From 829c47008188fed4df5c1d25c00cf898af9e4dc1 Mon Sep 17 00:00:00 2001 From: Niek Den Teuling Date: Fri, 4 Nov 2022 22:53:04 +0100 Subject: [PATCH] Implemented lcFitRep and variants(#61) --- DESCRIPTION | 2 + NAMESPACE | 4 ++ R/meta-fit-converged.R | 13 ++-- R/meta-fit-rep.R | 97 ++++++++++++++++++++++++++++++ R/meta-fit.R | 12 ++++ man/interface-metaMethods.Rd | 9 ++- man/lcFitMethods.Rd | 34 ++++++++++- tests/testthat/test-fit-rep.R | 25 ++++++++ tests/testthat/test-meta-methods.R | 22 ------- 9 files changed, 186 insertions(+), 32 deletions(-) create mode 100644 R/meta-fit-rep.R create mode 100644 R/meta-fit.R create mode 100644 tests/testthat/test-fit-rep.R delete mode 100644 tests/testthat/test-meta-methods.R diff --git a/DESCRIPTION b/DESCRIPTION index 62065c31..f5bfd535 100644 --- a/DESCRIPTION +++ b/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' diff --git a/NAMESPACE b/NAMESPACE index 76ea8191..42c343a3 100644 --- a/NAMESPACE +++ b/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) diff --git a/R/meta-fit-converged.R b/R/meta-fit-converged.R index 42d35b98..f6ed8896 100644 --- a/R/meta-fit-converged.R +++ b/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) } diff --git a/R/meta-fit-rep.R b/R/meta-fit-rep.R new file mode 100644 index 00000000..d2860908 --- /dev/null +++ b/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) + ) +}) diff --git a/R/meta-fit.R b/R/meta-fit.R new file mode 100644 index 00000000..d7f5e45c --- /dev/null +++ b/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 diff --git a/man/interface-metaMethods.Rd b/man/interface-metaMethods.Rd index 940b947b..b0e2c55f 100644 --- a/man/interface-metaMethods.Rd +++ b/man/interface-metaMethods.Rd @@ -1,5 +1,6 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/meta-method.R, R/meta-fit-converged.R +% Please edit documentation in R/meta-method.R, R/meta-fit-converged.R, +% R/meta-fit-rep.R \docType{class} \name{interface-metaMethods} \alias{interface-metaMethods} @@ -17,6 +18,8 @@ \alias{validate,lcMetaMethod-method} \alias{fit,lcFitConverged-method} \alias{validate,lcFitConverged-method} +\alias{fit,lcFitRep-method} +\alias{validate,lcFitRep-method} \title{lcMetaMethod abstract class} \usage{ \S4method{compose}{lcMetaMethod}(method, envir = NULL) @@ -44,6 +47,10 @@ \S4method{fit}{lcFitConverged}(method, data, envir, verbose) \S4method{validate}{lcFitConverged}(method, data, envir = NULL, ...) + +\S4method{fit}{lcFitRep}(method, data, envir, verbose) + +\S4method{validate}{lcFitRep}(method, data, envir = NULL, ...) } \description{ Virtual class for internal use. Do not use. diff --git a/man/lcFitMethods.Rd b/man/lcFitMethods.Rd index 5c7a82fd..92f487b4 100644 --- a/man/lcFitMethods.Rd +++ b/man/lcFitMethods.Rd @@ -1,29 +1,61 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/meta-fit-converged.R +% Please edit documentation in R/meta-fit.R, R/meta-fit-converged.R, +% R/meta-fit-rep.R \docType{class} \name{lcFitMethods} \alias{lcFitMethods} +\alias{lcFitConverged-class} \alias{lcFitConverged} +\alias{lcFitRep-class} +\alias{lcFitRep} +\alias{lcFitRepMin} +\alias{lcFitRepMax} \title{Method fit modifiers} \usage{ lcFitConverged(method, maxRep = Inf) + +lcFitRep(method, rep = 10, metric, maximize) + +lcFitRepMin(method, rep = 10, metric) + +lcFitRepMax(method, rep = 10, metric) } \arguments{ \item{method}{The \code{lcMethod} to use for fitting.} \item{maxRep}{The maximum number of fit attempts} + +\item{rep}{The number of fits} + +\item{metric}{The internal metric to assess the fit.} + +\item{maximize}{Whether to maximize the metric. Otherwise, it is minimized.} } \description{ A collection of special methods that adapt the fitting procedure of the underlying longitudinal cluster method. Supported fit methods: \itemize{ \item \code{lcFitConverged}: Fit a method until a converged result is obtained. +\item \code{lcFitRep}: Repeatedly fit a method and return the best result based on a given internal metric. +\item \code{lcFitRepMin}: Repeatedly fit a method and return the best result that minimizes the given internal metric. +\item \code{lcFitRepMax}: Repeatedly fit a method and return the best result that maximizes the given internal metric. } } \examples{ + data(latrendData) method <- lcMethodLMKM(Y ~ Time, id = "Id", time = "Time", nClusters = 2) metaMethod <- lcFitConverged(method, maxRep = 10) metaMethod model <- latrend(metaMethod, latrendData) + +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") } diff --git a/tests/testthat/test-fit-rep.R b/tests/testthat/test-fit-rep.R new file mode 100644 index 00000000..4160233e --- /dev/null +++ b/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') +}) diff --git a/tests/testthat/test-meta-methods.R b/tests/testthat/test-meta-methods.R deleted file mode 100644 index 44b44b3c..00000000 --- a/tests/testthat/test-meta-methods.R +++ /dev/null @@ -1,22 +0,0 @@ -method = lcMethodLMKM(Value ~ Assessment, id = 'Traj', time = 'Assessment', nClusters = 2) - -test_that('class', { - metaMethod = lcFitConverged(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('lcFitConverged', method = getCall(method), maxRep = Inf) - ) -})