/
methodMclustLLPA.R
122 lines (104 loc) · 3.19 KB
/
methodMclustLLPA.R
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
#' @include method.R
#' @name interface-mclust
#' @rdname interface-mclust
#' @title mclust interface
#' @seealso [lcMethodMclustLLPA] \link[mclust]{mclust-package}
#' @keywords internal
NULL
setClass('lcMethodMclustLLPA', contains = 'lcMethod')
setValidity('lcMethodMclustLLPA', function(object) {
if (isArgDefined(object, 'formula')) {
f = formula(object)
assert_that(hasSingleResponse(object$formula))
assert_that(!hasCovariates(object$formula), msg = 'covariates are not supported')
}
if (isArgDefined(object, 'nClusters')) {
assert_that(is.count(object$nClusters))
}
})
#' @export
#' @title Longitudinal latent profile analysis
#' @description Latent profile analysis or finite Gaussian mixture modeling.
#' @inheritParams lcMethodKML
#' @param ... Arguments passed to [mclust::Mclust].
#' The following external arguments are ignored: data, G, verbose.
#' @examples
#' data(latrendData)
#' if (require("mclust")) {
#' method <- lcMethodMclustLLPA("Y", id = "Id", time = "Time", nClusters = 3)
#' model <- latrend(method, latrendData)
#' }
#' @family lcMethod implementations
#' @references
#' \insertRef{scrucca2016mclust}{latrend}
lcMethodMclustLLPA = function(
response,
time = getOption('latrend.time'),
id = getOption('latrend.id'),
nClusters = 2,
...
) {
mc = match.call.all()
mc$Class = 'lcMethodMclustLLPA'
do.call(new, as.list(mc))
}
#' @rdname interface-mclust
setMethod('getArgumentDefaults', 'lcMethodMclustLLPA', function(object) {
.loadOptionalPackage('mclust')
c(
formals(lcMethodMclustLLPA),
formals(mclust::Mclust),
callNextMethod()
)
})
#' @rdname interface-mclust
setMethod('getArgumentExclusions', 'lcMethodMclustLLPA', function(object) {
union(
callNextMethod(),
c('data', 'G', 'verbose')
)
})
#' @rdname interface-mclust
setMethod('getCitation', 'lcMethodMclustLLPA', function(object, ...) {
citation('mclust')
})
#' @rdname interface-mclust
#' @inheritParams getName
setMethod('getName', 'lcMethodMclustLLPA', function(object) 'longitudinal latent profile analysis')
#' @rdname interface-mclust
setMethod('getShortName', 'lcMethodMclustLLPA', function(object) 'llpa')
#' @rdname interface-mclust
setMethod('prepareData', 'lcMethodMclustLLPA', function(method, data, verbose, ...) {
e = new.env()
valueColumn = responseVariable(method)
assert_that(noNA(data[[valueColumn]]), msg = 'data contains missing values')
# Data
e$data = tsmatrix(
data,
response = responseVariable(method),
id = idVariable(method),
time = timeVariable(method),
fill = FALSE
)
return(e)
})
#' @rdname interface-mclust
setMethod('compose', 'lcMethodMclustLLPA', function(method, envir = NULL) {
evaluate.lcMethod(method, try = TRUE, envir = envir)
})
#' @rdname interface-mclust
#' @inheritParams fit
setMethod('fit', 'lcMethodMclustLLPA', function(method, data, envir, verbose, ...) {
args = as.list(method, args = mclust::Mclust)
args$data = envir$data
args$G = method$nClusters
model = do.call(mclust::Mclust, args)
model$time = unique(data[[timeVariable(method)]]) %>% sort
new(
'lcModelMclustLLPA',
method = method,
data = data,
model = model,
clusterNames = make.clusterNames(method$nClusters)
)
})