/
methodLMKM.R
105 lines (92 loc) · 2.98 KB
/
methodLMKM.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
setClass('lcMethodLMKM', contains = 'lcMethod')
#' @export
#' @title Two-step clustering through linear regression modeling and k-means
#' @inheritParams lcMethodFeature
#' @inheritParams lcMethodKML
#' @param formula A `formula` specifying the linear trajectory model.
#' @param center A `function` that computes the cluster center based on the original trajectories associated with the respective cluster.
#' By default, the mean is computed.
#' @param ... Arguments passed to [stats::lm].
#' The following external arguments are ignored: x, data, control, centers, trace.
#' @examples
#' data(latrendData)
#' method <- lcMethodLMKM(Y ~ Time, id = "Id", time = "Time", nClusters = 3)
#' model <- latrend(method, latrendData)
#' @family lcMethod implementations
lcMethodLMKM = function(
formula,
time = getOption('latrend.time'),
id = getOption('latrend.id'),
nClusters = 2,
center = meanNA,
standardize = scale,
...
) {
mc = match.call.all()
mc$Class = 'lcMethodLMKM'
do.call(new, as.list(mc))
}
#' @rdname interface-featureBased
setMethod('getArgumentDefaults', 'lcMethodLMKM', function(object) {
c(
formals(lcMethodLMKM),
formals(lm),
formals(kmeans),
callNextMethod()
)
})
#' @rdname interface-featureBased
setMethod('getArgumentExclusions', 'lcMethodLMKM', function(object) {
union(
callNextMethod(),
c('x', 'data', 'centers', 'trace')
)
})
#' @rdname interface-featureBased
setMethod('getName', 'lcMethodLMKM', function(object) 'lm-kmeans')
#' @rdname interface-featureBased
setMethod('getShortName', 'lcMethodLMKM', function(object) 'lmkm')
#' @rdname interface-featureBased
setMethod('prepareData', 'lcMethodLMKM', function(method, data, verbose) {
cat(verbose, 'Representation step...')
lmArgs = as.list(method, args = lm)
id = idVariable(method)
coefdata = as.data.table(data) %>%
.[, do.call(lm, c(lmArgs, data = list(.SD))) %>% coef() %>% as.list(), keyby = c(id)]
# construct the coefficient matrix
coefmat = subset(coefdata, select = -1) %>% as.matrix()
assert_that(nrow(coefmat) == uniqueN(data[[id]]))
e = new.env()
e$x = standardizeTrajectoryCoefMatrix(coefmat, method$standardize)
return(e)
})
#' @rdname interface-featureBased
setMethod('fit', 'lcMethodLMKM', function(method, data, envir, verbose, ...) {
cat(verbose, 'Cluster step...')
km = kmeans(
envir$x,
centers = method$nClusters,
trace = canShow(verbose, 'fine')
)
kmConv = method$nClusters == 1 || not(km$ifault)
conv = kmConv && (!hasName(envir, 'converged') || envir$converged)
new(
'lcModelLMKM',
method = method,
data = data,
model = km,
center = method$center,
converged = conv,
name = 'lmkm',
coefNames = colnames(envir$x),
trajectoryCoefs = envir$x,
clusterNames = make.clusterNames(method$nClusters)
)
})
#' @rdname interface-featureBased
setMethod('validate', 'lcMethodLMKM', function(method, data, envir = NULL, ...) {
callNextMethod()
validate_that(
has_lcMethod_args(method, 'formula')
)
})