Implemented lcFitRep and variants(#61)

DESCRIPTION

@@ -94,7 +94,9 @@ Collate:
     'matrix.R'
     'method.R'
     'meta-method.R'
+    'meta-fit.R'
     'meta-fit-converged.R'
+    'meta-fit-rep.R'
     'methodMatrix.R'
     'methodAKMedoids.R'
     'methodCrimCV.R'

NAMESPACE

@@ -109,6 +109,9 @@ export(latrendBoot)
 export(latrendCV)
 export(latrendRep)
 export(lcFitConverged)
+export(lcFitRep)
+export(lcFitRepMax)
+export(lcFitRepMin)
 export(lcMethodAkmedoids)
 export(lcMethodCrimCV)
 export(lcMethodDtwclust)
@@ -175,6 +178,7 @@ export(weighted.meanNA)
 export(which.weight)
 exportClasses(lcApproxModel)
 exportClasses(lcFitConverged)
+exportClasses(lcFitRep)
 exportClasses(lcMetaMethod)
 exportClasses(lcMethod)
 exportClasses(lcModel)

R/meta-fit-converged.R

@@ -1,13 +1,9 @@
-#' @include meta-method.R
+#' @include meta-fit.R
 
 #' @export
-#' @name lcFitMethods
 #' @rdname lcFitMethods
-#' @title Method fit modifiers
-#' @description A collection of special methods that adapt the fitting procedure of the underlying longitudinal cluster method.
-#' Supported fit methods:
-#' * `lcFitConverged`: Fit a method until a converged result is obtained.
 #' @examples
+#'
 #' data(latrendData)
 #' method <- lcMethodLMKM(Y ~ Time, id = "Id", time = "Time", nClusters = 2)
 #' metaMethod <- lcFitConverged(method, maxRep = 10)
@@ -50,9 +46,10 @@ setMethod('fit', 'lcFitConverged', function(method, data, envir, verbose) {
       return (model)
     } else {
       attempt = attempt + 1L
-      seed = sample.int(.Machine$integer.max, 1L)
-      set.seed(seed)
+
       if (has_lcMethod_args(getLcMethod(method), 'seed')) {
+        seed = sample.int(.Machine$integer.max, 1L)
+        set.seed(seed)
         # update fit method with new seed
         method@arguments$method = update(getLcMethod(method), seed = seed, .eval = TRUE)
       }

R/meta-fit-rep.R

@@ -0,0 +1,97 @@
+#' @include meta-fit.R
+
+#' @export
+#' @rdname lcFitMethods
+#' @examples
+#'
+#' data(latrendData)
+#' method <- lcMethodLMKM(Y ~ Time, id = "Id", time = "Time", nClusters = 2)
+#' repMethod <- lcFitRep(method, rep = 10, metric = "RSS", maximize = FALSE)
+#' repMethod
+#' model <- latrend(repMethod, latrendData)
+#'
+#' minMethod <- lcFitRepMin(method, rep = 10, metric = "RSS")
+#'
+#' maxMethod <- lcFitRepMax(method, rep = 10, metric = "ASW")
+setClass('lcFitRep', contains = 'lcMetaMethod')
+
+#' @export
+#' @rdname lcFitMethods
+#' @param rep The number of fits
+#' @param metric The internal metric to assess the fit.
+#' @param maximize Whether to maximize the metric. Otherwise, it is minimized.
+lcFitRep = function(method, rep = 10, metric, maximize) {
+  mc = match.call.all()
+  mc$method = getCall(method)
+  mc$Class = 'lcFitRep'
+  do.call(new, as.list(mc))
+}
+
+#' @export
+#' @rdname lcFitMethods
+lcFitRepMin = function(method, rep = 10, metric) {
+  mc = match.call.all()
+  mc$method = getCall(method)
+  mc$maximize = FALSE
+  mc$Class = 'lcFitRep'
+  do.call(new, as.list(mc))
+}
+
+#' @export
+#' @rdname lcFitMethods
+lcFitRepMax = function(method, rep = 10, metric) {
+  mc = match.call.all()
+  mc$method = getCall(method)
+  mc$maximize = TRUE
+  mc$Class = 'lcFitRep'
+  do.call(new, as.list(mc))
+}
+
+
+#' @rdname interface-metaMethods
+setMethod('fit', 'lcFitRep', function(method, data, envir, verbose) {
+  bestModel = NULL
+  mult = ifelse(method$maximize, 1, -1)
+  bestScore = -Inf
+
+  for (i in seq_len(method$rep)) {
+    cat(verbose, sprintf('Repeated fitting %d / %d', i, method$rep))
+    enter(verbose, level = verboseLevels$fine, suffix = '')
+    newModel = fit(getLcMethod(method), data = data, envir = envir, verbose = verbose)
+    newScore = metric(newModel, method$metric)
+    exit(verbose, level = verboseLevels$fine, suffix = '')
+
+    if (is.finite(newScore) && newScore * mult > bestScore) {
+      cat(
+        verbose,
+        sprintf('Found improved fit for %s = %g (previous is %g)', method$metric, newScore, mult * bestScore),
+        level = verboseLevels$fine
+      )
+      bestModel = newModel
+      bestScore = newScore
+    }
+
+    if (has_lcMethod_args(getLcMethod(method), 'seed')) {
+      # update seed for the next run
+      seed = sample.int(.Machine$integer.max, 1L)
+      set.seed(seed)
+      # update fit method with new seed
+      method@arguments$method = update(getLcMethod(method), seed = seed, .eval = TRUE)
+    }
+  }
+
+  bestModel
+})
+
+#' @rdname interface-metaMethods
+setMethod('validate', 'lcFitRep', function(method, data, envir = NULL, ...) {
+  callNextMethod()
+
+  validate_that(
+    has_lcMethod_args(method, c('rep', 'metric', 'maximize')),
+    is.count(method$rep),
+    is.string(method$metric),
+    method$metric %in% getInternalMetricNames(),
+    is.flag(method$maximize)
+  )
+})

R/meta-fit.R

@@ -0,0 +1,12 @@
+#' @include meta-method.R
+
+#' @name lcFitMethods
+#' @rdname lcFitMethods
+#' @title Method fit modifiers
+#' @description A collection of special methods that adapt the fitting procedure of the underlying longitudinal cluster method.
+#' Supported fit methods:
+#' * `lcFitConverged`: Fit a method until a converged result is obtained.
+#' * `lcFitRep`: Repeatedly fit a method and return the best result based on a given internal metric.
+#' * `lcFitRepMin`: Repeatedly fit a method and return the best result that minimizes the given internal metric.
+#' * `lcFitRepMax`: Repeatedly fit a method and return the best result that maximizes the given internal metric.
+NULL

tests/testthat/test-fit-rep.R

@@ -0,0 +1,25 @@
+test_that('specify default', {
+  metaMethod = lcFitRep(mRandom, metric = 'RSS', maximize = FALSE)
+  expect_s4_class(metaMethod, 'lcFitRep')
+  expect_true(has_lcMethod_args(metaMethod, 'rep'))
+})
+
+test_that('specify min', {
+  metaMethod = lcFitRepMin(mRandom, metric = 'RSS')
+  expect_false(metaMethod$maximize)
+})
+
+test_that('specify max', {
+  metaMethod = lcFitRepMax(mRandom, metric = 'ASW')
+  expect_true(metaMethod$maximize)
+})
+
+test_that('fit', {
+  metaMethod = lcFitRepMin(mRandom, metric = 'RSS')
+
+  out = capture.output({
+    model = latrend(metaMethod, testLongData, verbose = verboseLevels$finest)
+  }, type = 'message')
+
+  expect_match(paste0(out, collapse = '\n'), regexp = 'RSS')
+})