Nothing
R/method.R
In latrend: A Framework for Clustering Longitudinal Data
#' @name lcMethod-estimation
#' @aliases latrend-procedure lcMethod-steps
#' @title Longitudinal cluster method (`lcMethod`) estimation procedure
#' @description Each longitudinal cluster method represented by a [lcMethod class][lcMethod-class] implements a series of standardized steps that produce the estimated method as its output.
#' These steps, as part of the estimation procedure, are executed by the [latrend()] function and other functions prefixed by *"latrend"* (e.g., [latrendRep()], [latrendBoot()], [latrendCV()]).
#' @section Estimation procedure:
#' The steps for estimating a `lcMethod` object are defined and executed as follows:
#' \enumerate{
#' \item [compose()]: Evaluate and finalize the method argument values.
#' \item [validate()]: Check the validity of the method argument values in relation to the dataset.
#' \item [prepareData()]: Process the training data for fitting.
#' \item [preFit()]: Prepare environment for estimation, independent of training data.
#' \item [fit()]: Estimate the specified method on the training data, outputting an object inheriting from `lcModel`.
#' \item [postFit()]: Post-process the outputted `lcModel` object.
#' }
#'
#' The result of the fitting procedure is an [lcModel-class] object that inherits from the `lcModel` class.
#' @examples
#' data(latrendData)
#' method <- lcMethodLMKM(Y ~ Time, id = "Id", time = "Time")
#' model <- latrend(method, data = latrendData)
#' summary(model)
#' @seealso [lcMethod-class] [latrend]
NULL
#' @export
#' @name lcMethod-class
#' @aliases lcMethod
#' @title lcMethod class
#' @description `lcMethod` objects represent the specification of a method for longitudinal clustering.
#' Furthermore, the object class contains the logic for estimating the respective method.
#'
#' You can specify a longitudinal cluster method through one of the method-specific constructor functions,
#' e.g., [lcMethodKML()], [lcMethodLcmmGBTM()], or [lcMethodDtwclust()].
#' Alternatively, you can instantiate methods through [methods::new()], e.g., by calling `new("lcMethodKML", response = "Value")`.
#' In both cases, default values are specified for omitted arguments.
#'
#' @section Method arguments:
#' An `lcMethod` objects represent the specification of a method with a set of configurable parameters (referred to as arguments).
#'
#' Arguments can be of any type.
#' It is up to the `lcMethod` implementation of [validate()] to ensure that the required arguments are present and are of the expected type.
#'
#' Arguments can have almost any name. Exceptions include the names `"data"`, `"envir"`, and `"verbose"`.
#' Furthermore, argument names may not start with a period (`"."`).
#'
#' Arguments cannot be directly modified, i.e., `lcMethod` objects are immutable.
#' Modifying an argument involves creating an altered copy through the [update.lcMethod] method.
#'
#' @section Implementation:
#' The base class `lcMethod` provides the logic for storing, evaluating, and printing the method parameters.
#'
#' Subclasses of `lcMethod` differ only in the [fitting procedure logic][lcMethod-estimation].
#'
#' To implement your own `lcMethod` subclass, you'll want to implement at least the following functions:
#' \itemize{
#' \item [fit()]: The main function for estimating your method.
#' \item [getName()]: The name of your method.
#' \item [getShortName()]: The abbreviated name of your method.
#' \item [getArgumentDefaults()]: Sensible default argument values to your method.
#' }
#'
#' For more complex methods, the additional functions as part of the [fitting procedure][lcMethod-estimation] will be of use.
#'
#' @details Because the `lcMethod` arguments may be unevaluated, argument retrieval functions such as `[[` accept an `envir` argument.
#' A default `environment` can be assigned or obtained from a `lcMethod` object using the `environment()` function.
#' @seealso [environment]
#' @slot arguments A `list` representing the arguments of the `lcMethod` object.
#' Arguments are not evaluated upon creation of the method object.
#' Instead, arguments are stored similar to a `call` object, and are only evaluated when a method is fitted.
#' Do not modify or access.
#' @slot sourceCalls A list of calls for tracking the original call after substitution.
#' Used for printing objects which require too many characters (e.g. ,function definitions, matrices).
#' Do not modify or access.
#' @examples
#' method <- lcMethodLMKM(Y ~ Time, id = "Id", time = "Time", nClusters = 2)
#' method
#'
#' method <- new("lcMethodLMKM", formula = Y ~ Time, id = "Id", time = "Time", nClusters = 2)
#'
#' # get argument names
#' names(method)
#'
#' # evaluate argument
#' method$nClusters
#'
#' # create a copy with updated nClusters argument
#' method3 <- update(method, nClusters = 3)
#' @family lcMethod implementations
#' @family lcMethod functions
setClass('lcMethod', slots = c(arguments = 'environment', sourceCalls = 'list'))
#. initialize ####
#' @title lcMethod initialization
#' @description Initialization of `lcMethod` objects, converting arbitrary arguments to arguments as part of an `lcMethod` object.
#' @param .Object The newly allocated `lcMethod` object.
#' @param ... Other method arguments.
#' @examples
#' new("lcMethodLMKM", formula = Y ~ Time, id = "Id", time = "Time")
setMethod('initialize', 'lcMethod', function(.Object, ...) {
.Object <- callNextMethod(.Object)
.defaults = getArgumentDefaults(.Object)
.exclude = getArgumentExclusions(.Object)
assert_that(
is.list(.defaults),
is_named(.defaults),
msg = sprintf(
'Implementation error for %s object: getArgumentDefaults() must return a named list',
class(.Object)[1]
)
)
assert_that(
is.character(.exclude),
msg = sprintf(
'Implementation error for %s object: getArgumentExclusions() must return character vector',
class(.Object)[1]
)
)
# drop arguments without defaults (empty symbols)
symMask = vapply(.defaults, is.symbol, FUN.VALUE = TRUE)
dropSymMask = vapply(.defaults[symMask], nchar, FUN.VALUE = 0) == 0
.defaults[which(symMask)[dropSymMask]] = NULL
# drop default arguments that should be excluded
defArgs = .defaults[setdiff(names(.defaults), .exclude)]
# process user arguments
mc = match.call.all()
userArgs = as.list(mc) %>%
.[nchar(names(.)) > 0]
userArgs[names(formals())] = NULL
if (any(hasName(userArgs, .exclude))) {
warning(
sprintf(
'arguments (%s) cannot be defined for this lcMethod class. These arguments will be ignored.',
paste0(intersect(.exclude, names(userArgs)), collapse = ', ')
)
)
}
args = modifyList(defArgs, userArgs, keep.null = TRUE)
# construct arguments environment
argEnv = list2env(rev(args), hash = FALSE)
.Object@arguments = argEnv
validObject(.Object)
.Object
})
#. validity ####
setValidity('lcMethod', function(object) {
errors = validate_that(
all(nchar(names(object)) > 0),
msg = 'lcMethod argument names cannot be empty'
)
errors = errors %c% validate_that(
!any(startsWith(names(object), '.')),
msg = sprintf(
'Cannot construct %s: lcMethod argument names cannot start with "."\nYou should rename argument(s) %s',
class(object)[1],
paste0('"', names(object)[startsWith(names(object), '.')], '"', collapse = ', ')
)
)
errors = errors %c% validate_that(!has_name(object, 'data'), msg = 'lcMethod argument name cannot be "data"')
errors = errors %c% validate_that(!has_name(object, 'envir'), msg = 'lcMethod argument name cannot be "envir"')
errors = errors %c% validate_that(!has_name(object, 'verbose'), msg = 'lcMethod argument name cannot be "verbose"')
if (isArgDefined(object, 'nClusters')) {
errors = errors %c% validate_that(is.scalar(object$nClusters))
errors = errors %c% validate_that(is.na(object$nClusters) || is.count(object$nClusters))
}
errors[errors != TRUE]
})
#. $ ####
#' @export
#' @name [[,lcMethod-method
#' @rdname indexy
#' @aliases $,lcMethod-method
#' @param name The argument name, as `character`.
#' @examples
#' method <- lcMethodLMKM(Y ~ Time, id = "Id", time = "Time", nClusters = 3)
#' method$nClusters # 3
setMethod('$', 'lcMethod', function(x, name) {
x[[name]]
})
#. [[ ####
#' @export
#' @rdname indexy
#' @title Retrieve and evaluate a lcMethod argument by name
#' @param x The `lcMethod` object.
#' @param i Name or index of the argument to retrieve.
#' @param eval Whether to evaluate the call argument (enabled by default).
#' @param envir The `environment` in which to evaluate the argument. This argument is only applicable when `eval = TRUE`.
#' @return The argument `call` or evaluation result.
#' @examples
#' m = lcMethodLMKM(Y ~ Time, id = "Id", time = "Time", nClusters = 5)
#' m[["nClusters"]] # 5
#'
#' k = 2
#' m = lcMethodLMKM(Y ~ Time, id = "Id", time = "Time", nClusters = k)
#' m[["nClusters", eval=FALSE]] # k
#' @family lcMethod functions
setMethod('[[', 'lcMethod', function(x, i, eval = TRUE, envir = NULL) {
envir = .selectEnvironment(x, parent.frame(3), envir)
if (is.character(i)) {
assert_that(has_name(x, i), msg = sprintf('method does not have an argument named "%s"', i))
arg = get(i, envir = x@arguments)
} else {
argName = names(x)[i]
assert_that(!is.na(argName), msg = sprintf('index "%s" exceeded argument name options', i))
arg = get(i, envir = x@arguments)
}
if (eval) {
# within-method scope
value = tryCatch({
eval(
arg,
envir = mget(setdiff(names(x@arguments), i), envir = x@arguments),
enclos = envir
)
}, error = function(e) {
tryCatch({
eval(arg, envir = envir)
}, error = function(e2) {
# try evaluation within package scope instead
tryCatch({
eval(arg, envir = parent.env(getNamespace(.packageName)))
}, error = function(e3) {
stop(
sprintf('error in evaluating lcMethod argument "%s" with expression "%s":\n\t%s',
i, deparse(e2$call), e2$message
)
)
})
})
})
} else {
value = arg
}
if (is.formula(value)) {
environment(value) = new.env()
}
return(value)
})
as.lcMethod = function(x, ..., envir = parent.frame()) {
assert_that(is.lcMethod(x) || is.character(x))
if (is.character(x)) {
assert_that(
methods::isClass(x),
msg = sprintf(
'Cannot instantiate lcMethod object of class "%1$s": Class "%1$s" is not defined',
class(x)[1]
)
)
assert_that(
methods::extends(x, 'lcMethod'),
msg = sprintf(
'Cannot instantiate object of class "%1$s" as lcMethod: "%1$s" does not inherit from lcMethod class',
class(x)[1]
)
)
x = new(x, ...)
} else {
assert_that(is_class_defined(x))
update(x, ..., envir = envir)
}
}
#' @exportS3Method base::as.character
as.character.lcMethod = function(x, ..., eval = FALSE, width = 40, prefix = '', envir = NULL) {
assert_that(
is.lcMethod(x),
is.flag(eval)
)
envir = .selectEnvironment(x, parent.frame(), envir)
if (isTRUE(eval)) {
x = evaluate.lcMethod(x, envir = envir)
}
arg2char = function(a) {
if (is.null(a)) {
'NULL'
} else if (is.character(a)) {
paste0('"', a, '"', collapse = ', ')
} else if (is.atomic(a)) {
paste0(as.character(a), collapse = ', ')
} else {
deparse(a) %>% paste0(collapse = '')
}
}
argNames = names(x)
chrValues = lapply(x@arguments, arg2char) %>% unlist()
assert_that(all(vapply(chrValues, length, FUN.VALUE = 0) == 1))
sourceMask = vapply(chrValues, nchar, FUN.VALUE = 0) > width &
argNames %in% names(x@sourceCalls)
chrSource = lapply(x@sourceCalls[argNames[sourceMask]], arg2char) %>% unlist()
chrValues[sourceMask] = paste0('`', chrSource, '`')
args = vapply(chrValues, strtrim, width = width, FUN.VALUE = '')
header = sprintf('%s specifying "%s"', class(x)[1], getName(x))
if (length(args) > 0) {
body = sprintf('%s%-16s%s', prefix, paste0(argNames, ':'), args)
} else {
body = 'no arguments'
}
c(header, body)
}
#' @exportS3Method base::as.list
#' @title Extract the method arguments as a list
#' @param x The `lcMethod` object.
#' @param ... Additional arguments.
#' @param args A `character vector` of argument names to select. Only available arguments are returned.
#' Alternatively, a `function` or `list` of `function`s, whose formal arguments will be selected from the method.
#' @param eval Whether to evaluate the arguments.
#' @param expand Whether to return all method arguments when `"..."` is present among the requested argument names.
#' @param envir The `environment` in which to evaluate the arguments. If `NULL`, the environment associated with the object is used. If not available, the `parent.frame()` is used.
#' @return A `list` with the argument `call`s or evaluated results depending on the value for `eval`.
#' @examples
#' data(latrendData)
#' method <- lcMethodLMKM(Y ~ Time, id = "Id", time = "Time")
#' as.list(method)
#'
#' as.list(method, args = c("id", "time"))
#'
#' if (require("kml")) {
#' method <- lcMethodKML("Y", id = "Id", time = "Time")
#' as.list(method)
#'
#' # select arguments used by kml()
#' as.list(method, args = kml::kml)
#'
#' # select arguments used by either kml() or parALGO()
#' as.list(method, args = c(kml::kml, kml::parALGO))
#' }
#' @family lcMethod functions
as.list.lcMethod = function(x, ..., args = names(x), eval = TRUE, expand = FALSE, envir = NULL) {
assert_that(
is.lcMethod(x),
is.flag(eval),
is.flag(expand)
)
envir = .selectEnvironment(x, parent.frame(), envir)
if (is.function(args)) {
argNames = formalArgs(args)
}
else if (is.list(args)) {
# functions special case
argNames = lapply(args, formalArgs) %>%
Reduce(union, .)
} else {
assert_that(is.character(args))
argNames = args
}
# filter arguments
if (isTRUE(expand) && '...' %in% argNames) {
selArgNames = argNames
} else {
selArgNames = intersect(argNames, names(x))
}
if (isTRUE(eval)) {
# full evaluation
method = evaluate.lcMethod(x, envir = envir)
} else {
method = x
}
as.list(method@arguments)[selArgNames]
}
#' @exportS3Method base::as.data.frame
#' @title Convert lcMethod arguments to a list of atomic types
#' @description Converts the arguments of a `lcMethod` to a named `list` of [atomic] types.
#' @inheritParams as.list.lcMethod
#' @param x `lcMethod` to be coerced to a `character` `vector`.
#' @param ... Additional arguments.
#' @param eval Whether to evaluate the arguments in order to replace expression if the resulting value is of a class specified in `evalClasses`.
#' @param nullValue Value to use to represent the `NULL` type. Must be of length 1.
#' @return A single-row `data.frame` where each columns represents an argument call or evaluation.
#' @family lcMethod functions
as.data.frame.lcMethod = function(x, ..., eval = TRUE, nullValue = NA, envir = NULL) {
assert_that(
is.lcMethod(x),
is.flag(eval),
length(nullValue) == 1
)
if (isTRUE(eval)) {
envir = .selectEnvironment(x, parent.frame(), envir)
evalClasses = c(
'NULL',
'logical',
'numeric',
'complex',
'integer',
'character',
'factor'
)
method = evaluate.lcMethod(x, classes = evalClasses, envir = envir)
} else {
method = x
}
argList = as.list(method, eval = FALSE)
dfList = lapply(argList, function(a) {
if (is.null(a)) {
nullValue
} else if (is.atomic(a)) {
if (length(a) > 1) {
deparse(a) %>% as.character() %>% paste0(collapse = '')
} else {
a
}
} else {
deparse(a) %>% paste0(collapse = '')
}
})
argValueLengths = vapply(dfList, length, FUN.VALUE = 0)
errMask = argValueLengths != 1
assert_that(
all(argValueLengths == 1),
msg = sprintf(
'as.data.frame.lcMethod(%s) requires all method arguments to be/evaluate to length 1.\nArguments that violate this requirement: %s',
class(x)[1],
paste0('"', names(argValueLengths)[errMask], '"(', argValueLengths[errMask], ')', collapse = ', ')
)
)
as.data.frame(dfList, stringsAsFactors = FALSE)
}
#' @noRd
#' @title Select the preferred environment
#' @description Returns envir if specified. Otherwise, returns environment(object) if specified. The defaultEnvir is returned when the former two are NULL.
#' @keywords internal
.selectEnvironment = function(object, defaultEnvir, envir) {
assert_that(
is.lcMethod(object),
is.null(defaultEnvir) || is.environment(defaultEnvir),
is.null(envir) || is.environment(envir)
)
if (!is.null(envir)) {
envir
} else if (!is.null(environment(object))) {
environment(object)
} else {
defaultEnvir
}
}
#. compose ####
#' @export
#' @rdname compose
#' @aliases compose,lcMethod-method
#' @title `lcMethod` estimation step: compose an lcMethod object
#' @description Note: this function should not be called directly, as it is part of the `lcMethod` [estimation procedure][lcMethod-estimation].
#' For fitting an `lcMethod` object to a dataset, use the [latrend()] function or [one of the other standard estimation functions][latrend-estimation].
#'
#' The `compose()` function of the `lcMethod` object evaluates and finalizes the `lcMethod` arguments.
#'
#' The default implementation returns an updated object with all arguments having been evaluated.
#' @param method The `lcMethod` object.
#' @param envir The `environment` in which the `lcMethod` should be evaluated
#' @return The evaluated and finalized `lcMethod` object.
#' @inheritSection lcMethod-estimation Estimation procedure
#' @section Implementation:
#' In general, there is no need to extend this method for a specific method, as all arguments are automatically evaluated by the `compose,lcMethod` method.
#'
#' However, in case there is a need to extend processing or to prevent evaluation of specific arguments (e.g., for handling errors), the method can be overridden for the specific `lcMethod` subclass.
#' \preformatted{
#' setMethod("compose", "lcMethodExample", function(method, envir = NULL) {
#' newMethod <- callNextMethod()
#' # further processing
#' return(newMethod)
#' })
#' }
#' @seealso [evaluate.lcMethod]
setMethod('compose', 'lcMethod', function(method, envir = NULL) {
evaluate.lcMethod(method, try = FALSE, envir = envir)
})
# . fit ####
#' @export
#' @rdname fit
#' @aliases fit,lcMethod-method
#' @title `lcMethod` estimation step: logic for fitting the method to the processed data
#' @description Note: this function should not be called directly, as it is part of the `lcMethod` [estimation procedure][lcMethod-estimation].
#' For fitting an `lcMethod` object to a dataset, use the [latrend()] function or [one of the other standard estimation functions][latrend-estimation].
#'
#' The `fit()` function of the `lcMethod` object estimates the model with the evaluated method specification, processed training data, and prepared environment.
#' @inheritParams preFit
#' @param envir The `environment` containing variables generated by [prepareData()] and [preFit()].
#' @section Implementation:
#' This method should be implemented for all `lcMethod` subclasses.
#'
#' \preformatted{
#' setMethod("fit", "lcMethodExample", function(method, data, envir, verbose) {
#' # estimate the model or cluster parameters
#' coefs <- FIT_CODE
#'
#' # create the lcModel object
#' new("lcModelExample",
#' method = method,
#' data = data,
#' model = coefs,
#' clusterNames = make.clusterNames(method$nClusters)
#' )
#' })
#' }
#' @inheritSection lcMethod-estimation Estimation procedure
setMethod('fit', 'lcMethod', function(method, data, envir, verbose) {
stop(
sprintf('method cannot be estimated because the fit() function is not implemented for lcMethod of class %1$s.
define the fit() method using:
\tsetMethod("fit", "%1$s", function(method, data, verbose) {
\t\t<your code returning a lcModel-extended class here>
\t})")', class(method)[1])
)
})
#' @exportS3Method stats::formula
#' @title Extract formula
#' @description Extracts the associated `formula` for the given distributional parameter.
#' @inheritParams as.list.lcMethod
#' @param x The `lcMethod` object.
#' @param ... Additional arguments.
#' @param what The distributional parameter to which this formula applies. By default, the formula specifies `"mu"`.
#' @return The `formula` for the given distributional parameter.
#' @examples
#' method <- lcMethodLMKM(Y ~ Time, id = "Id", time = "Time")
#' formula(method) # Y ~ Time
#' @family lcMethod functions
formula.lcMethod = function(x, what = 'mu', envir = NULL, ...) {
assert_that(
is.lcMethod(x),
is.scalar(what),
is.character(what)
)
envir = .selectEnvironment(x, parent.frame(), envir)
if (what == 'mu') {
f = x$formula
} else {
f = x[[paste0('formula.', what)]]
}
environment(f) = envir
f
}
#' @exportS3Method stats::getCall
getCall.lcMethod = function(x, ...) {
assert_that(is.lcMethod(x))
do.call(call, c(class(x)[1], eapply(x@arguments, enquote)))
}
#. getArgumentDefaults ####
#' @export
#' @rdname getArgumentDefaults
#' @aliases getArgumentDefaults,lcMethod-method
#' @description Returns the default arguments associated with the respective `lcMethod` subclass.
#' These arguments are automatically included into the `lcMethod` object during initialization.
#'
#' @section Implementation:
#' Although implementing this method is optional, it prevents users from
#' having to specify all arguments every time they want to create a method specification.
#'
#' In this example, most of the default arguments are defined as arguments of the function
#' `lcMethodExample`, which we can include in the list by calling [formals]. Copying the arguments from functions
#' is especially useful when your method implementation is based on an existing function.
#' \preformatted{
#' setMethod("getArgumentDefaults", "lcMethodExample", function(object) {
#' list(
#' formals(lcMethodExample),
#' formals(funFEM::funFEM),
#' extra = Value ~ 1,
#' tol = 1e-4,
#' callNextMethod()
#' )
#' })
#' }
#'
#' It is recommended to add `callNextMethod()` to the end of the list.
#' This enables inheriting the default arguments from superclasses.
#' @seealso [lcMethod]
#' @family lcMethod implementations
setMethod('getArgumentDefaults', 'lcMethod', function(object) {
set_names(list(), character(0))
})
#. getCitation ####
#' @rdname getCitation
#' @aliases getCitation,lcMethod-method
setMethod('getCitation', 'lcMethod', function(object, ...) {
utils::citation(package = 'base')[0]
})
#. getArgumentExclusions ####
#' @export
#' @rdname getArgumentExclusions
#' @aliases getArgumentExclusions,lcMethod-method
#' @section Implementation:
#' This function only needs to be implemented if you want to avoid users from specifying
#' redundant arguments or arguments that are set automatically or conditionally on other arguments.
#'
#' \preformatted{
#' setMethod("getArgumentExclusions", "lcMethodExample", function(object) {
#' c(
#' "doPlot",
#' "verbose",
#' callNextMethod()
#' )
#' })
#'
#' Adding `callNextMethod()` to the end of the return vector enables inheriting exclusions from superclasses.
#' }
#' @seealso [lcMethod] [getArgumentExclusions]
#' @family lcMethod implementations
setMethod('getArgumentExclusions', 'lcMethod', function(object) {
c('verbose', 'envir', 'data')
})
#. getLabel ####
#' @export
#' @rdname getLabel
#' @aliases getLabel,lcMethod-method
#' @description Extracts the assigned label from the given `lcMethod` or `lcModel` object.
#' By default, the label is determined from the `"label"` argument of the `lcMethod` object.
#' The label of an `lcModel` object is set upon estimation by [latrend()] to the label of its associated `lcMethod` object.
#' @seealso [getName] [getShortName]
#' @examples
#' method <- lcMethodLMKM(Y ~ Time, time = "Time")
#' getLabel(method) # ""
#'
#' getLabel(update(method, label = "v2")) # "v2"
setMethod('getLabel', 'lcMethod', function(object, ...) {
if (hasName(object, 'label')) {
object$label
} else {
''
}
})
#. getName ####
#' @export
#' @rdname getName
#' @aliases getName,lcMethod-method
#' @section Implementation:
#' When implementing your own `lcMethod` subclass, override these methods to provide full and abbreviated names.
#' \preformatted{
#' setMethod("getName", "lcMethodExample", function(object) "example name")
#'
#' setMethod("getShortName", "lcMethodExample", function(object) "EX")
#' }
#'
#' Similar methods can be implemented for your `lcModel` subclass,
#' however in practice this is not needed as the names are determined by default from the `lcMethod` object that was used to fit the `lcModel` object.
#'
#' @examples
#' method <- lcMethodLMKM(Y ~ Time)
#' getName(method) # "lm-kmeans"
setMethod('getName', 'lcMethod', function(object, ...) 'undefined')
#' @export
#' @rdname getName
#' @aliases getName,NULL-method
setMethod('getName', 'NULL', function(object, ...) 'null')
#. getShortName ####
#' @export
#' @rdname getName
#' @aliases getShortName,lcMethod-method
#' @examples
#' method <- lcMethodLMKM(Y ~ Time)
#' getShortName(method) # "LMKM"
setMethod('getShortName', 'lcMethod', function(object, ...) getName(object, ...))
#' @export
#' @rdname getName
#' @aliases getShortName,NULL-method
setMethod('getShortName', 'NULL', function(object, ...) 'nul')
#. idVariable ####
#' @export
#' @rdname idVariable
#' @aliases idVariable,lcMethod-method
#' @examples
#' method <- lcMethodLMKM(Y ~ Time, id = "Traj")
#' idVariable(method) # "Traj"
#'
setMethod('idVariable', 'lcMethod', function(object, ...) object$id)
#' @export
#' @title Check whether the argument of a lcMethod has a defined value.
#' @description Determines whether the associated argument value is defined. If the argument value is of type `language`, the argument is evaluated to see if it can be resolved within its `environment`.
#' @param object The `lcMethod` object.
#' @param name The name of the argument, as `character`.
#' @param envir The `environment` to evaluate the arguments in. If `NULL`, the argument is not evaluated.
#' @keywords internal
isArgDefined = function(object, name, envir = environment(object)) {
assert_that(
is.lcMethod(object),
is.character(name),
is.scalar(name),
is.environment(envir) || is.null(envir)
)
if (!hasName(object, name)) {
return(FALSE)
}
arg = object[[name[1], eval = FALSE]]
if (is.language(arg)) {
arg = try(object[[name[1], envir = envir]], silent = TRUE)
return(!is(arg, 'try-error'))
} else {
return(TRUE)
}
}
#' @export
#' @name latrend-is
#' @rdname is
#' @title Check if object is of Class
#' @param x The object to check the class of.
#' @return `scalar logical`
#' @keywords internal
is.lcMethod = function(x) {
isS4(x) && inherits(x, 'lcMethod')
}
#. length ####
#' @export
#' @name names,lcMethod-method
#' @rdname names-lcMethod-method
#' @aliases length,lcMethod-method
#' @return The number of arguments, as `scalar integer`.
setMethod('length', 'lcMethod', function(x) {
length(x@arguments)
})
#. names ####
#' @export
#' @title lcMethod argument names
#' @description Extract the argument names or number of arguments from an `lcMethod` object.
#' @param x The `lcMethod` object.
#' @return A `character vector` of argument names.
#' @examples
#' method <- lcMethodLMKM(Y ~ Time)
#' names(method)
#' length(method)
#' @family lcMethod functions
setMethod('names', 'lcMethod', function(x) {
argNames = names(x@arguments)
if (is.null(argNames)) {
character(0)
} else {
argNames
}
})
# . preFit ####
#' @rdname preFit
#' @aliases preFit,lcMethod-method
#' @title `lcMethod` estimation step: method preparation logic
#' @description Note: this function should not be called directly, as it is part of the `lcMethod` [estimation procedure][lcMethod-estimation].
#' For fitting an `lcMethod` object to a dataset, use the [latrend()] function or [one of the other standard estimation functions][latrend-estimation].
#'
#' The `preFit()` function of the `lcMethod` object performs preparatory work that is needed for fitting the method but should not be counted towards the method estimation time.
#' The work is added to the provided `environment`, allowing the [fit()] function to make use of the prepared work.
#' @inheritParams prepareData
#' @param envir The `environment` containing additional data variables returned by [prepareData()].
#' @section Implementation:
#' \preformatted{
#' setMethod("preFit", "lcMethodExample", function(method, data, envir, verbose) {
#' # update envir with additional computed work
#' envir$x <- INTENSIVE_OPERATION
#' return(envir)
#' })
#' }
#' @inheritSection lcMethod-estimation Estimation procedure
#' @return The updated `environment` that will be passed to [fit()].
setMethod('preFit', 'lcMethod', function(method, data, envir, verbose) {
envir
})
# . prepareData ####
#' @rdname prepareData
#' @aliases prepareData,lcMethod-method
#' @title `lcMethod` estimation step: logic for preparing the training data
#' @description Note: this function should not be called directly, as it is part of the `lcMethod` [estimation procedure][lcMethod-estimation].
#' For fitting an `lcMethod` object to a dataset, use the [latrend()] function or [one of the other standard estimation functions][latrend-estimation].
#'
#' The `prepareData()` function of the `lcMethod` object processes the training data prior to fitting the method.
#' Example uses:
#' \itemize{
#' \item Transforming the data to another format, e.g., a matrix.
#' \item Truncating the response variable.
#' \item Computing derived covariates.
#' \item Creating additional data objects.
#' }
#' The computed variables are stored in an `environment` which is passed to the [preFit()] function for further processing.
#'
#' By default, this method does not do anything.
#'
#' @inheritParams validate
#' @param verbose A [R.utils::Verbose] object indicating the level of verbosity.
#' @return An `environment` with the prepared data variable(s) that will be passed to [preFit()].
#' @section Implementation:
#' A common use case for this method is when the internal method fitting procedure expects the data in a different format.
#' In this example, the method converts the training data `data.frame` to a `matrix` of repeated and aligned trajectory measurements.
#' \preformatted{
#' setMethod("prepareData", "lcMethodExample", function(method, data, verbose) {
#' envir = new.env()
#' # transform the data to matrix
#' envir$dataMat = tsmatrix(data,
#' id = idColumn, time = timeColumn, response = valueColumn)
#' return(envir)
#' })
#' }
#' @inheritSection lcMethod-estimation Estimation procedure
setMethod('prepareData', 'lcMethod', function(method, data, verbose) {
new.env(parent = emptyenv())
})
# . postFit ####
#' @rdname postFit
#' @aliases postFit,lcMethod-method
#' @title `lcMethod` estimation step: logic for post-processing the fitted lcModel
#' @description Note: this function should not be called directly, as it is part of the `lcMethod` [estimation procedure][lcMethod-estimation].
#' For fitting an `lcMethod` object to a dataset, use the [latrend()] function or [one of the other standard estimation functions][latrend-estimation].
#'
#' The `postFit()` function of the `lcMethod` object defines how the `lcModel` object returned by [fit()] should be post-processed.
#' This can be used, for example, to:
#' \itemize{
#' \item Resolve label switching.
#' \item Clean up the internal model representation.
#' \item Correct estimation errors.
#' \item Compute additional metrics.
#' }
#' By default, this method does not do anything. It merely returns the original `lcModel` object.
#'
#' This is the last step in the `lcMethod` fitting procedure. The `postFit` method may be called again on fitted `lcModel` objects, allowing post-processing to be updated for existing models.
#'
#' @inheritParams fit
#' @param model The `lcModel` object returned by [fit()].
#' @return The updated `lcModel` object.
#' @section Implementation:
#' The method is intended to be able to be called on previously fitted `lcModel` objects as well, allowing for potential bugfixes or additions to previously fitted models.
#' Therefore, when implementing this method, ensure that you do not discard information from the model which would prevent the method from being run a second time on the object.
#'
#' In this example, the `lcModelExample` class is assumed to be defined with a slot named `"centers"`:
#' \preformatted{
#' setMethod("postFit", "lcMethodExample", function(method, data, model, envir, verbose) {
#' # compute and store the cluster centers
#' model@centers <- INTENSIVE_COMPUTATION
#' return(model)
#' })
#' }
#' @inheritSection lcMethod-estimation Estimation procedure
setMethod('postFit', 'lcMethod', function(method, data, model, envir, verbose) {
model
})
#' @exportS3Method base::print
#' @title Print the arguments of an lcMethod object
#' @param x The `lcMethod` object.
#' @param eval Whether to print the evaluated argument values.
#' @param width Maximum number of characters per argument.
#' @param envir The environment in which to evaluate the arguments when `eval = TRUE`.
#' @param ... Not used.
print.lcMethod = function(x, ..., eval = FALSE, width = 40, envir = NULL) {
out = as.character(x, ..., eval = eval, width = width, envir = envir, prefix = ' ')
cat(out, sep = '\n')
}
#' @exportS3Method R.utils::evaluate
#' @importFrom R.utils evaluate
#' @title Substitute the call arguments for their evaluated values
#' @description Substitutes the call arguments if they can be evaluated without error.
#' @inheritParams as.list.lcMethod
#' @param object The `lcMethod` object.
#' @param classes Substitute only arguments with specific class types. By default, all types are substituted.
#' @param try Whether to try to evaluate arguments and ignore errors (the default), or to fail on any argument evaluation error.
#' @param exclude Arguments to exclude from evaluation.
#' @param ... Not used.
#' @return A new `lcMethod` object with the substituted arguments.
#' @seealso [compose]
#' @family lcMethod functions
evaluate.lcMethod = function(
object,
classes = 'ANY',
try = TRUE,
exclude = character(),
envir = NULL,
...
) {
rawObject = as.lcMethod(object)
assert_that(is.character(classes))
envir = .selectEnvironment(rawObject, parent.frame(), envir)
argNames = names(rawObject)
if (isTRUE(try)) {
evalMask = vapply(
argNames,
isArgDefined,
object = rawObject,
envir = envir,
FUN.VALUE = FALSE
) & !(argNames %in% exclude)
} else {
evalMask = !(argNames %in% exclude)
}
evalValues = vector(mode = 'list', length = length(rawObject))
evalValues[evalMask] = lapply(
argNames[evalMask],
function(name) rawObject[[name, eval = TRUE, envir = envir]]
)
if ('ANY' %in% classes) {
updateMask = evalMask
} else {
updateMask = evalMask &
vapply(evalValues, function(x) class(x)[1], FUN.VALUE = '') %in% classes
}
newObject = rawObject
sourceMask = vapply(newObject@arguments, is.language, FUN.VALUE = FALSE)
sourceNames = argNames[updateMask & sourceMask]
newObject@sourceCalls[sourceNames] = mget(sourceNames, newObject@arguments)
updateNames = argNames[updateMask]
updateValues = evalValues[updateMask]
for (i in seq_along(updateNames)) {
assign(updateNames[i], updateValues[[i]], pos = rawObject@arguments)
}
# newObject@arguments = replace(object@arguments, names(object)[updateMask], evalValues[updateMask])
return(newObject)
}
#' @export
#' @title Update a method specification
#' @details Updates or adds arguments to a `lcMethod` object. The inputs are evaluated in order to determine the presence of `formula` objects, which are updated accordingly.
#' @inheritParams as.list.lcMethod
#' @param object The `lcMethod` object.
#' @param ... The new or updated method argument values.
#' @param .eval Whether to assign the evaluated argument values to the method. By default (`FALSE`), the argument expression is preserved.
#' @param .remove Names of arguments that should be removed.
#' @return The new `lcMethod` object with the additional or updated arguments.
#' @examples
#' method <- lcMethodLMKM(Y ~ 1, nClusters = 2)
#' method2 <- update(method, formula = ~ . + Time)
#'
#' method3 <- update(method2, nClusters = 3)
#'
#' k <- 2
#' method4 <- update(method, nClusters = k) # nClusters: k
#'
#' method5 <- update(method, nClusters = k, .eval = TRUE) # nClusters: 2
#'
#' @family lcMethod functions
update.lcMethod = function(object, ..., .eval = FALSE, .remove = character(), envir = NULL) {
assert_that(
is.lcMethod(object),
is.flag(.eval),
is.character(.remove)
)
envir = .selectEnvironment(object, parent.frame(), envir)
argNames = names(object)
if (isTRUE(.eval)) {
ucall = list(...)
uargValues = ucall
} else {
ucall = match.call()[c(-1, -2)]
ucall$envir = NULL
ucall$.eval = NULL
ucall$.remove = NULL
uargValues = lapply(ucall, eval, envir = envir)
}
uargNames = names(ucall)
defMask = uargNames %in% argNames
formulaMask = vapply(uargValues, is, 'formula', FUN.VALUE = FALSE)
updateFormulaMask = formulaMask & defMask
if (any(updateFormulaMask)) {
oldFormulaArgs = lapply(uargNames[updateFormulaMask], function(name) object[[name]])
ucall[updateFormulaMask] =
Map(update.formula, oldFormulaArgs, uargValues[updateFormulaMask]) %>%
lapply(match.call, definition = formula)
}
# copy environment
object@arguments = list2env(
rev(as.list(object@arguments)),
hash = FALSE,
parent = parent.env(object@arguments)
)
for (arg in uargNames) {
assign(arg, ucall[[arg]], pos = object@arguments)
}
#object@arguments = replace(object@arguments, uargNames, ucall[uargNames])
object@sourceCalls[uargNames] = NULL
if (length(.remove) > 0) {
remove(list = .remove, pos = object@arguments)
#object@arguments[.remove] = NULL
object@sourceCalls[.remove] = NULL
}
validObject(object)
return(object)
}
#. responseVariable ####
#' @export
#' @rdname responseVariable
#' @aliases responseVariable,lcMethod-method
#' @details If the `lcMethod` object specifies a `formula` argument, then the response is extracted from the response term of the formula.
#' @examples
#' method <- lcMethodLMKM(Y ~ Time)
#' responseVariable(method) # "Y"
setMethod('responseVariable', 'lcMethod', function(object, ...) {
if (hasName(object, 'response')) {
object$response
} else if (hasName(object, 'formula')) {
if (hasSingleResponse(object$formula)) {
getResponse(object$formula)
} else {
stop(
sprintf(
'Cannot determine the response variable for class %s: the formula of argument "formula" has no response',
class(object)[1]
)
)
}
} else {
stop(
sprintf(
'cannot determine the response variable(s) for class %s\nConsider overriding "responseVariable(lcMethod)" to fix this for your lcMethod implementation',
class(object)[1]
)
)
}
})
#. show ####
setMethod('show', 'lcMethod', function(object) {
print(x = object)
})
# . strip ####
#' @export
#' @rdname strip
#' @aliases strip,lcMethod-method
setMethod('strip', 'lcMethod', function(object, ..., classes = 'formula') {
newObject = object
environment(newObject) = emptyenv()
classMask = eapply(object@arguments, inherits, what = classes, all.names = TRUE) %>%
unlist()
if (any(classMask)) {
stripArgNames = names(classMask)[classMask]
newArgs = as.list(object@arguments, all.names = TRUE)
stripArgs = mget(stripArgNames, envir = object@arguments) %>%
lapply('environment<-', value = emptyenv())
newArgs = replace(newArgs, which(classMask), stripArgs)
newObject@arguments = list2env(newArgs, hash = FALSE, parent = emptyenv())
}
newObject@sourceCalls = lapply(object@sourceCalls, strip, ..., classes = classes)
newObject
})
#' @export
#' @rdname strip
#' @aliases strip,ANY-method
setMethod('strip', 'ANY', function(object, ..., classes = 'formula') {
if (is.list(object) || is(object, 'call')) { # is.call is TRUE for formulas
replace(object, seq_along(object), lapply(object, strip))
}
else if (inherits(object, what = classes)) {
environment(object) = emptyenv()
object
}
})
#. timeVariable ####
#' @export
#' @rdname timeVariable
#' @aliases timeVariable,lcMethod-method
#' @return The time variable name, as `character`.
#' @examples
#' method <- lcMethodLMKM(Y ~ Time, id = "Id", time = "Time")
#' timeVariable(method) # "Time"
setMethod('timeVariable', 'lcMethod', function(object, ...) object$time)
#. validate ####
#' @export
#' @rdname validate
#' @aliases validate,lcMethod-method
#' @title `lcMethod` estimation step: method argument validation logic
#' @description Note: this function should not be called directly, as it is part of the `lcMethod` [estimation procedure][lcMethod-estimation].
#' For fitting an `lcMethod` object to a dataset, use the [latrend()] function or [one of the other standard estimation functions][latrend-estimation].
#'
#' The `validate()` function of the `lcMethod` object validates the method with respect to the training data.
#' This enables a method to verify, for example:
#' \itemize{
#' \item whether the formula covariates are present.
#' \item whether the argument combination settings are valid.
#' \item whether the data is suitable for training.
#' }
#'
#' By default, the `validate()` function checks whether the id, time, and response variables are present as columns in the training data.
#'
#' @inheritParams compose
#' @param method An object inheriting from `lcMethod` with all its arguments having been evaluated and finalized.
#' @param data A `data.frame` representing the transformed training data.
#' @param ... Not used.
#' @inheritSection lcMethod-estimation Estimation procedure
#' @section Implementation:
#' An example implementation checking for the existence of specific arguments and type:
#' \preformatted{
#'
#' library(assertthat)
#' setMethod("validate", "lcMethodExample", function(method, data, envir = NULL, ...) {
#' validate_that(
#' hasName(method, "myArgument"),
#' hasName(method, "anotherArgument"),
#' is.numeric(method$myArgument)
#' )
#' })
#' }
#' @seealso [assertthat::validate_that]
setMethod('validate', 'lcMethod', function(method, data, envir = NULL, ...) {
id = idVariable(method)
time = timeVariable(method)
response = responseVariable(method)
if (getOption('latrend.warnTrajectoryLength', default = 1L) > 0) {
warn_that(
are_trajectories_length(
data,
min = getOption('latrend.warnTrajectoryLength', default = 1L),
id = id, time = time
),
append = '\nThis warning can be disabled using options(latrend.warnTrajectoryLength = 0)'
)
}
validate_that(
is_data(data, id = id, time = time, response = response),
is.string(getLabel(method))
)
})
#' @export
#' @title Argument matching with defaults and parent ellipsis expansion
#' @description Returns a call containing all arguments in specified form, including default arguments.
#' @param n The number of frames to go back on the calling stack. See [base::sys.parent] for more details.
#' @seealso [base::match.call] [base::sys.parent]
#' @return A `call`
#' @keywords internal
match.call.all = function(n = 1L) {
which = sys.nframe() - n
call = match.call.frame(which)
# search for ..N arguments
nameMask = vapply(call, is.name, FUN.VALUE = TRUE)
dotMask = grepl('\\.\\.\\d+', as.character(call[nameMask]))
namedDotMask = nchar(names(call)[nameMask][dotMask]) > 0
if (any(namedDotMask)) {
dotNames = names(call)[nameMask][dotMask][namedDotMask]
for (dotArg in dotNames) {
# allCall[[dotArg]] = do.call(substitute, list(as.name(dotArg)), envir = parent.frame(n))
val = .match.call.arg(dotArg, which - 1L)
# val = dynGet(dotArg, ifnotfound = as.name(dotArg), inherits = TRUE)
call[dotArg] = list(val) # list() is needed to preserve NULLs
}
}
call
}
.match.call.arg = function(arg, which = sys.parent()) {
if (which == 0) {
warning(sprintf('Cannot resolve argument %s', arg))
as.name(arg)
} else {
if (hasName(sys.call(which), arg)) {
call = match.call.frame(which)
if (hasName(call, arg) &&
(!is.name(arg) ||
!startsWith(as.character(call[[arg]]), '..'))) {
# message(sprintf('Found value %s for argument %s\n', deparse(call[[arg]]), arg))
return (call[[arg]])
}
}
.match.call.arg(arg, which - 1L)
}
}
match.call.frame = function(which = sys.parent()) {
def = sys.function(which)
envir = sys.frame(which - 1)
call = match.call(def, call = sys.call(which), expand.dots = TRUE, envir = envir)
formals = formals(def)
outCall = call
for (arg in setdiff(names(formals), c('...', names(call)))) {
outCall[arg] = list(formals[[arg]]) # use list() to preserve NULLs
}
outCall = match.call(def, outCall, TRUE, envir)
outCall
}
Try the latrend package in your browser
Any scripts or data that you put into this service are public.
latrend documentation built on May 29, 2024, 8:51 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
#' @name lcMethod-estimation
#' @aliases latrend-procedure lcMethod-steps
#' @title Longitudinal cluster method (`lcMethod`) estimation procedure
#' @description Each longitudinal cluster method represented by a [lcMethod class][lcMethod-class] implements a series of standardized steps that produce the estimated method as its output.
#' These steps, as part of the estimation procedure, are executed by the [latrend()] function and other functions prefixed by *"latrend"* (e.g., [latrendRep()], [latrendBoot()], [latrendCV()]).
#' @section Estimation procedure:
#' The steps for estimating a `lcMethod` object are defined and executed as follows:
#' \enumerate{
#' \item [compose()]: Evaluate and finalize the method argument values.
#' \item [validate()]: Check the validity of the method argument values in relation to the dataset.
#' \item [prepareData()]: Process the training data for fitting.
#' \item [preFit()]: Prepare environment for estimation, independent of training data.
#' \item [fit()]: Estimate the specified method on the training data, outputting an object inheriting from `lcModel`.
#' \item [postFit()]: Post-process the outputted `lcModel` object.
#' }
#'
#' The result of the fitting procedure is an [lcModel-class] object that inherits from the `lcModel` class.
#' @examples
#' data(latrendData)
#' method <- lcMethodLMKM(Y ~ Time, id = "Id", time = "Time")
#' model <- latrend(method, data = latrendData)
#' summary(model)
#' @seealso [lcMethod-class] [latrend]
NULL
#' @export
#' @name lcMethod-class
#' @aliases lcMethod
#' @title lcMethod class
#' @description `lcMethod` objects represent the specification of a method for longitudinal clustering.
#' Furthermore, the object class contains the logic for estimating the respective method.
#'
#' You can specify a longitudinal cluster method through one of the method-specific constructor functions,
#' e.g., [lcMethodKML()], [lcMethodLcmmGBTM()], or [lcMethodDtwclust()].
#' Alternatively, you can instantiate methods through [methods::new()], e.g., by calling `new("lcMethodKML", response = "Value")`.
#' In both cases, default values are specified for omitted arguments.
#'
#' @section Method arguments:
#' An `lcMethod` objects represent the specification of a method with a set of configurable parameters (referred to as arguments).
#'
#' Arguments can be of any type.
#' It is up to the `lcMethod` implementation of [validate()] to ensure that the required arguments are present and are of the expected type.
#'
#' Arguments can have almost any name. Exceptions include the names `"data"`, `"envir"`, and `"verbose"`.
#' Furthermore, argument names may not start with a period (`"."`).
#'
#' Arguments cannot be directly modified, i.e., `lcMethod` objects are immutable.
#' Modifying an argument involves creating an altered copy through the [update.lcMethod] method.
#'
#' @section Implementation:
#' The base class `lcMethod` provides the logic for storing, evaluating, and printing the method parameters.
#'
#' Subclasses of `lcMethod` differ only in the [fitting procedure logic][lcMethod-estimation].
#'
#' To implement your own `lcMethod` subclass, you'll want to implement at least the following functions:
#' \itemize{
#' \item [fit()]: The main function for estimating your method.
#' \item [getName()]: The name of your method.
#' \item [getShortName()]: The abbreviated name of your method.
#' \item [getArgumentDefaults()]: Sensible default argument values to your method.
#' }
#'
#' For more complex methods, the additional functions as part of the [fitting procedure][lcMethod-estimation] will be of use.
#'
#' @details Because the `lcMethod` arguments may be unevaluated, argument retrieval functions such as `[[` accept an `envir` argument.
#' A default `environment` can be assigned or obtained from a `lcMethod` object using the `environment()` function.
#' @seealso [environment]
#' @slot arguments A `list` representing the arguments of the `lcMethod` object.
#' Arguments are not evaluated upon creation of the method object.
#' Instead, arguments are stored similar to a `call` object, and are only evaluated when a method is fitted.
#' Do not modify or access.
#' @slot sourceCalls A list of calls for tracking the original call after substitution.
#' Used for printing objects which require too many characters (e.g. ,function definitions, matrices).
#' Do not modify or access.
#' @examples
#' method <- lcMethodLMKM(Y ~ Time, id = "Id", time = "Time", nClusters = 2)
#' method
#'
#' method <- new("lcMethodLMKM", formula = Y ~ Time, id = "Id", time = "Time", nClusters = 2)
#'
#' # get argument names
#' names(method)
#'
#' # evaluate argument
#' method$nClusters
#'
#' # create a copy with updated nClusters argument
#' method3 <- update(method, nClusters = 3)
#' @family lcMethod implementations
#' @family lcMethod functions
setClass('lcMethod', slots = c(arguments = 'environment', sourceCalls = 'list'))
#. initialize ####
#' @title lcMethod initialization
#' @description Initialization of `lcMethod` objects, converting arbitrary arguments to arguments as part of an `lcMethod` object.
#' @param .Object The newly allocated `lcMethod` object.
#' @param ... Other method arguments.
#' @examples
#' new("lcMethodLMKM", formula = Y ~ Time, id = "Id", time = "Time")
setMethod('initialize', 'lcMethod', function(.Object, ...) {
.Object <- callNextMethod(.Object)
.defaults = getArgumentDefaults(.Object)
.exclude = getArgumentExclusions(.Object)
assert_that(
is.list(.defaults),
is_named(.defaults),
msg = sprintf(
'Implementation error for %s object: getArgumentDefaults() must return a named list',
class(.Object)[1]
)
)
assert_that(
is.character(.exclude),
msg = sprintf(
'Implementation error for %s object: getArgumentExclusions() must return character vector',
class(.Object)[1]
)
)
# drop arguments without defaults (empty symbols)
symMask = vapply(.defaults, is.symbol, FUN.VALUE = TRUE)
dropSymMask = vapply(.defaults[symMask], nchar, FUN.VALUE = 0) == 0
.defaults[which(symMask)[dropSymMask]] = NULL
# drop default arguments that should be excluded
defArgs = .defaults[setdiff(names(.defaults), .exclude)]
# process user arguments
mc = match.call.all()
userArgs = as.list(mc) %>%
.[nchar(names(.)) > 0]
userArgs[names(formals())] = NULL
if (any(hasName(userArgs, .exclude))) {
warning(
sprintf(
'arguments (%s) cannot be defined for this lcMethod class. These arguments will be ignored.',
paste0(intersect(.exclude, names(userArgs)), collapse = ', ')
)
)
}
args = modifyList(defArgs, userArgs, keep.null = TRUE)
# construct arguments environment
argEnv = list2env(rev(args), hash = FALSE)
.Object@arguments = argEnv
validObject(.Object)
.Object
})
#. validity ####
setValidity('lcMethod', function(object) {
errors = validate_that(
all(nchar(names(object)) > 0),
msg = 'lcMethod argument names cannot be empty'
)
errors = errors %c% validate_that(
!any(startsWith(names(object), '.')),
msg = sprintf(
'Cannot construct %s: lcMethod argument names cannot start with "."\nYou should rename argument(s) %s',
class(object)[1],
paste0('"', names(object)[startsWith(names(object), '.')], '"', collapse = ', ')
)
)
errors = errors %c% validate_that(!has_name(object, 'data'), msg = 'lcMethod argument name cannot be "data"')
errors = errors %c% validate_that(!has_name(object, 'envir'), msg = 'lcMethod argument name cannot be "envir"')
errors = errors %c% validate_that(!has_name(object, 'verbose'), msg = 'lcMethod argument name cannot be "verbose"')
if (isArgDefined(object, 'nClusters')) {
errors = errors %c% validate_that(is.scalar(object$nClusters))
errors = errors %c% validate_that(is.na(object$nClusters) || is.count(object$nClusters))
}
errors[errors != TRUE]
})
#. $ ####
#' @export
#' @name [[,lcMethod-method
#' @rdname indexy
#' @aliases $,lcMethod-method
#' @param name The argument name, as `character`.
#' @examples
#' method <- lcMethodLMKM(Y ~ Time, id = "Id", time = "Time", nClusters = 3)
#' method$nClusters # 3
setMethod('$', 'lcMethod', function(x, name) {
x[[name]]
})
#. [[ ####
#' @export
#' @rdname indexy
#' @title Retrieve and evaluate a lcMethod argument by name
#' @param x The `lcMethod` object.
#' @param i Name or index of the argument to retrieve.
#' @param eval Whether to evaluate the call argument (enabled by default).
#' @param envir The `environment` in which to evaluate the argument. This argument is only applicable when `eval = TRUE`.
#' @return The argument `call` or evaluation result.
#' @examples
#' m = lcMethodLMKM(Y ~ Time, id = "Id", time = "Time", nClusters = 5)
#' m[["nClusters"]] # 5
#'
#' k = 2
#' m = lcMethodLMKM(Y ~ Time, id = "Id", time = "Time", nClusters = k)
#' m[["nClusters", eval=FALSE]] # k
#' @family lcMethod functions
setMethod('[[', 'lcMethod', function(x, i, eval = TRUE, envir = NULL) {
envir = .selectEnvironment(x, parent.frame(3), envir)
if (is.character(i)) {
assert_that(has_name(x, i), msg = sprintf('method does not have an argument named "%s"', i))
arg = get(i, envir = x@arguments)
} else {
argName = names(x)[i]
assert_that(!is.na(argName), msg = sprintf('index "%s" exceeded argument name options', i))
arg = get(i, envir = x@arguments)
}
if (eval) {
# within-method scope
value = tryCatch({
eval(
arg,
envir = mget(setdiff(names(x@arguments), i), envir = x@arguments),
enclos = envir
)
}, error = function(e) {
tryCatch({
eval(arg, envir = envir)
}, error = function(e2) {
# try evaluation within package scope instead
tryCatch({
eval(arg, envir = parent.env(getNamespace(.packageName)))
}, error = function(e3) {
stop(
sprintf('error in evaluating lcMethod argument "%s" with expression "%s":\n\t%s',
i, deparse(e2$call), e2$message
)
)
})
})
})
} else {
value = arg
}
if (is.formula(value)) {
environment(value) = new.env()
}
return(value)
})
as.lcMethod = function(x, ..., envir = parent.frame()) {
assert_that(is.lcMethod(x) || is.character(x))
if (is.character(x)) {
assert_that(
methods::isClass(x),
msg = sprintf(
'Cannot instantiate lcMethod object of class "%1$s": Class "%1$s" is not defined',
class(x)[1]
)
)
assert_that(
methods::extends(x, 'lcMethod'),
msg = sprintf(
'Cannot instantiate object of class "%1$s" as lcMethod: "%1$s" does not inherit from lcMethod class',
class(x)[1]
)
)
x = new(x, ...)
} else {
assert_that(is_class_defined(x))
update(x, ..., envir = envir)
}
}
#' @exportS3Method base::as.character
as.character.lcMethod = function(x, ..., eval = FALSE, width = 40, prefix = '', envir = NULL) {
assert_that(
is.lcMethod(x),
is.flag(eval)
)
envir = .selectEnvironment(x, parent.frame(), envir)
if (isTRUE(eval)) {
x = evaluate.lcMethod(x, envir = envir)
}
arg2char = function(a) {
if (is.null(a)) {
'NULL'
} else if (is.character(a)) {
paste0('"', a, '"', collapse = ', ')
} else if (is.atomic(a)) {
paste0(as.character(a), collapse = ', ')
} else {
deparse(a) %>% paste0(collapse = '')
}
}
argNames = names(x)
chrValues = lapply(x@arguments, arg2char) %>% unlist()
assert_that(all(vapply(chrValues, length, FUN.VALUE = 0) == 1))
sourceMask = vapply(chrValues, nchar, FUN.VALUE = 0) > width &
argNames %in% names(x@sourceCalls)
chrSource = lapply(x@sourceCalls[argNames[sourceMask]], arg2char) %>% unlist()
chrValues[sourceMask] = paste0('`', chrSource, '`')
args = vapply(chrValues, strtrim, width = width, FUN.VALUE = '')
header = sprintf('%s specifying "%s"', class(x)[1], getName(x))
if (length(args) > 0) {
body = sprintf('%s%-16s%s', prefix, paste0(argNames, ':'), args)
} else {
body = 'no arguments'
}
c(header, body)
}
#' @exportS3Method base::as.list
#' @title Extract the method arguments as a list
#' @param x The `lcMethod` object.
#' @param ... Additional arguments.
#' @param args A `character vector` of argument names to select. Only available arguments are returned.
#' Alternatively, a `function` or `list` of `function`s, whose formal arguments will be selected from the method.
#' @param eval Whether to evaluate the arguments.
#' @param expand Whether to return all method arguments when `"..."` is present among the requested argument names.
#' @param envir The `environment` in which to evaluate the arguments. If `NULL`, the environment associated with the object is used. If not available, the `parent.frame()` is used.
#' @return A `list` with the argument `call`s or evaluated results depending on the value for `eval`.
#' @examples
#' data(latrendData)
#' method <- lcMethodLMKM(Y ~ Time, id = "Id", time = "Time")
#' as.list(method)
#'
#' as.list(method, args = c("id", "time"))
#'
#' if (require("kml")) {
#' method <- lcMethodKML("Y", id = "Id", time = "Time")
#' as.list(method)
#'
#' # select arguments used by kml()
#' as.list(method, args = kml::kml)
#'
#' # select arguments used by either kml() or parALGO()
#' as.list(method, args = c(kml::kml, kml::parALGO))
#' }
#' @family lcMethod functions
as.list.lcMethod = function(x, ..., args = names(x), eval = TRUE, expand = FALSE, envir = NULL) {
assert_that(
is.lcMethod(x),
is.flag(eval),
is.flag(expand)
)
envir = .selectEnvironment(x, parent.frame(), envir)
if (is.function(args)) {
argNames = formalArgs(args)
}
else if (is.list(args)) {
# functions special case
argNames = lapply(args, formalArgs) %>%
Reduce(union, .)
} else {
assert_that(is.character(args))
argNames = args
}
# filter arguments
if (isTRUE(expand) && '...' %in% argNames) {
selArgNames = argNames
} else {
selArgNames = intersect(argNames, names(x))
}
if (isTRUE(eval)) {
# full evaluation
method = evaluate.lcMethod(x, envir = envir)
} else {
method = x
}
as.list(method@arguments)[selArgNames]
}
#' @exportS3Method base::as.data.frame
#' @title Convert lcMethod arguments to a list of atomic types
#' @description Converts the arguments of a `lcMethod` to a named `list` of [atomic] types.
#' @inheritParams as.list.lcMethod
#' @param x `lcMethod` to be coerced to a `character` `vector`.
#' @param ... Additional arguments.
#' @param eval Whether to evaluate the arguments in order to replace expression if the resulting value is of a class specified in `evalClasses`.
#' @param nullValue Value to use to represent the `NULL` type. Must be of length 1.
#' @return A single-row `data.frame` where each columns represents an argument call or evaluation.
#' @family lcMethod functions
as.data.frame.lcMethod = function(x, ..., eval = TRUE, nullValue = NA, envir = NULL) {
assert_that(
is.lcMethod(x),
is.flag(eval),
length(nullValue) == 1
)
if (isTRUE(eval)) {
envir = .selectEnvironment(x, parent.frame(), envir)
evalClasses = c(
'NULL',
'logical',
'numeric',
'complex',
'integer',
'character',
'factor'
)
method = evaluate.lcMethod(x, classes = evalClasses, envir = envir)
} else {
method = x
}
argList = as.list(method, eval = FALSE)
dfList = lapply(argList, function(a) {
if (is.null(a)) {
nullValue
} else if (is.atomic(a)) {
if (length(a) > 1) {
deparse(a) %>% as.character() %>% paste0(collapse = '')
} else {
a
}
} else {
deparse(a) %>% paste0(collapse = '')
}
})
argValueLengths = vapply(dfList, length, FUN.VALUE = 0)
errMask = argValueLengths != 1
assert_that(
all(argValueLengths == 1),
msg = sprintf(
'as.data.frame.lcMethod(%s) requires all method arguments to be/evaluate to length 1.\nArguments that violate this requirement: %s',
class(x)[1],
paste0('"', names(argValueLengths)[errMask], '"(', argValueLengths[errMask], ')', collapse = ', ')
)
)
as.data.frame(dfList, stringsAsFactors = FALSE)
}
#' @noRd
#' @title Select the preferred environment
#' @description Returns envir if specified. Otherwise, returns environment(object) if specified. The defaultEnvir is returned when the former two are NULL.
#' @keywords internal
.selectEnvironment = function(object, defaultEnvir, envir) {
assert_that(
is.lcMethod(object),
is.null(defaultEnvir) || is.environment(defaultEnvir),
is.null(envir) || is.environment(envir)
)
if (!is.null(envir)) {
envir
} else if (!is.null(environment(object))) {
environment(object)
} else {
defaultEnvir
}
}
#. compose ####
#' @export
#' @rdname compose
#' @aliases compose,lcMethod-method
#' @title `lcMethod` estimation step: compose an lcMethod object
#' @description Note: this function should not be called directly, as it is part of the `lcMethod` [estimation procedure][lcMethod-estimation].
#' For fitting an `lcMethod` object to a dataset, use the [latrend()] function or [one of the other standard estimation functions][latrend-estimation].
#'
#' The `compose()` function of the `lcMethod` object evaluates and finalizes the `lcMethod` arguments.
#'
#' The default implementation returns an updated object with all arguments having been evaluated.
#' @param method The `lcMethod` object.
#' @param envir The `environment` in which the `lcMethod` should be evaluated
#' @return The evaluated and finalized `lcMethod` object.
#' @inheritSection lcMethod-estimation Estimation procedure
#' @section Implementation:
#' In general, there is no need to extend this method for a specific method, as all arguments are automatically evaluated by the `compose,lcMethod` method.
#'
#' However, in case there is a need to extend processing or to prevent evaluation of specific arguments (e.g., for handling errors), the method can be overridden for the specific `lcMethod` subclass.
#' \preformatted{
#' setMethod("compose", "lcMethodExample", function(method, envir = NULL) {
#' newMethod <- callNextMethod()
#' # further processing
#' return(newMethod)
#' })
#' }
#' @seealso [evaluate.lcMethod]
setMethod('compose', 'lcMethod', function(method, envir = NULL) {
evaluate.lcMethod(method, try = FALSE, envir = envir)
})
# . fit ####
#' @export
#' @rdname fit
#' @aliases fit,lcMethod-method
#' @title `lcMethod` estimation step: logic for fitting the method to the processed data
#' @description Note: this function should not be called directly, as it is part of the `lcMethod` [estimation procedure][lcMethod-estimation].
#' For fitting an `lcMethod` object to a dataset, use the [latrend()] function or [one of the other standard estimation functions][latrend-estimation].
#'
#' The `fit()` function of the `lcMethod` object estimates the model with the evaluated method specification, processed training data, and prepared environment.
#' @inheritParams preFit
#' @param envir The `environment` containing variables generated by [prepareData()] and [preFit()].
#' @section Implementation:
#' This method should be implemented for all `lcMethod` subclasses.
#'
#' \preformatted{
#' setMethod("fit", "lcMethodExample", function(method, data, envir, verbose) {
#' # estimate the model or cluster parameters
#' coefs <- FIT_CODE
#'
#' # create the lcModel object
#' new("lcModelExample",
#' method = method,
#' data = data,
#' model = coefs,
#' clusterNames = make.clusterNames(method$nClusters)
#' )
#' })
#' }
#' @inheritSection lcMethod-estimation Estimation procedure
setMethod('fit', 'lcMethod', function(method, data, envir, verbose) {
stop(
sprintf('method cannot be estimated because the fit() function is not implemented for lcMethod of class %1$s.
define the fit() method using:
\tsetMethod("fit", "%1$s", function(method, data, verbose) {
\t\t<your code returning a lcModel-extended class here>
\t})")', class(method)[1])
)
})
#' @exportS3Method stats::formula
#' @title Extract formula
#' @description Extracts the associated `formula` for the given distributional parameter.
#' @inheritParams as.list.lcMethod
#' @param x The `lcMethod` object.
#' @param ... Additional arguments.
#' @param what The distributional parameter to which this formula applies. By default, the formula specifies `"mu"`.
#' @return The `formula` for the given distributional parameter.
#' @examples
#' method <- lcMethodLMKM(Y ~ Time, id = "Id", time = "Time")
#' formula(method) # Y ~ Time
#' @family lcMethod functions
formula.lcMethod = function(x, what = 'mu', envir = NULL, ...) {
assert_that(
is.lcMethod(x),
is.scalar(what),
is.character(what)
)
envir = .selectEnvironment(x, parent.frame(), envir)
if (what == 'mu') {
f = x$formula
} else {
f = x[[paste0('formula.', what)]]
}
environment(f) = envir
f
}
#' @exportS3Method stats::getCall
getCall.lcMethod = function(x, ...) {
assert_that(is.lcMethod(x))
do.call(call, c(class(x)[1], eapply(x@arguments, enquote)))
}
#. getArgumentDefaults ####
#' @export
#' @rdname getArgumentDefaults
#' @aliases getArgumentDefaults,lcMethod-method
#' @description Returns the default arguments associated with the respective `lcMethod` subclass.
#' These arguments are automatically included into the `lcMethod` object during initialization.
#'
#' @section Implementation:
#' Although implementing this method is optional, it prevents users from
#' having to specify all arguments every time they want to create a method specification.
#'
#' In this example, most of the default arguments are defined as arguments of the function
#' `lcMethodExample`, which we can include in the list by calling [formals]. Copying the arguments from functions
#' is especially useful when your method implementation is based on an existing function.
#' \preformatted{
#' setMethod("getArgumentDefaults", "lcMethodExample", function(object) {
#' list(
#' formals(lcMethodExample),
#' formals(funFEM::funFEM),
#' extra = Value ~ 1,
#' tol = 1e-4,
#' callNextMethod()
#' )
#' })
#' }
#'
#' It is recommended to add `callNextMethod()` to the end of the list.
#' This enables inheriting the default arguments from superclasses.
#' @seealso [lcMethod]
#' @family lcMethod implementations
setMethod('getArgumentDefaults', 'lcMethod', function(object) {
set_names(list(), character(0))
})
#. getCitation ####
#' @rdname getCitation
#' @aliases getCitation,lcMethod-method
setMethod('getCitation', 'lcMethod', function(object, ...) {
utils::citation(package = 'base')[0]
})
#. getArgumentExclusions ####
#' @export
#' @rdname getArgumentExclusions
#' @aliases getArgumentExclusions,lcMethod-method
#' @section Implementation:
#' This function only needs to be implemented if you want to avoid users from specifying
#' redundant arguments or arguments that are set automatically or conditionally on other arguments.
#'
#' \preformatted{
#' setMethod("getArgumentExclusions", "lcMethodExample", function(object) {
#' c(
#' "doPlot",
#' "verbose",
#' callNextMethod()
#' )
#' })
#'
#' Adding `callNextMethod()` to the end of the return vector enables inheriting exclusions from superclasses.
#' }
#' @seealso [lcMethod] [getArgumentExclusions]
#' @family lcMethod implementations
setMethod('getArgumentExclusions', 'lcMethod', function(object) {
c('verbose', 'envir', 'data')
})
#. getLabel ####
#' @export
#' @rdname getLabel
#' @aliases getLabel,lcMethod-method
#' @description Extracts the assigned label from the given `lcMethod` or `lcModel` object.
#' By default, the label is determined from the `"label"` argument of the `lcMethod` object.
#' The label of an `lcModel` object is set upon estimation by [latrend()] to the label of its associated `lcMethod` object.
#' @seealso [getName] [getShortName]
#' @examples
#' method <- lcMethodLMKM(Y ~ Time, time = "Time")
#' getLabel(method) # ""
#'
#' getLabel(update(method, label = "v2")) # "v2"
setMethod('getLabel', 'lcMethod', function(object, ...) {
if (hasName(object, 'label')) {
object$label
} else {
''
}
})
#. getName ####
#' @export
#' @rdname getName
#' @aliases getName,lcMethod-method
#' @section Implementation:
#' When implementing your own `lcMethod` subclass, override these methods to provide full and abbreviated names.
#' \preformatted{
#' setMethod("getName", "lcMethodExample", function(object) "example name")
#'
#' setMethod("getShortName", "lcMethodExample", function(object) "EX")
#' }
#'
#' Similar methods can be implemented for your `lcModel` subclass,
#' however in practice this is not needed as the names are determined by default from the `lcMethod` object that was used to fit the `lcModel` object.
#'
#' @examples
#' method <- lcMethodLMKM(Y ~ Time)
#' getName(method) # "lm-kmeans"
setMethod('getName', 'lcMethod', function(object, ...) 'undefined')
#' @export
#' @rdname getName
#' @aliases getName,NULL-method
setMethod('getName', 'NULL', function(object, ...) 'null')
#. getShortName ####
#' @export
#' @rdname getName
#' @aliases getShortName,lcMethod-method
#' @examples
#' method <- lcMethodLMKM(Y ~ Time)
#' getShortName(method) # "LMKM"
setMethod('getShortName', 'lcMethod', function(object, ...) getName(object, ...))
#' @export
#' @rdname getName
#' @aliases getShortName,NULL-method
setMethod('getShortName', 'NULL', function(object, ...) 'nul')
#. idVariable ####
#' @export
#' @rdname idVariable
#' @aliases idVariable,lcMethod-method
#' @examples
#' method <- lcMethodLMKM(Y ~ Time, id = "Traj")
#' idVariable(method) # "Traj"
#'
setMethod('idVariable', 'lcMethod', function(object, ...) object$id)
#' @export
#' @title Check whether the argument of a lcMethod has a defined value.
#' @description Determines whether the associated argument value is defined. If the argument value is of type `language`, the argument is evaluated to see if it can be resolved within its `environment`.
#' @param object The `lcMethod` object.
#' @param name The name of the argument, as `character`.
#' @param envir The `environment` to evaluate the arguments in. If `NULL`, the argument is not evaluated.
#' @keywords internal
isArgDefined = function(object, name, envir = environment(object)) {
assert_that(
is.lcMethod(object),
is.character(name),
is.scalar(name),
is.environment(envir) || is.null(envir)
)
if (!hasName(object, name)) {
return(FALSE)
}
arg = object[[name[1], eval = FALSE]]
if (is.language(arg)) {
arg = try(object[[name[1], envir = envir]], silent = TRUE)
return(!is(arg, 'try-error'))
} else {
return(TRUE)
}
}
#' @export
#' @name latrend-is
#' @rdname is
#' @title Check if object is of Class
#' @param x The object to check the class of.
#' @return `scalar logical`
#' @keywords internal
is.lcMethod = function(x) {
isS4(x) && inherits(x, 'lcMethod')
}
#. length ####
#' @export
#' @name names,lcMethod-method
#' @rdname names-lcMethod-method
#' @aliases length,lcMethod-method
#' @return The number of arguments, as `scalar integer`.
setMethod('length', 'lcMethod', function(x) {
length(x@arguments)
})
#. names ####
#' @export
#' @title lcMethod argument names
#' @description Extract the argument names or number of arguments from an `lcMethod` object.
#' @param x The `lcMethod` object.
#' @return A `character vector` of argument names.
#' @examples
#' method <- lcMethodLMKM(Y ~ Time)
#' names(method)
#' length(method)
#' @family lcMethod functions
setMethod('names', 'lcMethod', function(x) {
argNames = names(x@arguments)
if (is.null(argNames)) {
character(0)
} else {
argNames
}
})
# . preFit ####
#' @rdname preFit
#' @aliases preFit,lcMethod-method
#' @title `lcMethod` estimation step: method preparation logic
#' @description Note: this function should not be called directly, as it is part of the `lcMethod` [estimation procedure][lcMethod-estimation].
#' For fitting an `lcMethod` object to a dataset, use the [latrend()] function or [one of the other standard estimation functions][latrend-estimation].
#'
#' The `preFit()` function of the `lcMethod` object performs preparatory work that is needed for fitting the method but should not be counted towards the method estimation time.
#' The work is added to the provided `environment`, allowing the [fit()] function to make use of the prepared work.
#' @inheritParams prepareData
#' @param envir The `environment` containing additional data variables returned by [prepareData()].
#' @section Implementation:
#' \preformatted{
#' setMethod("preFit", "lcMethodExample", function(method, data, envir, verbose) {
#' # update envir with additional computed work
#' envir$x <- INTENSIVE_OPERATION
#' return(envir)
#' })
#' }
#' @inheritSection lcMethod-estimation Estimation procedure
#' @return The updated `environment` that will be passed to [fit()].
setMethod('preFit', 'lcMethod', function(method, data, envir, verbose) {
envir
})
# . prepareData ####
#' @rdname prepareData
#' @aliases prepareData,lcMethod-method
#' @title `lcMethod` estimation step: logic for preparing the training data
#' @description Note: this function should not be called directly, as it is part of the `lcMethod` [estimation procedure][lcMethod-estimation].
#' For fitting an `lcMethod` object to a dataset, use the [latrend()] function or [one of the other standard estimation functions][latrend-estimation].
#'
#' The `prepareData()` function of the `lcMethod` object processes the training data prior to fitting the method.
#' Example uses:
#' \itemize{
#' \item Transforming the data to another format, e.g., a matrix.
#' \item Truncating the response variable.
#' \item Computing derived covariates.
#' \item Creating additional data objects.
#' }
#' The computed variables are stored in an `environment` which is passed to the [preFit()] function for further processing.
#'
#' By default, this method does not do anything.
#'
#' @inheritParams validate
#' @param verbose A [R.utils::Verbose] object indicating the level of verbosity.
#' @return An `environment` with the prepared data variable(s) that will be passed to [preFit()].
#' @section Implementation:
#' A common use case for this method is when the internal method fitting procedure expects the data in a different format.
#' In this example, the method converts the training data `data.frame` to a `matrix` of repeated and aligned trajectory measurements.
#' \preformatted{
#' setMethod("prepareData", "lcMethodExample", function(method, data, verbose) {
#' envir = new.env()
#' # transform the data to matrix
#' envir$dataMat = tsmatrix(data,
#' id = idColumn, time = timeColumn, response = valueColumn)
#' return(envir)
#' })
#' }
#' @inheritSection lcMethod-estimation Estimation procedure
setMethod('prepareData', 'lcMethod', function(method, data, verbose) {
new.env(parent = emptyenv())
})
# . postFit ####
#' @rdname postFit
#' @aliases postFit,lcMethod-method
#' @title `lcMethod` estimation step: logic for post-processing the fitted lcModel
#' @description Note: this function should not be called directly, as it is part of the `lcMethod` [estimation procedure][lcMethod-estimation].
#' For fitting an `lcMethod` object to a dataset, use the [latrend()] function or [one of the other standard estimation functions][latrend-estimation].
#'
#' The `postFit()` function of the `lcMethod` object defines how the `lcModel` object returned by [fit()] should be post-processed.
#' This can be used, for example, to:
#' \itemize{
#' \item Resolve label switching.
#' \item Clean up the internal model representation.
#' \item Correct estimation errors.
#' \item Compute additional metrics.
#' }
#' By default, this method does not do anything. It merely returns the original `lcModel` object.
#'
#' This is the last step in the `lcMethod` fitting procedure. The `postFit` method may be called again on fitted `lcModel` objects, allowing post-processing to be updated for existing models.
#'
#' @inheritParams fit
#' @param model The `lcModel` object returned by [fit()].
#' @return The updated `lcModel` object.
#' @section Implementation:
#' The method is intended to be able to be called on previously fitted `lcModel` objects as well, allowing for potential bugfixes or additions to previously fitted models.
#' Therefore, when implementing this method, ensure that you do not discard information from the model which would prevent the method from being run a second time on the object.
#'
#' In this example, the `lcModelExample` class is assumed to be defined with a slot named `"centers"`:
#' \preformatted{
#' setMethod("postFit", "lcMethodExample", function(method, data, model, envir, verbose) {
#' # compute and store the cluster centers
#' model@centers <- INTENSIVE_COMPUTATION
#' return(model)
#' })
#' }
#' @inheritSection lcMethod-estimation Estimation procedure
setMethod('postFit', 'lcMethod', function(method, data, model, envir, verbose) {
model
})
#' @exportS3Method base::print
#' @title Print the arguments of an lcMethod object
#' @param x The `lcMethod` object.
#' @param eval Whether to print the evaluated argument values.
#' @param width Maximum number of characters per argument.
#' @param envir The environment in which to evaluate the arguments when `eval = TRUE`.
#' @param ... Not used.
print.lcMethod = function(x, ..., eval = FALSE, width = 40, envir = NULL) {
out = as.character(x, ..., eval = eval, width = width, envir = envir, prefix = ' ')
cat(out, sep = '\n')
}
#' @exportS3Method R.utils::evaluate
#' @importFrom R.utils evaluate
#' @title Substitute the call arguments for their evaluated values
#' @description Substitutes the call arguments if they can be evaluated without error.
#' @inheritParams as.list.lcMethod
#' @param object The `lcMethod` object.
#' @param classes Substitute only arguments with specific class types. By default, all types are substituted.
#' @param try Whether to try to evaluate arguments and ignore errors (the default), or to fail on any argument evaluation error.
#' @param exclude Arguments to exclude from evaluation.
#' @param ... Not used.
#' @return A new `lcMethod` object with the substituted arguments.
#' @seealso [compose]
#' @family lcMethod functions
evaluate.lcMethod = function(
object,
classes = 'ANY',
try = TRUE,
exclude = character(),
envir = NULL,
...
) {
rawObject = as.lcMethod(object)
assert_that(is.character(classes))
envir = .selectEnvironment(rawObject, parent.frame(), envir)
argNames = names(rawObject)
if (isTRUE(try)) {
evalMask = vapply(
argNames,
isArgDefined,
object = rawObject,
envir = envir,
FUN.VALUE = FALSE
) & !(argNames %in% exclude)
} else {
evalMask = !(argNames %in% exclude)
}
evalValues = vector(mode = 'list', length = length(rawObject))
evalValues[evalMask] = lapply(
argNames[evalMask],
function(name) rawObject[[name, eval = TRUE, envir = envir]]
)
if ('ANY' %in% classes) {
updateMask = evalMask
} else {
updateMask = evalMask &
vapply(evalValues, function(x) class(x)[1], FUN.VALUE = '') %in% classes
}
newObject = rawObject
sourceMask = vapply(newObject@arguments, is.language, FUN.VALUE = FALSE)
sourceNames = argNames[updateMask & sourceMask]
newObject@sourceCalls[sourceNames] = mget(sourceNames, newObject@arguments)
updateNames = argNames[updateMask]
updateValues = evalValues[updateMask]
for (i in seq_along(updateNames)) {
assign(updateNames[i], updateValues[[i]], pos = rawObject@arguments)
}
# newObject@arguments = replace(object@arguments, names(object)[updateMask], evalValues[updateMask])
return(newObject)
}
#' @export
#' @title Update a method specification
#' @details Updates or adds arguments to a `lcMethod` object. The inputs are evaluated in order to determine the presence of `formula` objects, which are updated accordingly.
#' @inheritParams as.list.lcMethod
#' @param object The `lcMethod` object.
#' @param ... The new or updated method argument values.
#' @param .eval Whether to assign the evaluated argument values to the method. By default (`FALSE`), the argument expression is preserved.
#' @param .remove Names of arguments that should be removed.
#' @return The new `lcMethod` object with the additional or updated arguments.
#' @examples
#' method <- lcMethodLMKM(Y ~ 1, nClusters = 2)
#' method2 <- update(method, formula = ~ . + Time)
#'
#' method3 <- update(method2, nClusters = 3)
#'
#' k <- 2
#' method4 <- update(method, nClusters = k) # nClusters: k
#'
#' method5 <- update(method, nClusters = k, .eval = TRUE) # nClusters: 2
#'
#' @family lcMethod functions
update.lcMethod = function(object, ..., .eval = FALSE, .remove = character(), envir = NULL) {
assert_that(
is.lcMethod(object),
is.flag(.eval),
is.character(.remove)
)
envir = .selectEnvironment(object, parent.frame(), envir)
argNames = names(object)
if (isTRUE(.eval)) {
ucall = list(...)
uargValues = ucall
} else {
ucall = match.call()[c(-1, -2)]
ucall$envir = NULL
ucall$.eval = NULL
ucall$.remove = NULL
uargValues = lapply(ucall, eval, envir = envir)
}
uargNames = names(ucall)
defMask = uargNames %in% argNames
formulaMask = vapply(uargValues, is, 'formula', FUN.VALUE = FALSE)
updateFormulaMask = formulaMask & defMask
if (any(updateFormulaMask)) {
oldFormulaArgs = lapply(uargNames[updateFormulaMask], function(name) object[[name]])
ucall[updateFormulaMask] =
Map(update.formula, oldFormulaArgs, uargValues[updateFormulaMask]) %>%
lapply(match.call, definition = formula)
}
# copy environment
object@arguments = list2env(
rev(as.list(object@arguments)),
hash = FALSE,
parent = parent.env(object@arguments)
)
for (arg in uargNames) {
assign(arg, ucall[[arg]], pos = object@arguments)
}
#object@arguments = replace(object@arguments, uargNames, ucall[uargNames])
object@sourceCalls[uargNames] = NULL
if (length(.remove) > 0) {
remove(list = .remove, pos = object@arguments)
#object@arguments[.remove] = NULL
object@sourceCalls[.remove] = NULL
}
validObject(object)
return(object)
}
#. responseVariable ####
#' @export
#' @rdname responseVariable
#' @aliases responseVariable,lcMethod-method
#' @details If the `lcMethod` object specifies a `formula` argument, then the response is extracted from the response term of the formula.
#' @examples
#' method <- lcMethodLMKM(Y ~ Time)
#' responseVariable(method) # "Y"
setMethod('responseVariable', 'lcMethod', function(object, ...) {
if (hasName(object, 'response')) {
object$response
} else if (hasName(object, 'formula')) {
if (hasSingleResponse(object$formula)) {
getResponse(object$formula)
} else {
stop(
sprintf(
'Cannot determine the response variable for class %s: the formula of argument "formula" has no response',
class(object)[1]
)
)
}
} else {
stop(
sprintf(
'cannot determine the response variable(s) for class %s\nConsider overriding "responseVariable(lcMethod)" to fix this for your lcMethod implementation',
class(object)[1]
)
)
}
})
#. show ####
setMethod('show', 'lcMethod', function(object) {
print(x = object)
})
# . strip ####
#' @export
#' @rdname strip
#' @aliases strip,lcMethod-method
setMethod('strip', 'lcMethod', function(object, ..., classes = 'formula') {
newObject = object
environment(newObject) = emptyenv()
classMask = eapply(object@arguments, inherits, what = classes, all.names = TRUE) %>%
unlist()
if (any(classMask)) {
stripArgNames = names(classMask)[classMask]
newArgs = as.list(object@arguments, all.names = TRUE)
stripArgs = mget(stripArgNames, envir = object@arguments) %>%
lapply('environment<-', value = emptyenv())
newArgs = replace(newArgs, which(classMask), stripArgs)
newObject@arguments = list2env(newArgs, hash = FALSE, parent = emptyenv())
}
newObject@sourceCalls = lapply(object@sourceCalls, strip, ..., classes = classes)
newObject
})
#' @export
#' @rdname strip
#' @aliases strip,ANY-method
setMethod('strip', 'ANY', function(object, ..., classes = 'formula') {
if (is.list(object) || is(object, 'call')) { # is.call is TRUE for formulas
replace(object, seq_along(object), lapply(object, strip))
}
else if (inherits(object, what = classes)) {
environment(object) = emptyenv()
object
}
})
#. timeVariable ####
#' @export
#' @rdname timeVariable
#' @aliases timeVariable,lcMethod-method
#' @return The time variable name, as `character`.
#' @examples
#' method <- lcMethodLMKM(Y ~ Time, id = "Id", time = "Time")
#' timeVariable(method) # "Time"
setMethod('timeVariable', 'lcMethod', function(object, ...) object$time)
#. validate ####
#' @export
#' @rdname validate
#' @aliases validate,lcMethod-method
#' @title `lcMethod` estimation step: method argument validation logic
#' @description Note: this function should not be called directly, as it is part of the `lcMethod` [estimation procedure][lcMethod-estimation].
#' For fitting an `lcMethod` object to a dataset, use the [latrend()] function or [one of the other standard estimation functions][latrend-estimation].
#'
#' The `validate()` function of the `lcMethod` object validates the method with respect to the training data.
#' This enables a method to verify, for example:
#' \itemize{
#' \item whether the formula covariates are present.
#' \item whether the argument combination settings are valid.
#' \item whether the data is suitable for training.
#' }
#'
#' By default, the `validate()` function checks whether the id, time, and response variables are present as columns in the training data.
#'
#' @inheritParams compose
#' @param method An object inheriting from `lcMethod` with all its arguments having been evaluated and finalized.
#' @param data A `data.frame` representing the transformed training data.
#' @param ... Not used.
#' @inheritSection lcMethod-estimation Estimation procedure
#' @section Implementation:
#' An example implementation checking for the existence of specific arguments and type:
#' \preformatted{
#'
#' library(assertthat)
#' setMethod("validate", "lcMethodExample", function(method, data, envir = NULL, ...) {
#' validate_that(
#' hasName(method, "myArgument"),
#' hasName(method, "anotherArgument"),
#' is.numeric(method$myArgument)
#' )
#' })
#' }
#' @seealso [assertthat::validate_that]
setMethod('validate', 'lcMethod', function(method, data, envir = NULL, ...) {
id = idVariable(method)
time = timeVariable(method)
response = responseVariable(method)
if (getOption('latrend.warnTrajectoryLength', default = 1L) > 0) {
warn_that(
are_trajectories_length(
data,
min = getOption('latrend.warnTrajectoryLength', default = 1L),
id = id, time = time
),
append = '\nThis warning can be disabled using options(latrend.warnTrajectoryLength = 0)'
)
}
validate_that(
is_data(data, id = id, time = time, response = response),
is.string(getLabel(method))
)
})
#' @export
#' @title Argument matching with defaults and parent ellipsis expansion
#' @description Returns a call containing all arguments in specified form, including default arguments.
#' @param n The number of frames to go back on the calling stack. See [base::sys.parent] for more details.
#' @seealso [base::match.call] [base::sys.parent]
#' @return A `call`
#' @keywords internal
match.call.all = function(n = 1L) {
which = sys.nframe() - n
call = match.call.frame(which)
# search for ..N arguments
nameMask = vapply(call, is.name, FUN.VALUE = TRUE)
dotMask = grepl('\\.\\.\\d+', as.character(call[nameMask]))
namedDotMask = nchar(names(call)[nameMask][dotMask]) > 0
if (any(namedDotMask)) {
dotNames = names(call)[nameMask][dotMask][namedDotMask]
for (dotArg in dotNames) {
# allCall[[dotArg]] = do.call(substitute, list(as.name(dotArg)), envir = parent.frame(n))
val = .match.call.arg(dotArg, which - 1L)
# val = dynGet(dotArg, ifnotfound = as.name(dotArg), inherits = TRUE)
call[dotArg] = list(val) # list() is needed to preserve NULLs
}
}
call
}
.match.call.arg = function(arg, which = sys.parent()) {
if (which == 0) {
warning(sprintf('Cannot resolve argument %s', arg))
as.name(arg)
} else {
if (hasName(sys.call(which), arg)) {
call = match.call.frame(which)
if (hasName(call, arg) &&
(!is.name(arg) ||
!startsWith(as.character(call[[arg]]), '..'))) {
# message(sprintf('Found value %s for argument %s\n', deparse(call[[arg]]), arg))
return (call[[arg]])
}
}
.match.call.arg(arg, which - 1L)
}
}
match.call.frame = function(which = sys.parent()) {
def = sys.function(which)
envir = sys.frame(which - 1)
call = match.call(def, call = sys.call(which), expand.dots = TRUE, envir = envir)
formals = formals(def)
outCall = call
for (arg in setdiff(names(formals), c('...', names(call)))) {
outCall[arg] = list(formals[[arg]]) # use list() to preserve NULLs
}
outCall = match.call(def, outCall, TRUE, envir)
outCall
}
Try the latrend package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.