Implemented lcMetaMethod and lcMetaConverged (#61)

DESCRIPTION

@@ -93,6 +93,8 @@ Collate:
     'make.R'
     'matrix.R'
     'method.R'
+    'meta-method.R'
+    'meta-method-converged.R'
     'methodMatrix.R'
     'methodAKMedoids.R'
     'methodCrimCV.R'

NAMESPACE

@@ -25,7 +25,6 @@ S3method(fitted,lcModelFunFEM)
 S3method(fitted,lcModelLcmmGMM)
 S3method(formula,lcMethod)
 S3method(formula,lcModel)
-S3method(getCall,lcMetaMethod)
 S3method(getCall,lcMethod)
 S3method(getCall,lcModel)
 S3method(logLik,lcModel)
@@ -109,6 +108,7 @@ export(latrendBatch)
 export(latrendBoot)
 export(latrendCV)
 export(latrendRep)
+export(lcMetaConverged)
 export(lcMethodAkmedoids)
 export(lcMethodCrimCV)
 export(lcMethodDtwclust)
@@ -174,6 +174,8 @@ export(validate)
 export(weighted.meanNA)
 export(which.weight)
 exportClasses(lcApproxModel)
+exportClasses(lcMetaConverged)
+exportClasses(lcMetaMethod)
 exportClasses(lcMethod)
 exportClasses(lcModel)
 exportMethods("$")

R/meta-method-converged.R

@@ -0,0 +1,55 @@
+#' @include meta-method.R
+
+#' @export
+#' @rdname lcMetaMethods
+#' @examples
+#' data(latrendData)
+#' method <- lcMethodLMKM(Y ~ Time, id = "Id", time = "Time", nClusters = 2)
+#' metaMethod <- lcMetaConverged(method, maxRep = 10)
+#' metaMethod
+#' model <- latrend(metaMethod, latrendData)
+setClass('lcMetaConverged', contains = 'lcMetaMethod')
+
+#' @export
+#' @rdname lcMetaMethods
+#' @param method The `lcMethod` to use for fitting.
+#' @param maxRep The maximum number of fit attempts
+lcMetaConverged = function(method, maxRep = Inf) {
+  mc = match.call.all()
+  mc$method = getCall(method)
+  mc$Class = 'lcMetaConverged'
+  do.call(new, as.list(mc))
+}
+
+
+#' @rdname lcMetaMethod-interface
+setMethod('fit', 'lcMetaConverged', function(method, data, envir, verbose) {
+  attempt = 1L
+  repeat {
+    enter(verbose, level = verboseLevels$fine, suffix = '')
+    model = fit(getLcMethod(method), data = data, envir = envir, verbose = verbose)
+    exit(verbose, level = verboseLevels$fine, suffix = '')
+
+    if (converged(model)) {
+      return (model)
+    } else if (attempt >= method$maxRep) {
+      warning(
+        sprintf(
+          'Failed to obtain converged result for %s within %d attempts.\n\tReturning last model.',
+          class(getLcMethod(method))[1],
+          method$maxRep
+        ),
+        immediate. = TRUE
+      )
+      return (model)
+    } else {
+      attempt = attempt + 1L
+
+      if (is.infinite(method$maxRep)) {
+        cat(verbose, sprintf('Method failed to converge. Retrying... attempt %d', attempt))
+      } else {
+        cat(verbose, sprintf('Method failed to converge. Retrying... attempt %d / %d', attempt, method$maxRep))
+      }
+    }
+  }
+})

R/meta-method.R

@@ -0,0 +1,81 @@
+#' @include method.R
+
+#' @export
+#' @name lcMetaMethods
+#' @rdname lcMetaMethods
+#' @aliases lcMetaMethod-class
+#' @title Meta methods
+#' @description `lcMetaMethod` classes are used to specify a repeated or adjusted fitting approach for the given longitudinal cluster method.
+#' Supported meta methods:
+#' * `lcMetaMethodConverged`: Fit a method until a converged result is obtained.
+setClass(
+  'lcMetaMethod',
+  contains = c('lcMethod', 'VIRTUAL')
+)
+
+as.character.lcMetaMethod = function(x, ...) {
+  c(
+    sprintf('%s encapsulating:', class(x)[1]),
+    paste0(' ', as.character(getLcMethod(x), ...)),
+    ' with meta-method arguments:',
+    paste0('  ', tail(as.character.lcMethod(x), -2L))
+  )
+}
+
+#' @export
+#' @name lcMetaMethod-interface
+#' @rdname lcMetaMethod-interface
+#' @title lcMetaMethod methods
+setMethod('compose', 'lcMetaMethod', function(method, envir = NULL) {
+  newMethod = method
+  newMethod@arguments$method = evaluate.lcMethod(getLcMethod(method), try = FALSE, envir = envir)
+  newMethod
+})
+
+#' @export
+#' @rdname lcMetaMethod-interface
+setMethod('getLcMethod', 'lcMetaMethod', function(object, ...) object$method)
+
+#' @export
+#' @rdname lcMetaMethod-interface
+setMethod('getName', 'lcMetaMethod', function(object, ...) getName(getLcMethod(object), ...))
+
+#' @export
+#' @rdname lcMetaMethod-interface
+setMethod('getShortName', 'lcMetaMethod', function(object, ...) getShortName(getLcMethod(object), ...))
+
+#' @export
+#' @rdname idVariable
+setMethod('idVariable', 'lcMetaMethod', function(object, ...) idVariable(getLcMethod(object), ...))
+
+#' @export
+#' @rdname lcMetaMethod-interface
+setMethod('preFit', 'lcMetaMethod', function(method, data, envir, verbose) {
+  preFit(getLcMethod(method), data = data, envir = envir, verbose = verbose)
+})
+
+#' @export
+#' @rdname lcMetaMethod-interface
+setMethod('prepareData', 'lcMetaMethod', function(method, data, verbose) {
+  prepareData(getLcMethod(method), data = data, verbose = verbose)
+})
+
+#' @export
+#' @rdname lcMetaMethod-interface
+setMethod('postFit', 'lcMetaMethod', function(method, data, model, envir, verbose) {
+  postFit(getLcMethod(method), data = data, model = model, envir = envir, verbose = verbose)
+})
+
+#' @export
+#' @rdname responseVariable
+setMethod('responseVariable', 'lcMetaMethod', function(object, ...) responseVariable(getLcMethod(object), ...))
+
+#' @export
+#' @rdname timeVariable
+setMethod('timeVariable', 'lcMetaMethod', function(object, ...) timeVariable(getLcMethod(object), ...))
+
+#' @export
+#' @rdname lcMetaMethod-interface
+setMethod('validate', 'lcMetaMethod', function(method, data, envir = NULL, ...) {
+  validate(getLcMethod(method), data = data, envir = envir, ...)
+})

tests/testthat/test-meta-methods.R

@@ -0,0 +1,42 @@
+method = lcMethodLMKM(Value ~ Assessment, id = 'Traj', time = 'Assessment', nClusters = 2)
+
+test_that('specify converged', {
+  metaMethod = lcMetaConverged(method)
+  expect_s4_class(metaMethod, 'lcMetaConverged')
+  expect_true(has_lcMethod_args(metaMethod, 'maxRep'))
+})
+
+test_that('specify converged with maxRep', {
+  metaMethod = lcMetaConverged(method, maxRep = 13)
+  expect_true(has_lcMethod_args(metaMethod, 'maxRep'))
+  expect_equal(metaMethod$maxRep, 13)
+})
+
+test_that('meta method class', {
+  metaMethod = lcMetaConverged(method)
+
+  expect_output(print(metaMethod), 'encapsulating')
+  expect_output(show(metaMethod), 'encapsulating')
+
+  expect_equal(getName(metaMethod), getName(method))
+  expect_equal(getShortName(metaMethod), getShortName(method))
+  expect_equal(getLabel(metaMethod), getLabel(method))
+  expect_equal(getLcMethod(metaMethod), method)
+
+  expect_equal(idVariable(metaMethod), idVariable(method))
+  expect_equal(timeVariable(metaMethod), timeVariable(method))
+  expect_equal(responseVariable(metaMethod), responseVariable(method))
+
+  expect_equal(
+    getCall(metaMethod),
+    call('lcMetaConverged', method = getCall(method), maxRep = Inf)
+  )
+})
+
+test_that('meta converged fit', {
+  metaMethod = lcMetaConverged(mRandom)
+
+  expect_no_warning({
+    model = latrend(metaMethod, testLongData)
+  })
+})