| 1 |
- #' Dynamic Registration for Package Interoperability+ #' Methods for `mmrm_tmb` Objects |
||
| 3 |
- #' @seealso See `vignette("xtending", package = "emmeans")` for background.
+ #' @description `r lifecycle::badge("stable")`
|
||
| 4 |
- #' @keywords internal+ #' |
||
| 5 |
- #' @noRd+ #' @param object (`mmrm_tmb`)\cr the fitted MMRM object. |
||
| 6 |
- .onLoad <- function(libname, pkgname) { # nolint
+ #' @param x (`mmrm_tmb`)\cr same as `object`. |
||
| 7 | -! | +
- if (utils::packageVersion("TMB") < "1.9.15") {
+ #' @param formula (`mmrm_tmb`)\cr same as `object`. |
|
| 8 | -! | +
- warning("TMB version 1.9.15 or higher is required for reproducible model fits", call. = FALSE)
+ #' @param complete (`flag`)\cr whether to include potential non-estimable |
|
| 9 |
- }+ #' coefficients. |
||
| 10 |
-
+ #' @param ... mostly not used; |
||
| 11 | -! | +
- register_on_load(+ #' Exception is `model.matrix()` passing `...` to the default method. |
|
| 12 | -! | +
- "emmeans", c("1.6", NA),
+ #' @return Depends on the method, see Functions. |
|
| 13 | -! | +
- callback = function() emmeans::.emm_register("mmrm", pkgname),
+ #' |
|
| 14 | -! | +
- message = "mmrm() registered as emmeans extension"+ #' @name mmrm_tmb_methods |
|
| 15 |
- )+ #' |
||
| 16 |
-
+ #' @seealso [`mmrm_methods`], [`mmrm_tidiers`] for additional methods. |
||
| 17 | -! | +
- register_on_load(+ #' |
|
| 18 | -! | +
- "parsnip", c("1.1.0", NA),
+ #' @examples |
|
| 19 | -! | +
- callback = parsnip_add_mmrm,+ #' formula <- FEV1 ~ RACE + SEX + ARMCD * AVISIT + us(AVISIT | USUBJID) |
|
| 20 | -! | +
- message = emit_tidymodels_register_msg+ #' object <- fit_mmrm(formula, fev_data, weights = rep(1, nrow(fev_data))) |
|
| 21 |
- )+ NULL |
||
| 22 | -! | +
- register_on_load(+ |
|
| 23 | -! | +
- "car", c("3.1.2", NA),
+ #' @describeIn mmrm_tmb_methods obtains the estimated coefficients. |
|
| 24 | -! | +
- callback = car_add_mmrm,+ #' @importFrom stats coef |
|
| 25 | -! | +
- message = "mmrm() registered as car::Anova extension"+ #' @exportS3Method |
|
| 26 |
- )+ #' @examples |
||
| 27 |
- }+ #' # Estimated coefficients: |
||
| 28 |
-
+ #' coef(object) |
||
| 29 |
- #' Helper Function for Registering Functionality With Suggests Packages+ coef.mmrm_tmb <- function(object, complete = TRUE, ...) {
|
||
| 30 | -+ | 58x |
- #'+ assert_flag(complete) |
| 31 | -+ | 58x |
- #' @inheritParams check_package_version+ nm <- if (complete) "beta_est_complete" else "beta_est" |
| 32 | -+ | 58x |
- #'+ component(object, name = nm) |
| 33 |
- #' @param callback (`function(...) ANY`)\cr a callback to execute upon package+ } |
||
| 34 |
- #' load. Note that no arguments are passed to this function. Any necessary+ |
||
| 35 |
- #' data must be provided upon construction.+ #' @describeIn mmrm_tmb_methods obtains the fitted values. |
||
| 36 |
- #'+ #' @importFrom stats fitted |
||
| 37 |
- #' @param message (`NULL` or `string`)\cr an optional message to print after+ #' @exportS3Method |
||
| 38 |
- #' the callback is executed upon successful registration.+ #' @examples |
||
| 39 |
- #'+ #' # Fitted values: |
||
| 40 |
- #' @return A logical (invisibly) indicating whether registration was successful.+ #' fitted(object) |
||
| 41 |
- #' If not, a onLoad hook was set for the next time the package is loaded.+ fitted.mmrm_tmb <- function(object, ...) {
|
||
| 42 | -+ | 19x |
- #'+ fitted_col <- component(object, "x_matrix") %*% component(object, "beta_est") |
| 43 | -+ | 19x |
- #' @keywords internal+ fitted_col[, 1L, drop = TRUE] |
| 44 |
- register_on_load <- function(pkg,+ } |
||
| 45 |
- ver = c(NA_character_, NA_character_),+ |
||
| 46 |
- callback,+ #' @describeIn mmrm_tmb_methods predict conditional means for new data; |
||
| 47 |
- message = NULL) {
+ #' optionally with standard errors and confidence or prediction intervals. |
||
| 48 | -4x | +
- if (isNamespaceLoaded(pkg) && check_package_version(pkg, ver)) {
+ #' Returns a vector of predictions if `se.fit == FALSE` and |
|
| 49 | -3x | +
- callback()+ #' `interval == "none"`; otherwise it returns a data.frame with multiple |
|
| 50 | -2x | +
- if (is.character(message)) packageStartupMessage(message)+ #' columns and one row per input data row. |
|
| 51 | -1x | +
- if (is.function(message)) packageStartupMessage(message())+ #' |
|
| 52 | -3x | +
- return(invisible(TRUE))+ #' @param newdata (`data.frame`)\cr optional new data, otherwise data from `object` is used. |
|
| 53 |
- }+ #' @param se.fit (`flag`)\cr indicator if standard errors are required. |
||
| 54 |
-
+ #' @param interval (`string`)\cr type of interval calculation. Can be abbreviated. |
||
| 55 | -1x | +
- setHook(+ #' @param level (`number`)\cr tolerance/confidence level. |
|
| 56 | -1x | +
- packageEvent(pkg, event = "onLoad"),+ #' @param nsim (`count`)\cr number of simulations to use. |
|
| 57 | -1x | +
- action = "append",+ #' @param conditional (`flag`)\cr indicator if the prediction is conditional on the observation or not. |
|
| 58 | -1x | +
- function(...) {
+ #' |
|
| 59 | -! | +
- register_on_load(+ #' @importFrom stats predict |
|
| 60 | -! | +
- pkg = pkg,+ #' @exportS3Method |
|
| 61 | -! | +
- ver = ver,+ #' |
|
| 62 | -! | +
- callback = callback,+ #' @examples |
|
| 63 | -! | +
- message = message+ #' predict(object, newdata = fev_data) |
|
| 64 |
- )+ predict.mmrm_tmb <- function(object, |
||
| 65 |
- }+ newdata, |
||
| 66 |
- )+ se.fit = FALSE, # nolint |
||
| 67 |
-
+ interval = c("none", "confidence", "prediction"),
|
||
| 68 | -1x | +
- invisible(FALSE)+ level = 0.95, |
|
| 69 |
- }+ nsim = 1000L, |
||
| 70 |
-
+ conditional = FALSE, |
||
| 71 |
- #' Check Suggested Dependency Against Version Requirements+ ...) {
|
||
| 72 | -+ | 45x |
- #'+ if (missing(newdata)) {
|
| 73 | -+ | 8x |
- #' @param pkg (`string`)\cr package name.+ newdata <- object$data |
| 74 |
- #' @param ver (`character`)\cr of length 2 whose elements can be provided to+ } |
||
| 75 | -+ | 45x |
- #' [numeric_version()], representing a minimum and maximum (inclusive) version+ assert_data_frame(newdata) |
| 76 | -+ | 45x |
- #' requirement for interoperability. When `NA`, no version requirement is+ orig_row_names <- row.names(newdata) |
| 77 | -+ | 45x |
- #' imposed. Defaults to no version requirement.+ assert_flag(se.fit) |
| 78 | -+ | 45x |
- #'+ assert_number(level, lower = 0, upper = 1) |
| 79 | -+ | 45x |
- #' @return A logical (invisibly) indicating whether the loaded package meets+ assert_count(nsim, positive = TRUE) |
| 80 | -+ | 45x |
- #' the version requirements. A warning is emitted otherwise.+ assert_flag(conditional) |
| 81 | -+ | 45x |
- #'+ interval <- match.arg(interval) |
| 82 | -+ | 45x |
- #' @keywords internal+ formula_parts <- object$formula_parts |
| 83 | -+ | 45x |
- check_package_version <- function(pkg, ver = c(NA_character_, NA_character_)) {
+ if (any(object$tmb_data$x_cols_aliased)) {
|
| 84 | -7x | +1x |
- assert_character(ver, len = 2L)+ warning( |
| 85 | -6x | +1x |
- pkg_ver <- utils::packageVersion(pkg)+ "In fitted object there are co-linear variables and therefore dropped terms, ", |
| 86 | -6x | +1x |
- ver <- numeric_version(ver, strict = FALSE)+ "and this could lead to incorrect prediction on new data." |
| 87 |
-
+ ) |
||
| 88 | -6x | +
- warn_version <- function(pkg, pkg_ver, ver) {
+ } |
|
| 89 | -2x | +45x |
- ver_na <- is.na(ver)+ colnames <- names(Filter(isFALSE, object$tmb_data$x_cols_aliased)) |
| 90 | -2x | +45x |
- warning(sprintf(+ if (!conditional && interval %in% c("none", "confidence")) {
|
| 91 | -2x | +
- "Cannot register mmrm for use with %s (v%s). Version %s required.",+ # model.matrix always return a complete matrix (no NA allowed) |
|
| 92 | -2x | +27x |
- pkg, pkg_ver,+ x_mat <- stats::model.matrix(object, data = newdata, use_response = FALSE)[, colnames, drop = FALSE] |
| 93 | -2x | +27x |
- if (!any(ver_na)) {
+ x_mat_full <- matrix( |
| 94 | -! | +27x |
- sprintf("%s to %s", ver[1], ver[2])
+ NA, |
| 95 | -2x | +27x |
- } else if (ver_na[2]) {
+ nrow = nrow(newdata), ncol = ncol(x_mat), |
| 96 | -1x | +27x |
- paste0(">= ", ver[1])
+ dimnames = list(row.names(newdata), colnames(x_mat)) |
| 97 | -2x | +
- } else if (ver_na[1]) {
+ ) |
|
| 98 | -1x | +27x |
- paste0("<= ", ver[2])
+ x_mat_full[row.names(x_mat), ] <- x_mat |
| 99 | -+ | 27x |
- }+ predictions <- (x_mat_full %*% component(object, "beta_est"))[, 1] |
| 100 | -+ | 27x |
- ))+ predictions_raw <- stats::setNames(rep(NA_real_, nrow(newdata)), row.names(newdata)) |
| 101 | -+ | 27x |
- }+ predictions_raw[names(predictions)] <- predictions |
| 102 | -+ | 27x |
-
+ if (identical(interval, "none")) {
|
| 103 | -6x | +20x |
- if (identical(pkg_ver < ver[1], TRUE) || identical(pkg_ver > ver[2], TRUE)) {
+ return(predictions_raw) |
| 104 | -2x | +
- warn_version(pkg, pkg_ver, ver)+ } |
|
| 105 | -2x | +7x |
- return(invisible(FALSE))+ se <- switch(interval, |
| 106 |
- }+ # can be NA if there are aliased cols |
||
| 107 | -+ | 7x |
-
+ "confidence" = diag(x_mat_full %*% component(object, "beta_vcov") %*% t(x_mat_full)), |
| 108 | -4x | +7x |
- invisible(TRUE)+ "none" = NA_real_ |
| 109 |
- }+ ) |
||
| 110 | -+ | 7x |
-
+ res <- cbind( |
| 111 | -+ | 7x |
- #' Format a Message to Emit When Tidymodels is Loaded+ fit = predictions, se = se, |
| 112 | -+ | 7x |
- #'+ lwr = predictions - stats::qnorm(1 - level / 2) * se, upr = predictions + stats::qnorm(1 - level / 2) * se |
| 113 |
- #' @return A character message to emit. Either a ansi-formatted cli output if+ ) |
||
| 114 | -+ | 7x |
- #' package 'cli' is available or a plain-text message otherwise.+ if (!se.fit) {
|
| 115 | -+ | 1x |
- #'+ res <- res[, setdiff(colnames(res), "se")] |
| 116 |
- #' @keywords internal+ } |
||
| 117 | -+ | 7x |
- emit_tidymodels_register_msg <- function() {
+ res_raw <- matrix( |
| 118 | -1x | +7x |
- pkg <- utils::packageName()+ NA_real_, |
| 119 | -1x | +7x |
- ver <- utils::packageVersion(pkg)+ ncol = ncol(res), nrow = nrow(newdata), |
| 120 | -+ | 7x |
-
+ dimnames = list(row.names(newdata), colnames(res)) |
| 121 | -1x | +
- if (isTRUE(getOption("tidymodels.quiet"))) {
+ ) |
|
| 122 | -! | +7x |
- return()+ res_raw[row.names(res), ] <- res |
| 123 | -+ | 7x |
- }+ return(res_raw) |
| 124 |
-
+ } |
||
| 125 | -+ | 18x |
- # if tidymodels is attached, cli packages come as a dependency+ tmb_data <- h_mmrm_tmb_data( |
| 126 | -1x | +18x |
- has_cli <- requireNamespace("cli", quietly = TRUE)
+ formula_parts, newdata, |
| 127 | -1x | +18x |
- if (has_cli) {
+ weights = rep(1, nrow(newdata)), |
| 128 | -+ | 18x |
- # unfortunately, cli does not expose many formatting tools for emitting+ reml = TRUE, |
| 129 | -+ | 18x |
- # messages (only via conditions to stderr) which can't be suppressed using+ singular = "keep", |
| 130 | -+ | 18x |
- # suppressPackageStartupMessages() so formatting must be done adhoc,+ drop_visit_levels = FALSE, |
| 131 | -+ | 18x |
- # similar to how it's done in {tidymodels} R/attach.R
+ allow_na_response = TRUE, |
| 132 | -1x | +18x |
- paste0(+ drop_levels = FALSE, |
| 133 | -1x | +18x |
- cli::rule(+ xlev = component(object, "xlev"), |
| 134 | -1x | +18x |
- left = cli::style_bold("Model Registration"),
+ contrasts = component(object, "contrasts") |
| 135 | -1x | +
- right = paste(pkg, ver)+ ) |
|
| 136 | -+ | 18x |
- ),+ tmb_data$x_matrix <- tmb_data$x_matrix[, colnames, drop = FALSE] |
| 137 | -1x | +18x |
- "\n",+ predictions <- h_get_prediction( |
| 138 | -1x | +18x |
- cli::col_green(cli::symbol$tick), " ",+ tmb_data, object$theta_est, object$beta_est, component(object, "beta_vcov") |
| 139 | -1x | +18x |
- cli::col_blue("mmrm"), "::", cli::col_green("mmrm()")
+ )$prediction |
| 140 | -+ | 18x |
- )+ res <- cbind(fit = rep(NA_real_, nrow(newdata))) |
| 141 | -+ | 18x |
- } else {
+ new_order <- match(row.names(tmb_data$full_frame), orig_row_names) |
| 142 | -! | +18x |
- paste0(pkg, "::mmrm() registered for use with tidymodels")+ res[new_order, "fit"] <- predictions[, "fit"] |
| 143 | -+ | 18x |
- }+ se <- switch(interval, |
| 144 | -+ | 18x |
- }+ "confidence" = sqrt(predictions[, "conf_var"]), |
| 1 | -+ | |||
| 145 | +18x |
- #' Tidying Methods for `mmrm` Objects+ "prediction" = sqrt(h_get_prediction_variance(object, nsim, tmb_data)), |
||
| 2 | -+ | |||
| 146 | +18x |
- #'+ "none" = NULL |
||
| 3 | +147 |
- #' @description `r lifecycle::badge("experimental")`
+ ) |
||
| 4 | -+ | |||
| 148 | +18x |
- #'+ if (interval != "none") {
|
||
| 5 | -+ | |||
| 149 | +7x |
- #' These methods tidy the estimates from an `mmrm` object into a+ res <- cbind( |
||
| 6 | -+ | |||
| 150 | +7x |
- #' summary.+ res, |
||
| 7 | -+ | |||
| 151 | +7x |
- #'+ se = NA_real_ |
||
| 8 | +152 |
- #' @param x (`mmrm`)\cr fitted model.+ ) |
||
| 9 | -+ | |||
| 153 | +7x |
- #' @param conf.int (`flag`)\cr if `TRUE` columns for the lower (`conf.low`) and upper bounds+ res[new_order, "se"] <- se |
||
| 10 | -+ | |||
| 154 | +7x |
- #' (`conf.high`) of coefficient estimates are included.+ alpha <- 1 - level |
||
| 11 | -+ | |||
| 155 | +7x |
- #' @param conf.level (`number`)\cr defines the range of the optional confidence internal.+ z <- stats::qnorm(1 - alpha / 2) * res[, "se"] |
||
| 12 | -+ | |||
| 156 | +7x |
- #' @param newdata (`data.frame` or `NULL`)\cr optional new data frame.+ res <- cbind( |
||
| 13 | -+ | |||
| 157 | +7x |
- #' @param se_fit (`flag`)\cr whether to return standard errors of fit.+ res, |
||
| 14 | -+ | |||
| 158 | +7x |
- #' @param interval (`string`)\cr type of interval calculation.+ lwr = res[, "fit"] - z, |
||
| 15 | -+ | |||
| 159 | +7x |
- #' @param type.residuals (`string`)\cr passed on to [residuals.mmrm_tmb()].+ upr = res[, "fit"] + z |
||
| 16 | +160 |
- #' @param ... only used by `augment()` to pass arguments to the [predict.mmrm_tmb()] method.+ ) |
||
| 17 | -+ | |||
| 161 | +7x |
- #'+ if (!se.fit) {
|
||
| 18 | -+ | |||
| 162 | +! |
- #' @name mmrm_tidiers+ res <- res[, setdiff(colnames(res), "se")] |
||
| 19 | +163 |
- #' @aliases mmrm_tidiers+ } |
||
| 20 | +164 |
- #'+ } |
||
| 21 | +165 |
- #' @seealso [`mmrm_methods`], [`mmrm_tmb_methods`] for additional methods.+ # Use original names. |
||
| 22 | -+ | |||
| 166 | +18x |
- #'+ row.names(res) <- orig_row_names |
||
| 23 | -+ | |||
| 167 | +18x |
- #' @examples+ if (ncol(res) == 1) {
|
||
| 24 | -+ | |||
| 168 | +11x |
- #' fit <- mmrm(+ res <- res[, "fit"] |
||
| 25 | +169 |
- #' formula = FEV1 ~ RACE + SEX + ARMCD * AVISIT + us(AVISIT | USUBJID),+ } |
||
| 26 | -+ | |||
| 170 | +18x |
- #' data = fev_data+ return(res) |
||
| 27 | +171 |
- #' )+ } |
||
| 28 | +172 |
- NULL+ |
||
| 29 | +173 |
-
+ #' Get Prediction |
||
| 30 | +174 |
- #' @describeIn mmrm_tidiers derives tidy `tibble` from an `mmrm` object.+ #' |
||
| 31 | +175 |
- #' @exportS3Method+ #' @description Get predictions with given `data`, `theta`, `beta`, `beta_vcov`. |
||
| 32 | +176 |
- #' @examples+ #' |
||
| 33 | +177 |
- #' # Applying tidy method to return summary table of covariate estimates.+ #' @details See `predict` function in `predict.cpp` which is called internally. |
||
| 34 | +178 |
- #' fit |> tidy()+ #' |
||
| 35 | +179 |
- #' fit |> tidy(conf.int = TRUE, conf.level = 0.9)+ #' @param tmb_data (`mmrm_tmb_data`)\cr object. |
||
| 36 | +180 |
- tidy.mmrm <- function(x, # nolint+ #' @param theta (`numeric`)\cr theta value. |
||
| 37 | +181 |
- conf.int = FALSE, # nolint+ #' @param beta (`numeric`)\cr beta value. |
||
| 38 | +182 |
- conf.level = 0.95, # nolint+ #' @param beta_vcov (`matrix`)\cr beta_vcov matrix. |
||
| 39 | +183 |
- ...) {
- |
- ||
| 40 | -5x | -
- assert_flag(conf.int)+ #' |
||
| 41 | -5x | +|||
| 184 | +
- assert_number(conf.level, lower = 0, upper = 1)+ #' @return List with: |
|||
| 42 | -5x | +|||
| 185 | +
- tbl <- tibble::as_tibble(summary(x)$coefficients, rownames = "term")+ #' - `prediction`: Matrix with columns `fit`, `conf_var`, and `var`. |
|||
| 43 | -5x | +|||
| 186 | +
- colnames(tbl) <- c("term", "estimate", "std.error", "df", "statistic", "p.value")
+ #' - `covariance`: List with subject specific covariance matrices. |
|||
| 44 | -5x | +|||
| 187 | +
- coefs <- coef(x)+ #' - `index`: List of zero-based subject indices. |
|||
| 45 | -5x | +|||
| 188 | +
- if (length(coefs) != nrow(tbl)) {
+ #' |
|||
| 46 | -! | +|||
| 189 | +
- coefs <- tibble::enframe(coefs, name = "term", value = "estimate")+ #' @keywords internal |
|||
| 47 | -! | +|||
| 190 | +
- tbl <- merge(coefs, tbl, by = c("term", "estimate"))
+ h_get_prediction <- function(tmb_data, theta, beta, beta_vcov) {
|
|||
| 48 | -+ | |||
| 191 | +1696x |
- }+ assert_class(tmb_data, "mmrm_tmb_data") |
||
| 49 | -5x | +192 | +1696x |
- if (conf.int) {
+ assert_numeric(theta) |
| 50 | -4x | +193 | +1696x |
- ci <- h_tbl_confint_terms(x, level = conf.level)+ n_beta <- ncol(tmb_data$x_matrix) |
| 51 | -4x | +194 | +1696x |
- tbl <- tibble::as_tibble(merge(tbl, ci, by = "term"))+ assert_numeric(beta, finite = TRUE, any.missing = FALSE, len = n_beta) |
| 52 | -+ | |||
| 195 | +1696x |
- }+ assert_matrix(beta_vcov, mode = "numeric", any.missing = FALSE, nrows = n_beta, ncols = n_beta) |
||
| 53 | -5x | +196 | +1696x |
- tbl+ .Call(`_mmrm_predict`, PACKAGE = "mmrm", tmb_data, theta, beta, beta_vcov) |
| 54 | +197 |
} |
||
| 55 | +198 | |||
| 56 | +199 |
- #' @describeIn mmrm_tidiers derives `glance` `tibble` from an `mmrm` object.+ #' Get Prediction Variance |
||
| 57 | +200 |
- #' @exportS3Method+ #' |
||
| 58 | +201 |
- #' @examples+ #' @description Get prediction variance with given fit, `tmb_data` with the Monte Carlo sampling method. |
||
| 59 | +202 |
- #' # Applying glance method to return summary table of goodness of fit statistics.+ #' |
||
| 60 | +203 |
- #' fit |> glance()+ #' @param object (`mmrm_tmb`)\cr the fitted MMRM. |
||
| 61 | +204 |
- glance.mmrm <- function(x, ...) { # nolint
- |
- ||
| 62 | -1x | -
- tibble::as_tibble(summary(x)$aic_list)+ #' @param nsim (`count`)\cr number of samples. |
||
| 63 | +205 |
- }+ #' @param tmb_data (`mmrm_tmb_data`)\cr object. |
||
| 64 | +206 |
-
+ #' |
||
| 65 | +207 |
- #' @describeIn mmrm_tidiers derives `augment` `tibble` from an `mmrm` object.+ #' @keywords internal |
||
| 66 | +208 |
- #' @exportS3Method+ h_get_prediction_variance <- function(object, nsim, tmb_data) {
|
||
| 67 | -+ | |||
| 209 | +7x |
- #' @examples+ assert_class(object, "mmrm_tmb") |
||
| 68 | -+ | |||
| 210 | +7x |
- #' # Applying augment method to return merged `tibble` of model data, fitted and residuals.+ assert_class(tmb_data, "mmrm_tmb_data") |
||
| 69 | -+ | |||
| 211 | +7x |
- #' fit |> augment()+ assert_count(nsim, positive = TRUE)+ |
+ ||
| 212 | +7x | +
+ theta_chol <- chol(object$theta_vcov)+ |
+ ||
| 213 | +7x | +
+ n_theta <- length(object$theta_est)+ |
+ ||
| 214 | +7x | +
+ res <- replicate(nsim, {
+ |
+ ||
| 215 | +1150x | +
+ z <- stats::rnorm(n = n_theta)+ |
+ ||
| 216 | +1150x | +
+ theta_sample <- object$theta_est + z %*% theta_chol+ |
+ ||
| 217 | +1150x | +
+ cond_beta_results <- object$tmb_object$report(theta_sample)+ |
+ ||
| 218 | +1150x | +
+ beta_mean <- cond_beta_results$beta+ |
+ ||
| 219 | +1150x | +
+ beta_cov <- cond_beta_results$beta_vcov+ |
+ ||
| 220 | +1150x | +
+ h_get_prediction(tmb_data, theta_sample, beta_mean, beta_cov)$prediction |
||
| 70 | +221 |
- #' fit |> augment(interval = "confidence")+ })+ |
+ ||
| 222 | +7x | +
+ mean_of_var <- rowMeans(res[, "var", ])+ |
+ ||
| 223 | +7x | +
+ var_of_mean <- apply(res[, "fit", ], 1, stats::var)+ |
+ ||
| 224 | +7x | +
+ mean_of_var + var_of_mean |
||
| 71 | +225 |
- #' fit |> augment(type.residuals = "pearson")+ } |
||
| 72 | +226 |
- augment.mmrm <- function(x, # nolint+ |
||
| 73 | +227 |
- newdata = NULL,+ #' @describeIn mmrm_tmb_methods obtains the model frame. |
||
| 74 | +228 |
- interval = c("none", "confidence", "prediction"),
+ #' @param data (`data.frame`)\cr object in which to construct the frame. |
||
| 75 | +229 |
- se_fit = (interval != "none"),+ #' @param include (`character`)\cr names of variable types to include. |
||
| 76 | +230 |
- type.residuals = c("response", "pearson", "normalized"), # nolint
+ #' Must be `NULL` or one or more of `c("subject_var", "visit_var", "group_var", "response_var")`.
|
||
| 77 | +231 |
- ...) {
+ #' @param full (`flag`)\cr indicator whether to return full model frame (deprecated). |
||
| 78 | -9x | +|||
| 232 | +
- type.residuals <- match.arg(type.residuals) # nolint+ #' @param na.action (`string`)\cr na action. |
|||
| 79 | -9x | +|||
| 233 | +
- resid_df <- NULL+ #' @importFrom stats model.frame |
|||
| 80 | -9x | +|||
| 234 | +
- if (is.null(newdata)) {
+ #' @exportS3Method |
|||
| 81 | -4x | +|||
| 235 | +
- newdata <- stats::get_all_vars(x, data = stats::na.omit(x$data))+ #' |
|||
| 82 | -4x | +|||
| 236 | +
- resid_df <- data.frame(+ #' @details |
|||
| 83 | -4x | +|||
| 237 | +
- .rownames = rownames(newdata),+ #' `include` argument controls the variables the returned model frame will include. |
|||
| 84 | -4x | +|||
| 238 | +
- .resid = unname(residuals(x, type = type.residuals))+ #' Possible options are "response_var", "subject_var", "visit_var" and "group_var", representing the |
|||
| 85 | +239 |
- )+ #' response variable, subject variable, visit variable or group variable. |
||
| 86 | +240 |
- }+ #' `character` values in new data will always be factorized according to the data in the fit |
||
| 87 | -9x | +|||
| 241 | +
- interval <- match.arg(interval)+ #' to avoid mismatched in levels or issues in `model.matrix`. |
|||
| 88 | +242 |
-
+ #' |
||
| 89 | -9x | +|||
| 243 | +
- tbl <- h_newdata_add_pred(+ #' @examples |
|||
| 90 | -9x | +|||
| 244 | +
- x,+ #' # Model frame: |
|||
| 91 | -9x | +|||
| 245 | +
- newdata = newdata,+ #' model.frame(object) |
|||
| 92 | -9x | +|||
| 246 | +
- se_fit = se_fit,+ #' model.frame(object, include = "subject_var") |
|||
| 93 | -9x | +|||
| 247 | +
- interval = interval,+ model.frame.mmrm_tmb <- function(formula, data, include = c("subject_var", "visit_var", "group_var", "response_var"),
|
|||
| 94 | +248 |
- ...+ full, na.action = "na.omit", ...) { # nolint
|
||
| 95 | +249 |
- )+ # Construct updated formula and data arguments. |
||
| 96 | -9x | +250 | +46x |
- if (!is.null(resid_df)) {
+ lst_formula_and_data <- |
| 97 | -4x | +251 | +46x |
- tbl <- merge(tbl, resid_df, by = ".rownames")+ h_construct_model_frame_inputs( |
| 98 | -4x | +252 | +46x |
- tbl$.rownames <- as.numeric(tbl$.rownames)+ formula = formula, |
| 99 | -4x | +253 | +46x |
- tbl <- tbl[order(tbl$.rownames), , drop = FALSE]+ data = data, |
| 100 | -+ | |||
| 254 | +46x |
- }+ include = include, |
||
| 101 | -9x | +255 | +46x |
- tibble::as_tibble(tbl)+ full = full |
| 102 | +256 |
- }+ ) |
||
| 103 | +257 |
-
+ # Only if include is default (full) and also data is missing, and also na.action is na.omit we will |
||
| 104 | +258 |
- #' Extract `tibble` with Confidence Intervals and Term Names+ # use the model frame from the tmb_data. |
||
| 105 | -+ | |||
| 259 | +46x |
- #'+ include_choice <- c("subject_var", "visit_var", "group_var", "response_var")
|
||
| 106 | -+ | |||
| 260 | +46x |
- #' This is used in [tidy.mmrm()].+ if (missing(data) && setequal(include, include_choice) && identical(h_get_na_action(na.action), stats::na.omit)) {
|
||
| 107 | -+ | |||
| 261 | +2x |
- #'+ ret <- formula$tmb_data$full_frame |
||
| 108 | +262 |
- #' @param x (`mmrm`)\cr fit object.+ # Remove weights column. |
||
| 109 | -+ | |||
| 263 | +2x |
- #' @param ... passed to [stats::confint()], hence not used at the moment.+ ret[, "(weights)"] <- NULL |
||
| 110 | -+ | |||
| 264 | +2x |
- #'+ ret |
||
| 111 | +265 |
- #' @return A `tibble` with `term`, `conf.low`, `conf.high` columns.+ } else {
|
||
| 112 | +266 |
- #'+ # Construct data frame to return to users. |
||
| 113 | -+ | |||
| 267 | +44x |
- #' @keywords internal+ ret <- |
||
| 114 | -+ | |||
| 268 | +44x |
- h_tbl_confint_terms <- function(x, ...) {
+ stats::model.frame( |
||
| 115 | -8x | +269 | +44x |
- df <- stats::confint(x, ...)+ formula = lst_formula_and_data$formula, |
| 116 | -8x | +270 | +44x |
- tbl <- tibble::as_tibble(df, rownames = "term", .name_repair = "minimal")+ data = h_get_na_action(na.action)(lst_formula_and_data$data), |
| 117 | -8x | +271 | +44x |
- names(tbl) <- c("term", "conf.low", "conf.high")
+ na.action = na.action, |
| 118 | -8x | +272 | +44x |
- tbl+ xlev = stats::.getXlevels(terms(formula), formula$tmb_data$full_frame) |
| 119 | +273 |
- }+ ) |
||
| 120 | +274 |
-
+ } |
||
| 121 | -+ | |||
| 275 | +45x |
- #' Add Prediction Results to New Data+ ret |
||
| 122 | +276 |
- #'+ } |
||
| 123 | +277 |
- #' This is used in [augment.mmrm()].+ |
||
| 124 | +278 |
- #'+ |
||
| 125 | +279 |
- #' @param x (`mmrm`)\cr fit.+ #' Construction of Model Frame Formula and Data Inputs |
||
| 126 | +280 |
- #' @param newdata (`data.frame`)\cr data to predict.+ #' |
||
| 127 | +281 |
- #' @param se_fit (`flag`)\cr whether to return standard error of prediction,+ #' @description |
||
| 128 | +282 |
- #' can only be used when `interval` is not "none".+ #' Input formulas are converted from mmrm-style to a style compatible |
||
| 129 | +283 |
- #' @param interval (`string`)\cr type of interval.+ #' with default [stats::model.frame()] and [stats::model.matrix()] methods. |
||
| 130 | +284 |
- #' @param ... passed to [predict.mmrm_tmb()].+ #' |
||
| 131 | +285 |
- #'+ #' The full formula is returned so we can construct, for example, the |
||
| 132 | +286 |
- #' @return The `newdata` as a `tibble` with additional columns `.fitted`,+ #' `model.frame()` including all columns as well as the requested subset. |
||
| 133 | +287 |
- #' `.lower`, `.upper` (if interval is not `none`) and `.se.fit` (if `se_fit`+ #' The full set is used to identify rows to include in the reduced model frame. |
||
| 134 | +288 |
- #' requested).+ #' |
||
| 135 | +289 |
- #'+ #' @param formula (`mmrm`)\cr mmrm fit object. |
||
| 136 | +290 |
- #' @keywords internal+ #' @param data optional data frame that will be |
||
| 137 | +291 |
- h_newdata_add_pred <- function(x,+ #' passed to `model.frame()` or `model.matrix()` |
||
| 138 | +292 |
- newdata,+ #' @param include (`character`)\cr names of variable to include |
||
| 139 | +293 |
- se_fit,+ #' @param full (`flag`)\cr indicator whether to return full model frame (deprecated). |
||
| 140 | +294 |
- interval,+ #' |
||
| 141 | +295 |
- ...) {
+ #' @return named list with four elements: |
||
| 142 | -13x | +|||
| 296 | +
- assert_class(x, "mmrm")+ #' - `"formula"`: the formula including the columns requested in the `include=` argument. |
|||
| 143 | -13x | +|||
| 297 | +
- assert_data_frame(newdata)+ #' - `"data"`: a data frame including all columns needed in the formula. |
|||
| 144 | -13x | +|||
| 298 | +
- assert_flag(se_fit)+ #' full formula are identical |
|||
| 145 | -13x | +|||
| 299 | +
- assert_string(interval)+ #' @keywords internal |
|||
| 146 | -13x | +|||
| 300 | +
- if (interval == "none") {
+ h_construct_model_frame_inputs <- function(formula, |
|||
| 147 | -7x | +|||
| 301 | +
- assert_false(se_fit)+ data, |
|||
| 148 | +302 |
- }+ include, |
||
| 149 | +303 |
-
+ include_choice = c("subject_var", "visit_var", "group_var", "response_var"),
|
||
| 150 | -12x | +|||
| 304 | +
- tbl <- h_df_to_tibble(newdata)+ full) {
|
|||
| 151 | -12x | +305 | +280x |
- pred_results <- predict(+ if (!missing(full) && identical(full, TRUE)) {
|
| 152 | -12x | +|||
| 306 | +! |
- x,+ lifecycle::deprecate_warn("0.3", "model.frame.mmrm_tmb(full)")
+ |
+ ||
| 307 | +! | +
+ include <- include_choice+ |
+ ||
| 308 | ++ |
+ }+ |
+ ||
| 309 | ++ | + | ||
| 153 | -12x | +310 | +280x |
- newdata = newdata,+ assert_class(formula, classes = "mmrm_tmb") |
| 154 | -12x | +311 | +280x |
- na.action = stats::na.pass,+ assert_subset(include, include_choice) |
| 155 | -12x | +312 | +280x |
- se.fit = se_fit,+ if (missing(data)) {
|
| 156 | -12x | +313 | +256x |
- interval = interval,+ data <- formula$data |
| 157 | +314 |
- ...+ }+ |
+ ||
| 315 | +280x | +
+ assert_data_frame(data) |
||
| 158 | +316 |
- )+ |
||
| 159 | -12x | +317 | +280x |
- if (interval == "none") {
+ drop_response <- !"response_var" %in% include |
| 160 | -6x | +318 | +280x |
- assert_numeric(pred_results)+ add_vars <- unlist(formula$formula_parts[include]) |
| 161 | -6x | +319 | +280x |
- tbl$.fitted <- unname(pred_results)+ new_formula <- h_add_terms(formula$formula_parts$model_formula, add_vars, drop_response) |
| 162 | +320 |
- } else {
+
|
||
| 163 | -6x | +321 | +280x |
- assert_matrix(pred_results)+ drop_response_full <- !"response_var" %in% include_choice |
| 164 | -6x | +322 | +280x |
- tbl$.fitted <- unname(pred_results[, "fit"])+ add_vars_full <- unlist(formula$formula_parts[include_choice]) |
| 165 | -6x | +323 | +280x |
- tbl$.lower <- unname(pred_results[, "lwr"])+ new_formula_full <- |
| 166 | -6x | +324 | +280x |
- tbl$.upper <- unname(pred_results[, "upr"])+ h_add_terms(formula$formula_parts$model_formula, add_vars_full, drop_response_full) |
| 167 | +325 |
- }+ |
||
| 168 | -12x | +|||
| 326 | +
- if (se_fit) {
+ # Update data based on the columns in the full formula return. |
|||
| 169 | -5x | +327 | +280x |
- tbl$.se.fit <- unname(pred_results[, "se"])+ all_vars <- all.vars(new_formula_full) |
| 170 | -+ | |||
| 328 | +280x |
- }+ assert_names(colnames(data), must.include = all_vars) |
||
| 171 | -12x | +329 | +280x |
- tbl+ data <- data[, all_vars, drop = FALSE] |
| 172 | +330 |
- }+ |
||
| 173 | +331 |
-
+ # Return list with updated formula, data. |
||
| 174 | -+ | |||
| 332 | +280x |
- #' Coerce a Data Frame to a `tibble`+ list( |
||
| 175 | -+ | |||
| 333 | +280x |
- #'+ formula = new_formula, |
||
| 176 | -+ | |||
| 334 | +280x |
- #' This is used in [h_newdata_add_pred()].+ data = data |
||
| 177 | +335 |
- #'+ ) |
||
| 178 | +336 |
- #' @details This is only a thin wrapper around [tibble::as_tibble()], except+ } |
||
| 179 | +337 |
- #' giving a useful error message and it checks for `rownames` and adds them+ |
||
| 180 | +338 |
- #' as a new column `.rownames` if they are not just a numeric sequence as+ #' @describeIn mmrm_tmb_methods obtains the model matrix. |
||
| 181 | +339 |
- #' per the [tibble::has_rownames()] decision.+ #' @exportS3Method |
||
| 182 | +340 |
- #'+ #' @param use_response (`flag`)\cr whether to use the response for complete rows. |
||
| 183 | +341 |
- #' @param data (`data.frame`)\cr what to coerce.+ #' |
||
| 184 | +342 |
- #'+ #' @examples |
||
| 185 | +343 |
- #' @return The `data` as a `tibble`, potentially with a `.rownames` column.+ #' # Model matrix: |
||
| 186 | +344 |
- #'+ #' model.matrix(object) |
||
| 187 | +345 |
- #' @keywords internal+ model.matrix.mmrm_tmb <- function(object, data, use_response = TRUE, ...) { # nolint
|
||
| 188 | +346 |
- h_df_to_tibble <- function(data) {
+ # Always return the utilized model matrix if data not provided. |
||
| 189 | -15x | +347 | +37x |
- tryCatch(tbl <- tibble::as_tibble(data), error = function(cnd) {
+ if (missing(data)) {
|
| 190 | -1x | +348 | +3x |
- stop("Could not coerce data to `tibble`. Try explicitly passing a",
+ return(object$tmb_data$x_matrix) |
| 191 | -1x | +|||
| 349 | +
- "dataset to either the `data` or `newdata` argument.",+ } |
|||
| 192 | -1x | +350 | +34x |
- call. = FALSE+ stats::model.matrix( |
| 193 | -+ | |||
| 351 | +34x |
- )+ h_add_terms(object$formula_parts$model_formula, NULL, drop_response = !use_response), |
||
| 194 | -+ | |||
| 352 | +34x |
- })+ data = data, |
||
| 195 | -14x | +353 | +34x |
- if (tibble::has_rownames(data)) {
+ contrasts.arg = attr(object$tmb_data$x_matrix, "contrasts"), |
| 196 | -5x | +354 | +34x |
- tbl <- tibble::add_column(tbl, .rownames = rownames(data), .before = TRUE)+ xlev = component(object, "xlev"), |
| 197 | +355 |
- }+ ... |
||
| 198 | -14x | +|||
| 356 | +
- tbl+ ) |
|||
| 199 | +357 |
} |
| 1 | +358 |
- #' Obtain List of Jacobian Matrix Entries for Covariance Matrix+ |
||
| 2 | +359 |
- #'+ #' @describeIn mmrm_tmb_methods obtains the terms object. |
||
| 3 | +360 |
- #' @description Obtain the Jacobian matrices given the covariance function and variance parameters.+ #' @importFrom stats model.frame |
||
| 4 | +361 |
- #'+ #' @exportS3Method |
||
| 5 | +362 |
- #' @param tmb_data (`mmrm_tmb_data`)\cr produced by [h_mmrm_tmb_data()].+ #' |
||
| 6 | +363 |
- #' @param theta_est (`numeric`)\cr variance parameters point estimate.+ #' @examples |
||
| 7 | +364 |
- #' @param beta_vcov (`matrix`)\cr vairance covariance matrix of coefficients.+ #' # terms: |
||
| 8 | +365 |
- #'+ #' terms(object) |
||
| 9 | +366 |
- #' @return List with one element per variance parameter containing a matrix+ #' terms(object, include = "subject_var") |
||
| 10 | +367 |
- #' of the same dimensions as the covariance matrix. The values are the derivatives+ terms.mmrm_tmb <- function(x, include = "response_var", ...) { # nolint
|
||
| 11 | +368 |
- #' with regards to this variance parameter.+ # Construct updated formula and data arguments. |
||
| 12 | -+ | |||
| 369 | +231x |
- #'+ lst_formula_and_data <- |
||
| 13 | -+ | |||
| 370 | +231x |
- #' @keywords internal+ h_construct_model_frame_inputs(+ |
+ ||
| 371 | +231x | +
+ formula = x,+ |
+ ||
| 372 | +231x | +
+ include = include |
||
| 14 | +373 |
- h_jac_list <- function(tmb_data,+ ) |
||
| 15 | +374 |
- theta_est,+ |
||
| 16 | +375 |
- beta_vcov) {
+ # Use formula method for `terms()` to construct the mmrm terms object. |
||
| 17 | -81x | +376 | +231x |
- assert_class(tmb_data, "mmrm_tmb_data")+ stats::terms( |
| 18 | -81x | +377 | +231x |
- assert_numeric(theta_est)+ x = lst_formula_and_data$formula, |
| 19 | -81x | +378 | +231x |
- assert_matrix(beta_vcov)+ data = lst_formula_and_data$data |
| 20 | -81x | +|||
| 379 | +
- .Call(`_mmrm_get_jacobian`, PACKAGE = "mmrm", tmb_data, theta_est, beta_vcov)+ ) |
|||
| 21 | +380 |
} |
||
| 22 | +381 | |||
| 23 | +382 |
- #' Quadratic Form Calculations+ |
||
| 24 | +383 |
- #'+ #' @describeIn mmrm_tmb_methods obtains the attained log likelihood value. |
||
| 25 | +384 |
- #' @description These helpers are mainly for easier readability and slightly better efficiency+ #' @importFrom stats logLik |
||
| 26 | +385 |
- #' of the quadratic forms used in the Satterthwaite calculations.+ #' @exportS3Method |
||
| 27 | +386 |
- #'+ #' @examples |
||
| 28 | +387 |
- #' @param center (`matrix`)\cr square numeric matrix with the same dimensions as+ #' # Log likelihood given the estimated parameters: |
||
| 29 | +388 |
- #' `x` as the center of the quadratic form.+ #' logLik(object) |
||
| 30 | +389 |
- #'+ logLik.mmrm_tmb <- function(object, ...) {
|
||
| 31 | -+ | |||
| 390 | +50x |
- #' @name h_quad_form+ -component(object, "neg_log_lik") |
||
| 32 | +391 |
- NULL+ } |
||
| 33 | +392 | |||
| 34 | +393 |
- #' @describeIn h_quad_form calculates the number `vec %*% center %*% t(vec)`+ #' @describeIn mmrm_tmb_methods obtains the used formula. |
||
| 35 | +394 |
- #' as a numeric (not a matrix).+ #' @importFrom stats formula |
||
| 36 | +395 |
- #'+ #' @exportS3Method |
||
| 37 | +396 |
- #' @param vec (`numeric`)\cr interpreted as a row vector.+ #' @examples |
||
| 38 | +397 |
- #'+ #' # Formula which was used: |
||
| 39 | +398 |
- #' @keywords internal+ #' formula(object) |
||
| 40 | +399 |
- h_quad_form_vec <- function(vec, center) {
- |
- ||
| 41 | -5607x | -
- vec <- as.vector(vec)- |
- ||
| 42 | -5607x | -
- assert_numeric(vec, any.missing = FALSE)+ formula.mmrm_tmb <- function(x, ...) {
|
||
| 43 | -5607x | +400 | +5x |
- assert_matrix(+ x$formula_parts$formula |
| 44 | -5607x | +|||
| 401 | +
- center,+ } |
|||
| 45 | -5607x | +|||
| 402 | +
- mode = "numeric",+ |
|||
| 46 | -5607x | +|||
| 403 | +
- any.missing = FALSE,+ #' @describeIn mmrm_tmb_methods obtains the variance-covariance matrix estimate |
|||
| 47 | -5607x | +|||
| 404 | +
- nrows = length(vec),+ #' for the coefficients. |
|||
| 48 | -5607x | +|||
| 405 | +
- ncols = length(vec)+ #' @importFrom stats vcov |
|||
| 49 | +406 |
- )+ #' @exportS3Method |
||
| 50 | +407 |
-
+ #' @examples |
||
| 51 | -5607x | +|||
| 408 | +
- sum(vec * (center %*% vec))+ #' # Variance-covariance matrix estimate for coefficients: |
|||
| 52 | +409 |
- }+ #' vcov(object) |
||
| 53 | +410 |
-
+ vcov.mmrm_tmb <- function(object, complete = TRUE, ...) {
|
||
| 54 | -+ | |||
| 411 | +3x |
- #' @describeIn h_quad_form calculates the quadratic form `mat %*% center %*% t(mat)`+ assert_flag(complete) |
||
| 55 | -+ | |||
| 412 | +3x |
- #' as a matrix, the result is square and has dimensions identical to the number+ nm <- if (complete) "beta_vcov_complete" else "beta_vcov" |
||
| 56 | -+ | |||
| 413 | +3x |
- #' of rows in `mat`.+ component(object, name = nm) |
||
| 57 | +414 |
- #'+ } |
||
| 58 | +415 |
- #' @param mat (`matrix`)\cr numeric matrix to be multiplied left and right of+ |
||
| 59 | +416 |
- #' `center`, therefore needs to have as many columns as there are rows and columns+ #' @describeIn mmrm_tmb_methods obtains the variance-covariance matrix estimate |
||
| 60 | +417 |
- #' in `center`.+ #' for the residuals. |
||
| 61 | +418 |
- #'+ #' @param sigma cannot be used (this parameter does not exist in MMRM). |
||
| 62 | +419 |
- #' @keywords internal+ #' @importFrom nlme VarCorr |
||
| 63 | +420 |
- h_quad_form_mat <- function(mat, center) {
+ #' @export VarCorr |
||
| 64 | -119x | +|||
| 421 | +
- assert_matrix(mat, mode = "numeric", any.missing = FALSE, min.cols = 1L)+ #' @aliases VarCorr |
|||
| 65 | -119x | +|||
| 422 | +
- assert_matrix(+ #' @exportS3Method |
|||
| 66 | -119x | +|||
| 423 | +
- center,+ #' @examples |
|||
| 67 | -119x | +|||
| 424 | +
- mode = "numeric",+ #' # Variance-covariance matrix estimate for residuals: |
|||
| 68 | -119x | +|||
| 425 | +
- any.missing = FALSE,+ #' VarCorr(object) |
|||
| 69 | -119x | +|||
| 426 | +
- nrows = ncol(center),+ VarCorr.mmrm_tmb <- function(x, sigma = NA, ...) { # nolint
|
|||
| 70 | -119x | +427 | +10x |
- ncols = ncol(center)+ assert_scalar_na(sigma) |
| 71 | +428 |
- )+ |
||
| 72 | -119x | +429 | +10x |
- mat %*% tcrossprod(center, mat)+ component(x, name = "varcor") |
| 73 | +430 |
} |
||
| 74 | +431 | |||
| 75 | +432 |
- #' Computation of a Gradient Given Jacobian and Contrast Vector+ #' @describeIn mmrm_tmb_methods obtains the deviance, which is defined here |
||
| 76 | +433 |
- #'+ #' as twice the negative log likelihood, which can either be integrated |
||
| 77 | +434 |
- #' @description Computes the gradient of a linear combination of `beta` given the Jacobian matrix and+ #' over the coefficients for REML fits or the usual one for ML fits. |
||
| 78 | +435 |
- #' variance parameters.+ #' @importFrom stats deviance |
||
| 79 | +436 |
- #'+ #' @exportS3Method |
||
| 80 | +437 |
- #' @param jac_list (`list`)\cr Jacobian list produced e.g. by [h_jac_list()].+ #' @examples |
||
| 81 | +438 |
- #' @param contrast (`numeric`)\cr contrast vector, which needs to have the+ #' # REML criterion (twice the negative log likelihood): |
||
| 82 | +439 |
- #' same number of elements as there are rows and columns in each element of+ #' deviance(object) |
||
| 83 | +440 |
- #' `jac_list`.+ deviance.mmrm_tmb <- function(object, ...) {
|
||
| 84 | -+ | |||
| 441 | +74x |
- #'+ 2 * component(object, "neg_log_lik") |
||
| 85 | +442 |
- #' @return Numeric vector which contains the quadratic forms of each element of+ } |
||
| 86 | +443 |
- #' `jac_list` with the `contrast` vector.+ |
||
| 87 | +444 |
- #'+ #' @describeIn mmrm_tmb_methods obtains the Akaike Information Criterion, |
||
| 88 | +445 |
- #' @keywords internal+ #' where the degrees of freedom are the number of variance parameters (`n_theta`). |
||
| 89 | +446 |
- h_gradient <- function(jac_list, contrast) {
- |
- ||
| 90 | -491x | -
- assert_list(jac_list)- |
- ||
| 91 | -491x | -
- assert_numeric(contrast)+ #' If `corrected`, then this is multiplied with `m / (m - n_theta - 1)` where |
||
| 92 | +447 | - - | -||
| 93 | -491x | -
- vapply(- |
- ||
| 94 | -491x | -
- jac_list,- |
- ||
| 95 | -491x | -
- h_quad_form_vec,+ #' `m` is the number of observations minus the number of coefficients, or |
||
| 96 | -491x | +|||
| 448 | +
- vec = contrast,+ #' `n_theta + 2` if it is smaller than that \insertCite{hurvich1989regression,burnham1998practical}{mmrm}.
|
|||
| 97 | -491x | +|||
| 449 | +
- numeric(1L)+ #' @param corrected (`flag`)\cr whether corrected AIC should be calculated. |
|||
| 98 | +450 |
- )+ #' @param k (`number`)\cr the penalty per parameter to be used; default `k = 2` |
||
| 99 | +451 |
- }+ #' is the classical AIC. |
||
| 100 | +452 |
-
+ #' @importFrom stats AIC |
||
| 101 | +453 |
- #' Calculation of Satterthwaite Degrees of Freedom for One-Dimensional Contrast+ #' @exportS3Method |
||
| 102 | +454 |
- #'+ #' @examples |
||
| 103 | +455 |
- #' @description Used in [df_1d()] if method is+ #' # AIC: |
||
| 104 | +456 |
- #' "Satterthwaite".+ #' AIC(object) |
||
| 105 | +457 |
- #'+ #' AIC(object, corrected = TRUE) |
||
| 106 | +458 |
- #' @param object (`mmrm`)\cr the MMRM fit.+ #' @references |
||
| 107 | +459 |
- #' @param contrast (`numeric`)\cr contrast vector. Note that this should not include+ #' - \insertRef{hurvich1989regression}{mmrm}
|
||
| 108 | +460 |
- #' elements for singular coefficient estimates, i.e. only refer to the+ #' - \insertRef{burnham1998practical}{mmrm}
|
||
| 109 | +461 |
- #' actually estimated coefficients.+ AIC.mmrm_tmb <- function(object, corrected = FALSE, ..., k = 2) {
|
||
| 110 | +462 |
- #'+ # nolint |
||
| 111 | -+ | |||
| 463 | +44x |
- #' @return List with `est`, `se`, `df`, `t_stat` and `p_val`.+ assert_flag(corrected) |
||
| 112 | -+ | |||
| 464 | +44x |
- #' @keywords internal+ assert_number(k, lower = 1) |
||
| 113 | +465 |
- h_df_1d_sat <- function(object, contrast) {
+
|
||
| 114 | -456x | +466 | +44x |
- assert_class(object, "mmrm")+ n_theta <- length(component(object, "theta_est")) |
| 115 | -456x | +467 | +44x |
- contrast <- as.numeric(contrast)+ df <- if (!corrected) {
|
| 116 | -456x | +468 | +43x |
- assert_numeric(contrast, len = length(component(object, "beta_est")))+ n_theta |
| 117 | +469 |
-
+ } else {
|
||
| 118 | -456x | +470 | +1x |
- df <- if (identical(object$vcov, "Asymptotic")) {
+ n_obs <- length(component(object, "y_vector")) |
| 119 | -444x | +471 | +1x |
- grad <- h_gradient(component(object, "jac_list"), contrast)+ n_beta <- length(component(object, "beta_est")) |
| 120 | -444x | +472 | +1x |
- v_num <- 2 * h_quad_form_vec(contrast, component(object, "beta_vcov"))^2+ m <- max(n_theta + 2, n_obs - n_beta) |
| 121 | -444x | +473 | +1x |
- v_denom <- h_quad_form_vec(grad, component(object, "theta_vcov"))+ n_theta * (m / (m - n_theta - 1)) |
| 122 | -444x | +|||
| 474 | +
- v_num / v_denom+ } |
|||
| 123 | -456x | +|||
| 475 | +
- } else if (object$vcov %in% c("Empirical", "Empirical-Jackknife", "Empirical-Bias-Reduced")) {
+
|
|||
| 124 | -12x | +476 | +44x |
- contrast_matrix <- Matrix::.bdiag(rep(list(matrix(contrast, nrow = 1)), component(object, "n_subjects")))- |
-
| 125 | -12x | -
- contrast_matrix <- as.matrix(contrast_matrix)- |
- ||
| 126 | -12x | -
- g_matrix <- h_quad_form_mat(contrast_matrix, object$empirical_df_mat)- |
- ||
| 127 | -12x | -
- h_tr(g_matrix)^2 / sum(g_matrix^2)+ 2 * component(object, "neg_log_lik") + k * df |
||
| 128 | +477 |
- }+ } |
||
| 129 | +478 | |||
| 130 | -456x | +|||
| 479 | +
- h_test_1d(object, contrast, df)+ #' @describeIn mmrm_tmb_methods obtains the Bayesian Information Criterion, |
|||
| 131 | +480 |
- }+ #' which is using the natural logarithm of the number of subjects for the |
||
| 132 | +481 |
-
+ #' penalty parameter `k`. |
||
| 133 | +482 |
- #' Calculating Denominator Degrees of Freedom for the Multi-Dimensional Case+ #' @importFrom stats BIC |
||
| 134 | +483 |
- #'+ #' @exportS3Method |
||
| 135 | +484 |
- #' @description Calculates the degrees of freedom for multi-dimensional contrast.+ #' @examples |
||
| 136 | +485 |
- #'+ #' # BIC: |
||
| 137 | +486 |
- #' @param t_stat_df (`numeric`)\cr `n` t-statistic derived degrees of freedom.+ #' BIC(object) |
||
| 138 | +487 |
- #'+ BIC.mmrm_tmb <- function(object, ...) {
|
||
| 139 | +488 |
- #' @return Usually the calculation is returning `2 * E / (E - n)` where+ # nolint |
||
| 140 | -+ | |||
| 489 | +21x |
- #' `E` is the sum of `t / (t - 2)` over all `t_stat_df` values `t`.+ k <- log(component(object, "n_subjects"))+ |
+ ||
| 490 | +21x | +
+ AIC(object, corrected = FALSE, k = k) |
||
| 141 | +491 |
- #'+ } |
||
| 142 | +492 |
- #' @note If the input values are two similar to each other then just the average+ |
||
| 143 | +493 |
- #' of them is returned. If any of the inputs is not larger than 2 then 2 is+ |
||
| 144 | +494 |
- #' returned.+ #' @describeIn mmrm_tmb_methods prints the object. |
||
| 145 | +495 |
- #'+ #' @exportS3Method |
||
| 146 | +496 |
- #' @keywords internal+ print.mmrm_tmb <- function(x, |
||
| 147 | +497 |
- h_md_denom_df <- function(t_stat_df) {
+ ...) {
|
||
| 148 | -24x | +498 | +2x |
- assert_numeric(t_stat_df, min.len = 1L, lower = .Machine$double.xmin, any.missing = FALSE)+ cat("mmrm fit\n\n")
|
| 149 | +499 | |||
| 150 | -24x | -
- if (test_scalar(t_stat_df)) {
- |
- ||
| 151 | -1x | +500 | +2x |
- t_stat_df+ h_print_call( |
| 152 | -23x | +501 | +2x |
- } else if (all(abs(diff(t_stat_df)) < sqrt(.Machine$double.eps))) {
+ component(x, "call"), component(x, "n_obs"), |
| 153 | -1x | +502 | +2x |
- mean(t_stat_df)+ component(x, "n_subjects"), component(x, "n_timepoints") |
| 154 | -22x | +|||
| 503 | +
- } else if (any(t_stat_df <= 2)) {
+ ) |
|||
| 155 | +504 | 2x |
- 2+ h_print_cov(component(x, "cov_type"), component(x, "n_theta"), component(x, "n_groups")) |
|
| 156 | +505 |
- } else {
+
|
||
| 157 | -20x | +506 | +2x |
- e <- sum(t_stat_df / (t_stat_df - 2))+ cat("Inference: ")
|
| 158 | -20x | +507 | +2x |
- 2 * e / (e - (length(t_stat_df)))+ cat(ifelse(component(x, "reml"), "REML", "ML")) |
| 159 | -+ | |||
| 508 | +2x |
- }+ cat("\n")
|
||
| 160 | -+ | |||
| 509 | +2x |
- }+ cat("Deviance: ")
|
||
| 161 | -+ | |||
| 510 | +2x |
-
+ cat(deviance(x)) |
||
| 162 | +511 |
- #' Creating F-Statistic Results from One-Dimensional Contrast+ |
||
| 163 | -+ | |||
| 512 | +2x |
- #'+ cat("\n\nCoefficients: ")
|
||
| 164 | -+ | |||
| 513 | +2x |
- #' @description Creates multi-dimensional result from one-dimensional contrast from [df_1d()].+ n_singular_coefs <- sum(component(x, "beta_aliased")) |
||
| 165 | -+ | |||
| 514 | +2x |
- #'+ if (n_singular_coefs > 0) {
|
||
| 166 | -+ | |||
| 515 | +1x |
- #' @param object (`mmrm`)\cr model fit.+ cat("(", n_singular_coefs, " not defined because of singularities)", sep = "")
|
||
| 167 | +516 |
- #' @param contrast (`numeric`)\cr one-dimensional contrast.+ } |
||
| 168 | -+ | |||
| 517 | +2x |
- #'+ cat("\n")
|
||
| 169 | -+ | |||
| 518 | +2x |
- #' @return The one-dimensional degrees of freedom are calculated and then+ print(coef(x, complete = TRUE)) |
||
| 170 | +519 |
- #' based on that the p-value is calculated.+ |
||
| 171 | -+ | |||
| 520 | +2x |
- #'+ cat("\nModel Inference Optimization:")
|
||
| 172 | +521 |
- #' @keywords internal+ |
||
| 173 | -+ | |||
| 522 | +2x |
- h_df_md_from_1d <- function(object, contrast) {
+ cat(ifelse(component(x, "convergence") == 0, "\nConverged", "\nFailed to converge")) |
||
| 174 | -134x | +523 | +2x |
- res_1d <- h_df_1d_sat(object, contrast)+ cat( |
| 175 | -134x | +524 | +2x |
- list(+ " with code", component(x, "convergence"), |
| 176 | -134x | +525 | +2x |
- num_df = 1,+ "and message:", |
| 177 | -134x | +526 | +2x |
- denom_df = res_1d$df,+ if (is.null(component(x, "conv_message"))) "No message provided." else tolower(component(x, "conv_message"))+ |
+
| 527 | ++ |
+ ) |
||
| 178 | -134x | +528 | +2x |
- f_stat = res_1d$t_stat^2,+ cat("\n")
|
| 179 | -134x | +529 | +2x |
- p_val = stats::pf(q = res_1d$t_stat^2, df1 = 1, df2 = res_1d$df, lower.tail = FALSE)+ invisible(x) |
| 180 | +530 |
- )+ } |
||
| 181 | +531 |
- }+ |
||
| 182 | +532 | |||
| 183 | +533 |
- #' Calculation of Satterthwaite Degrees of Freedom for Multi-Dimensional Contrast+ #' @describeIn mmrm_tmb_methods to obtain residuals - either unscaled ('response'), 'pearson' or 'normalized'.
|
||
| 184 | +534 |
- #'+ #' @param type (`string`)\cr unscaled (`response`), `pearson` or `normalized`. Default is `response`, |
||
| 185 | +535 |
- #' @description Used in [df_md()] if method is "Satterthwaite".+ #' and this is the only type available for use with models with a spatial covariance structure. |
||
| 186 | +536 |
- #'+ #' @importFrom stats residuals |
||
| 187 | +537 |
- #' @param object (`mmrm`)\cr the MMRM fit.+ #' @exportS3Method |
||
| 188 | +538 |
- #' @param contrast (`matrix`)\cr numeric contrast matrix, if given a `numeric`+ #' @examples |
||
| 189 | +539 |
- #' then this is coerced to a row vector. Note that this should not include+ #' # residuals: |
||
| 190 | +540 |
- #' elements for singular coefficient estimates, i.e. only refer to the+ #' residuals(object, type = "response") |
||
| 191 | +541 |
- #' actually estimated coefficients.+ #' residuals(object, type = "pearson") |
||
| 192 | +542 |
- #'+ #' residuals(object, type = "normalized") |
||
| 193 | +543 |
- #' @return List with `num_df`, `denom_df`, `f_stat` and `p_val` (2-sided p-value).+ #' @references |
||
| 194 | +544 |
- #' @keywords internal+ #' - \insertRef{galecki2013linear}{mmrm}
|
||
| 195 | +545 |
- h_df_md_sat <- function(object, contrast) {
+ residuals.mmrm_tmb <- function(object, type = c("response", "pearson", "normalized"), ...) {
|
||
| 196 | -151x | +546 | +20x |
- assert_class(object, "mmrm")+ type <- match.arg(type) |
| 197 | -151x | +547 | +20x |
- assert_matrix(contrast, mode = "numeric", any.missing = FALSE, ncols = length(component(object, "beta_est")))+ switch(type, |
| 198 | -+ | |||
| 548 | +8x |
- # Early return if we are in the one-dimensional case.+ "response" = h_residuals_response(object), |
||
| 199 | -151x | +549 | +5x |
- if (identical(nrow(contrast), 1L)) {
+ "pearson" = h_residuals_pearson(object), |
| 200 | -132x | +550 | +7x |
- return(h_df_md_from_1d(object, contrast))+ "normalized" = h_residuals_normalized(object) |
| 201 | +551 |
- }+ ) |
||
| 202 | +552 |
-
+ } |
||
| 203 | -19x | +|||
| 553 | +
- contrast_cov <- h_quad_form_mat(contrast, component(object, "beta_vcov"))+ #' Calculate Pearson Residuals |
|||
| 204 | -19x | +|||
| 554 | +
- eigen_cont_cov <- eigen(contrast_cov)+ #' |
|||
| 205 | -19x | +|||
| 555 | +
- eigen_cont_cov_vctrs <- eigen_cont_cov$vectors+ #' This is used by [residuals.mmrm_tmb()] to calculate Pearson residuals. |
|||
| 206 | -19x | +|||
| 556 | +
- eigen_cont_cov_vals <- eigen_cont_cov$values+ #' |
|||
| 207 | +557 |
-
+ #' @param object (`mmrm_tmb`)\cr the fitted MMRM. |
||
| 208 | -19x | +|||
| 558 | +
- eps <- sqrt(.Machine$double.eps)+ #' |
|||
| 209 | -19x | +|||
| 559 | +
- tol <- max(eps * eigen_cont_cov_vals[1], 0)+ #' @return Vector of residuals. |
|||
| 210 | -19x | +|||
| 560 | +
- rank_cont_cov <- sum(eigen_cont_cov_vals > tol)+ #' |
|||
| 211 | -19x | +|||
| 561 | +
- assert_number(rank_cont_cov, lower = .Machine$double.xmin)+ #' @keywords internal+ |
+ |||
| 562 | ++ |
+ h_residuals_pearson <- function(object) {
|
||
| 212 | -19x | +563 | +6x |
- rank_seq <- seq_len(rank_cont_cov)+ assert_class(object, "mmrm_tmb") |
| 213 | -19x | +564 | +6x |
- vctrs_cont_prod <- crossprod(eigen_cont_cov_vctrs, contrast)[rank_seq, , drop = FALSE]+ h_residuals_response(object) * object$tmb_object$report()$diag_cov_inv_sqrt |
| 214 | +565 |
-
+ } |
||
| 215 | +566 |
- # Early return if rank 1.- |
- ||
| 216 | -19x | -
- if (identical(rank_cont_cov, 1L)) {
- |
- ||
| 217 | -1x | -
- return(h_df_md_from_1d(object, vctrs_cont_prod))+ |
||
| 218 | +567 |
- }+ #' Calculate normalized residuals |
||
| 219 | +568 | - - | -||
| 220 | -18x | -
- t_squared_nums <- drop(vctrs_cont_prod %*% object$beta_est)^2- |
- ||
| 221 | -18x | -
- t_squared_denoms <- eigen_cont_cov_vals[rank_seq]- |
- ||
| 222 | -18x | -
- t_squared <- t_squared_nums / t_squared_denoms- |
- ||
| 223 | -18x | -
- f_stat <- sum(t_squared) / rank_cont_cov- |
- ||
| 224 | -18x | -
- t_stat_df_nums <- 2 * eigen_cont_cov_vals^2- |
- ||
| 225 | -18x | -
- t_stat_df <- if (identical(object$vcov, "Asymptotic")) {
- |
- ||
| 226 | -18x | -
- grads_vctrs_cont_prod <- lapply(- |
- ||
| 227 | -18x | -
- rank_seq,- |
- ||
| 228 | -18x | -
- function(m) h_gradient(component(object, "jac_list"), contrast = vctrs_cont_prod[m, ])+ #' |
||
| 229 | +569 |
- )- |
- ||
| 230 | -18x | -
- t_stat_df_denoms <- vapply(- |
- ||
| 231 | -18x | -
- grads_vctrs_cont_prod,- |
- ||
| 232 | -18x | -
- h_quad_form_vec,- |
- ||
| 233 | -18x | -
- center = component(object, "theta_vcov"),- |
- ||
| 234 | -18x | -
- numeric(1)+ #' This is used by [residuals.mmrm_tmb()] to calculate normalized / scaled residuals. |
||
| 235 | +570 |
- )- |
- ||
| 236 | -18x | -
- t_stat_df_nums / t_stat_df_denoms+ #' |
||
| 237 | +571 |
- } else {
- |
- ||
| 238 | -! | -
- vapply(- |
- ||
| 239 | -! | -
- rank_seq,- |
- ||
| 240 | -! | -
- function(m) {
- |
- ||
| 241 | -! | -
- contrast_matrix <- Matrix::.bdiag(- |
- ||
| 242 | -! | -
- rep(list(vctrs_cont_prod[m, , drop = FALSE]), component(object, "n_subjects"))+ #' @param object (`mmrm_tmb`)\cr the fitted MMRM. |
||
| 243 | +572 |
- )- |
- ||
| 244 | -! | -
- contrast_matrix <- as.matrix(contrast_matrix)- |
- ||
| 245 | -! | -
- g_matrix <- h_quad_form_mat(contrast_matrix, object$empirical_df_mat)- |
- ||
| 246 | -! | -
- h_tr(g_matrix)^2 / sum(g_matrix^2)+ #' |
||
| 247 | +573 |
- },- |
- ||
| 248 | -! | -
- FUN.VALUE = 0+ #' @return Vector of residuals |
||
| 249 | +574 |
- )+ #' |
||
| 250 | +575 |
- }- |
- ||
| 251 | -18x | -
- denom_df <- h_md_denom_df(t_stat_df)+ #' @keywords internal |
||
| 252 | +576 | - - | -||
| 253 | -18x | -
- list(- |
- ||
| 254 | -18x | -
- num_df = rank_cont_cov,- |
- ||
| 255 | -18x | -
- denom_df = denom_df,+ h_residuals_normalized <- function(object) {
|
||
| 256 | -18x | +577 | +8x |
- f_stat = f_stat,+ assert_class(object, "mmrm_tmb") |
| 257 | -18x | -
- p_val = stats::pf(q = f_stat, df1 = rank_cont_cov, df2 = denom_df, lower.tail = FALSE)- |
- ||
| 258 | -+ | 578 | +8x |
- )+ object$tmb_object$report()$epsilonTilde |
| 259 | +579 |
} |
| 1 | +580 |
- #' Fitting an MMRM with Single Optimizer+ #' Calculate response residuals. |
||
| 2 | +581 |
#' |
||
| 3 | +582 |
- #' @description `r lifecycle::badge("experimental")`
+ #' This is used by [residuals.mmrm_tmb()] to calculate response residuals. |
||
| 4 | +583 |
#' |
||
| 5 | -- |
- #' This function helps to fit an MMRM using `TMB` with a single optimizer,- |
- ||
| 6 | +584 |
- #' while capturing messages and warnings.+ #' @param object (`mmrm_tmb`)\cr the fitted MMRM. |
||
| 7 | +585 |
#' |
||
| 8 | +586 |
- #' @inheritParams mmrm+ #' @return Vector of residuals |
||
| 9 | +587 |
- #' @param control (`mmrm_control`)\cr object.+ #' |
||
| 10 | +588 |
- #' @param tmb_data (`mmrm_tmb_data`)\cr object.+ #' @keywords internal |
||
| 11 | +589 |
- #' @param formula_parts (`mmrm_tmb_formula_parts`)\cr object.+ h_residuals_response <- function(object) {
|
||
| 12 | -+ | |||
| 590 | +15x |
- #' @param ... Additional arguments to pass to [mmrm_control()].+ assert_class(object, "mmrm_tmb") |
||
| 13 | -+ | |||
| 591 | +15x |
- #'+ component(object, "y_vector") - unname(fitted(object)) |
||
| 14 | +592 |
- #' @details+ } |
||
| 15 | +593 |
- #' `fit_single_optimizer` will fit the `mmrm` model using the `control` provided.+ |
||
| 16 | +594 |
- #' If there are multiple optimizers provided in `control`, only the first optimizer+ #' @describeIn mmrm_tmb_methods simulate responses from a fitted model according |
||
| 17 | +595 |
- #' will be used.+ #' to the simulation `method`, returning a `data.frame` of dimension `[n, m]` |
||
| 18 | +596 |
- #' If `tmb_data` and `formula_parts` are both provided, `formula`, `data`, `weights`,+ #' where n is the number of rows in `newdata`, |
||
| 19 | +597 |
- #' `reml`, and `covariance` are ignored.+ #' and m is the number `nsim` of simulated responses. |
||
| 20 | +598 |
#' |
||
| 21 | +599 |
- #' @return The `mmrm_fit` object, with additional attributes containing warnings,+ #' @param seed unused argument from [stats::simulate()]. |
||
| 22 | +600 |
- #' messages, optimizer used and convergence status in addition to the+ #' @param method (`string`)\cr simulation method to use. If "conditional", |
||
| 23 | +601 |
- #' `mmrm_tmb` contents.+ #' simulated values are sampled given the estimated covariance matrix of `object`. |
||
| 24 | +602 |
- #' @export+ #' If "marginal", the variance of the estimated covariance matrix is taken into account. |
||
| 25 | +603 |
#' |
||
| 26 | +604 |
- #' @examples+ #' @importFrom stats simulate |
||
| 27 | +605 |
- #' mod_fit <- fit_single_optimizer(+ #' @exportS3Method |
||
| 28 | +606 |
- #' formula = FEV1 ~ RACE + SEX + ARMCD * AVISIT + us(AVISIT | USUBJID),+ simulate.mmrm_tmb <- function(object, |
||
| 29 | +607 |
- #' data = fev_data,+ nsim = 1, |
||
| 30 | +608 |
- #' weights = rep(1, nrow(fev_data)),+ seed = NULL, |
||
| 31 | +609 |
- #' optimizer = "nlminb"+ newdata, |
||
| 32 | +610 |
- #' )+ ..., |
||
| 33 | +611 |
- #' attr(mod_fit, "converged")+ method = c("conditional", "marginal")) {
|
||
| 34 | -+ | |||
| 612 | +15x |
- fit_single_optimizer <- function(formula,+ assert_count(nsim, positive = TRUE) |
||
| 35 | -+ | |||
| 613 | +15x |
- data,+ assert_null(seed) |
||
| 36 | -+ | |||
| 614 | +15x |
- weights,+ if (missing(newdata)) {
|
||
| 37 | -+ | |||
| 615 | +12x |
- reml = TRUE,+ newdata <- object$data |
||
| 38 | +616 |
- covariance = NULL,+ } |
||
| 39 | -+ | |||
| 617 | +15x |
- tmb_data,+ assert_data_frame(newdata) |
||
| 40 | -+ | |||
| 618 | +15x |
- formula_parts,+ method <- match.arg(method) |
||
| 41 | +619 |
- ...,+ |
||
| 42 | +620 |
- control = mmrm_control(...)) {
+
|
||
| 43 | -198x | -
- to_remove <- list(- |
- ||
| 44 | -+ | 621 | +15x |
- # Transient visit to invalid parameters.+ tmb_data <- h_mmrm_tmb_data( |
| 45 | -198x | +622 | +15x |
- warnings = c("NA/NaN function evaluation")
+ object$formula_parts, newdata, |
| 46 | -+ | |||
| 623 | +15x |
- )+ weights = rep(1, nrow(newdata)), |
||
| 47 | -198x | +624 | +15x |
- as_diverged <- list(+ reml = TRUE, |
| 48 | -198x | +625 | +15x |
- errors = c(+ singular = "keep", |
| 49 | -198x | +626 | +15x |
- "NA/NaN Hessian evaluation",+ drop_visit_levels = FALSE, |
| 50 | -198x | +627 | +15x |
- "L-BFGS-B needs finite values of 'fn'"+ allow_na_response = TRUE, |
| 51 | -+ | |||
| 628 | +15x |
- )+ drop_levels = FALSE,+ |
+ ||
| 629 | +15x | +
+ xlev = component(object, "xlev"),+ |
+ ||
| 630 | +15x | +
+ contrasts = component(object, "contrasts") |
||
| 52 | +631 |
) |
||
| 53 | -198x | +632 | +15x |
- if (missing(tmb_data) || missing(formula_parts)) {
+ ret <- if (method == "conditional") {
|
| 54 | -14x | +633 | +8x |
- h_valid_formula(formula)+ predict_res <- h_get_prediction(tmb_data, object$theta_est, object$beta_est, object$beta_vcov) |
| 55 | -13x | +634 | +8x |
- assert_data_frame(data)+ as.data.frame(h_get_sim_per_subj(predict_res, tmb_data$n_subjects, nsim)) |
| 56 | -13x | +635 | +15x |
- assert_numeric(weights, any.missing = FALSE, lower = .Machine$double.xmin)+ } else if (method == "marginal") {
|
| 57 | -13x | +636 | +7x |
- assert_flag(reml)+ theta_chol <- t(chol(object$theta_vcov)) |
| 58 | -13x | +637 | +7x |
- assert_class(control, "mmrm_control")+ n_theta <- length(object$theta_est) |
| 59 | -13x | +638 | +7x |
- assert_list(control$optimizers, names = "unique", types = c("function", "partial"))
+ as.data.frame( |
| 60 | -13x | +639 | +7x |
- quiet_fit <- h_record_all_output(+ sapply(seq_len(nsim), function(x) {
|
| 61 | -13x | +640 | +503x |
- fit_mmrm(+ newtheta <- object$theta_est + theta_chol %*% matrix(stats::rnorm(n_theta), ncol = 1) |
| 62 | -13x | +|||
| 641 | +
- formula = formula,+ # Recalculate betas with sampled thetas. |
|||
| 63 | -13x | +642 | +503x |
- data = data,+ hold <- object$tmb_object$report(newtheta) |
| 64 | -13x | +|||
| 643 | +
- weights = weights,+ # Resample betas given new beta distribution. |
|||
| 65 | -13x | +|||
| 644 | +
- reml = reml,+ # We first solve L^\top w = D^{-1/2}z_{sample}:
|
|||
| 66 | -13x | +645 | +503x |
- covariance = covariance,+ w_sample <- backsolve( |
| 67 | -13x | +646 | +503x |
- control = control+ r = hold$XtWX_L, |
| 68 | -+ | |||
| 647 | +503x |
- ),+ x = stats::rnorm(length(hold$beta)) / sqrt(hold$XtWX_D), |
||
| 69 | -13x | +648 | +503x |
- remove = to_remove,+ upper.tri = FALSE, |
| 70 | -13x | +649 | +503x |
- divergence = as_diverged+ transpose = TRUE |
| 71 | +650 |
- )+ ) |
||
| 72 | +651 |
- } else {
+ # Then we add the mean vector, the beta estimate. |
||
| 73 | -184x | +652 | +503x |
- assert_class(tmb_data, "mmrm_tmb_data")+ beta_sample <- hold$beta + w_sample |
| 74 | -184x | +653 | +503x |
- assert_class(formula_parts, "mmrm_tmb_formula_parts")+ predict_res <- h_get_prediction(tmb_data, newtheta, beta_sample, hold$beta_vcov) |
| 75 | -184x | +654 | +503x |
- quiet_fit <- h_record_all_output(+ h_get_sim_per_subj(predict_res, tmb_data$n_subjects, 1L) |
| 76 | -184x | +|||
| 655 | +
- fit_mmrm(+ })+ |
+ |||
| 656 | ++ |
+ )+ |
+ ||
| 657 | ++ |
+ } |
||
| 77 | -184x | +658 | +15x |
- formula_parts = formula_parts,+ orig_row_names <- row.names(newdata) |
| 78 | -184x | +659 | +15x |
- tmb_data = tmb_data,+ new_order <- match(orig_row_names, row.names(tmb_data$full_frame)) |
| 79 | -184x | +660 | +15x |
- control = control+ ret[new_order, , drop = FALSE] |
| 80 | +661 |
- ),+ } |
||
| 81 | -184x | +|||
| 662 | +
- remove = to_remove,+ |
|||
| 82 | -184x | +|||
| 663 | +
- divergence = as_diverged+ #' Get simulated values by patient. |
|||
| 83 | +664 |
- )+ #' |
||
| 84 | +665 |
- }+ #' @param predict_res (`list`)\cr from [h_get_prediction()]. |
||
| 85 | -197x | +|||
| 666 | +
- if (length(quiet_fit$errors)) {
+ #' @param nsub (`count`)\cr number of subjects. |
|||
| 86 | -4x | +|||
| 667 | +
- stop(quiet_fit$errors)+ #' @param nsim (`count`)\cr number of values to simulate. |
|||
| 87 | +668 |
- }+ #' |
||
| 88 | -193x | +|||
| 669 | +
- converged <- (length(quiet_fit$warnings) == 0L) &&+ #' @keywords internal |
|||
| 89 | -193x | +|||
| 670 | +
- (length(quiet_fit$divergence) == 0L) &&+ h_get_sim_per_subj <- function(predict_res, nsub, nsim) {
|
|||
| 90 | -193x | +671 | +517x |
- isTRUE(quiet_fit$result$opt_details$convergence == 0)+ assert_list(predict_res) |
| 91 | -193x | +672 | +517x |
- structure(+ assert_count(nsub, positive = TRUE) |
| 92 | -193x | +673 | +516x |
- quiet_fit$result,+ assert_count(nsim, positive = TRUE) |
| 93 | -193x | +|||
| 674 | +
- warnings = quiet_fit$warnings,+ |
|||
| 94 | -193x | +675 | +515x |
- messages = quiet_fit$messages,+ ret <- matrix( |
| 95 | -193x | +676 | +515x |
- divergence = quiet_fit$divergence,+ predict_res$prediction[, "fit"], |
| 96 | -193x | +677 | +515x |
- converged = converged,+ ncol = nsim, |
| 97 | -193x | +678 | +515x |
- class = c("mmrm_fit", class(quiet_fit$result))
+ nrow = nrow(predict_res$prediction) |
| 98 | +679 |
) |
||
| 99 | -+ | |||
| 680 | +515x |
- }+ for (i in seq_len(nsub)) {
|
||
| 100 | +681 |
-
+ # Skip subjects which are not included in predict_res. |
||
| 101 | -+ | |||
| 682 | +82699x |
- #' Summarizing List of Fits+ if (length(predict_res$index[[i]]) > 0) {
|
||
| 102 | +683 |
- #'+ # Obtain indices of data.frame belonging to subject i |
||
| 103 | +684 |
- #' @param all_fits (`list` of `mmrm_fit` or `try-error`)\cr list of fits.+ # (increment by 1, since indices from cpp are 0-order). |
||
| 104 | -+ | |||
| 685 | +66631x |
- #'+ inds <- predict_res$index[[i]] + 1 |
||
| 105 | -+ | |||
| 686 | +66631x |
- #' @return List with `warnings`, `messages`, `log_liks` and `converged` results.+ obs <- length(inds) |
||
| 106 | +687 |
- #' @keywords internal+ |
||
| 107 | +688 |
- h_summarize_all_fits <- function(all_fits) {
+ # Get relevant covariance matrix for subject i. |
||
| 108 | -8x | +689 | +66631x |
- assert_list(all_fits, types = c("mmrm_fit", "try-error"))
+ covmat_i <- predict_res$covariance[[i]] |
| 109 | -8x | +690 | +66631x |
- is_error <- vapply(all_fits, is, logical(1), class2 = "try-error")+ theta_chol <- t(chol(covmat_i)) |
| 110 | +691 | |||
| 111 | -8x | -
- warnings <- messages <- vector(mode = "list", length = length(all_fits))- |
- ||
| 112 | -8x | -
- warnings[is_error] <- lapply(all_fits[is_error], as.character)- |
- ||
| 113 | -8x | +|||
| 692 | +
- warnings[!is_error] <- lapply(all_fits[!is_error], attr, which = "warnings")+ # Simulate epsilon from covariance matrix. |
|||
| 114 | -8x | +693 | +66631x |
- messages[!is_error] <- lapply(all_fits[!is_error], attr, which = "messages")+ mus <- ret[inds, , drop = FALSE] |
| 115 | -8x | +694 | +66631x |
- log_liks <- as.numeric(rep(NA, length.out = length(all_fits)))+ epsilons <- theta_chol %*% matrix(stats::rnorm(nsim * obs), ncol = nsim) |
| 116 | -8x | +695 | +66631x |
- log_liks[!is_error] <- vapply(all_fits[!is_error], stats::logLik, numeric(1L))+ ret[inds, ] <- mus + epsilons |
| 117 | -8x | +|||
| 696 | +
- converged <- rep(FALSE, length.out = length(all_fits))+ } |
|||
| 118 | -8x | +|||
| 697 | +
- converged[!is_error] <- vapply(all_fits[!is_error], attr, logical(1), which = "converged")+ } |
|||
| 119 | +698 | |||
| 120 | -8x | +699 | +515x |
- list(+ ret |
| 121 | -8x | +|||
| 700 | +
- warnings = warnings,+ } |
|||
| 122 | -8x | +
| 1 | +
- messages = messages,+ #' Capture all Output |
|||
| 123 | -8x | +|||
| 2 | +
- log_liks = log_liks,+ #' |
|||
| 124 | -8x | +|||
| 3 | +
- converged = converged+ #' This function silences all warnings, errors & messages and instead returns a list |
|||
| 125 | +4 |
- )+ #' containing the results (if it didn't error), as well as the warnings, errors |
||
| 126 | +5 |
- }+ #' and messages and divergence signals as character vectors. |
||
| 127 | -- | - - | -||
| 128 | -- |
- #' Refitting MMRM with Multiple Optimizers- |
- ||
| 129 | +6 |
#' |
||
| 130 | +7 |
- #' @description `r lifecycle::badge("experimental")`
+ #' @param expr (`expression`)\cr to be executed. |
||
| 131 | +8 |
- #'+ #' @param remove (`list`)\cr optional list with elements `warnings`, `errors`, |
||
| 132 | +9 |
- #' @param fit (`mmrm_fit`)\cr original model fit from [fit_single_optimizer()].+ #' `messages` which can be character vectors, which will be removed from the |
||
| 133 | +10 |
- #' @param ... Additional arguments passed to [mmrm_control()].+ #' results if specified. |
||
| 134 | +11 |
- #' @param control (`mmrm_control`)\cr object.+ #' @param divergence (`list`)\cr optional list similar as `remove`, but these |
||
| 135 | +12 |
- #'+ #' character vectors will be moved to the `divergence` result and signal |
||
| 136 | +13 |
- #' @return The best (in terms of log likelihood) fit which converged.+ #' that the fit did not converge. |
||
| 137 | +14 |
#' |
||
| 138 | +15 |
- #' @note For Windows, no parallel computations are currently implemented.+ #' @return |
||
| 139 | +16 |
- #' @export+ #' A list containing |
||
| 140 | +17 |
#' |
||
| 141 | +18 |
- #' @examples+ #' - `result`: The object returned by `expr` or `list()` if an error was thrown. |
||
| 142 | +19 |
- #' fit <- fit_single_optimizer(+ #' - `warnings`: `NULL` or a character vector if warnings were thrown. |
||
| 143 | +20 |
- #' formula = FEV1 ~ RACE + SEX + ARMCD * AVISIT + us(AVISIT | USUBJID),+ #' - `errors`: `NULL` or a string if an error was thrown. |
||
| 144 | +21 |
- #' data = fev_data,+ #' - `messages`: `NULL` or a character vector if messages were produced. |
||
| 145 | +22 |
- #' weights = rep(1, nrow(fev_data)),+ #' - `divergence`: `NULL` or a character vector if divergence messages were caught. |
||
| 146 | +23 |
- #' optimizer = "nlminb"+ #' |
||
| 147 | +24 |
- #' )+ #' @keywords internal |
||
| 148 | +25 |
- #' best_fit <- refit_multiple_optimizers(fit)+ h_record_all_output <- function(expr, |
||
| 149 | +26 |
- refit_multiple_optimizers <- function(fit,+ remove = list(), |
||
| 150 | +27 |
- ...,+ divergence = list()) {
|
||
| 151 | +28 |
- control = mmrm_control(...)) {
- |
- ||
| 152 | -6x | -
- assert_class(fit, "mmrm_fit")+ # Note: We don't need to and cannot assert `expr` here. |
||
| 153 | -6x | -
- assert_class(control, "mmrm_control")- |
- ||
| 154 | -+ | 29 | +200x |
-
+ assert_list(remove, types = "character") |
| 155 | -6x | +30 | +200x |
- n_cores_used <- ifelse(+ assert_list(divergence, types = "character") |
| 156 | -6x | +31 | +200x |
- .Platform$OS.type == "windows",+ env <- new.env() |
| 157 | -6x | +32 | +200x |
- 1L,+ result <- withCallingHandlers( |
| 158 | -6x | +33 | +200x |
- min(+ withRestarts( |
| 159 | -6x | +34 | +200x |
- length(control$optimizers),+ expr, |
| 160 | -6x | +35 | +200x |
- control$n_cores+ muffleStop = function(e) structure(e$message, class = "try-error") |
| 161 | +36 |
- )+ ), |
||
| 162 | -+ | |||
| 37 | +200x |
- )+ message = function(m) {
|
||
| 163 | +38 | 6x |
- controls <- h_split_control(+ msg_without_newline <- gsub(m$message, pattern = "\n$", replacement = "") |
|
| 164 | +39 | 6x |
- control,+ env$message <- c(env$message, msg_without_newline) |
|
| 165 | +40 | 6x |
- start = fit$theta_est- |
- |
| 166 | -- |
- )+ invokeRestart("muffleMessage")
|
||
| 167 | +41 |
-
+ }, |
||
| 168 | -+ | |||
| 42 | +200x |
- # Take the results from old fit as starting values for new fits.+ warning = function(w) {
|
||
| 169 | -6x | +43 | +14x |
- all_fits <- suppressWarnings(parallel::mcmapply(+ env$warning <- c(env$warning, w$message) |
| 170 | -6x | +44 | +14x |
- FUN = fit_single_optimizer,+ invokeRestart("muffleWarning")
|
| 171 | -6x | +|||
| 45 | +
- control = controls,+ }, |
|||
| 172 | -6x | +46 | +200x |
- MoreArgs = list(+ error = function(e) {
|
| 173 | -6x | +47 | +14x |
- tmb_data = fit$tmb_data,+ env$error <- c(env$error, e$message) |
| 174 | -6x | +48 | +14x |
- formula_parts = fit$formula_parts+ invokeRestart("muffleStop", e)
|
| 175 | +49 |
- ),- |
- ||
| 176 | -6x | -
- mc.cores = n_cores_used,- |
- ||
| 177 | -6x | -
- mc.silent = TRUE,- |
- ||
| 178 | -6x | -
- SIMPLIFY = FALSE+ } |
||
| 179 | +50 |
- ))+ ) |
||
| 180 | -6x | +51 | +200x |
- all_fits <- c(all_fits, list(old_result = fit))+ list( |
| 181 | -+ | |||
| 52 | +200x |
-
+ result = result, |
||
| 182 | -+ | |||
| 53 | +200x |
- # Find the results that are ok and return best in terms of log-likelihood.+ warnings = setdiff(env$warning, c(remove$warnings, divergence$warnings)), |
||
| 183 | -6x | +54 | +200x |
- all_fits_summary <- h_summarize_all_fits(all_fits)+ errors = setdiff(env$error, c(remove$errors, divergence$errors)), |
| 184 | -6x | +55 | +200x |
- is_ok <- all_fits_summary$converged+ messages = setdiff(env$message, c(remove$messages, divergence$messages)), |
| 185 | -6x | +56 | +200x |
- if (!any(is_ok)) {
+ divergence = c( |
| 186 | -1x | +57 | +200x |
- stop(+ intersect(env$warning, divergence$warnings), |
| 187 | -1x | +58 | +200x |
- "No optimizer led to a successful model fit. ",+ intersect(env$error, divergence$errors), |
| 188 | -1x | +59 | +200x |
- "Please try to use a different covariance structure or other covariates."+ intersect(env$message, divergence$messages) |
| 189 | +60 |
) |
||
| 190 | +61 |
- }- |
- ||
| 191 | -5x | -
- best_optimizer <- which.max(all_fits_summary$log_liks[is_ok])- |
- ||
| 192 | -5x | -
- all_fits[[which(is_ok)[best_optimizer]]]+ ) |
||
| 193 | +62 |
} |
||
| 194 | +63 | |||
| 195 | +64 |
- #' Control Parameters for Fitting an MMRM+ #' Trace of a Matrix |
||
| 196 | +65 |
#' |
||
| 197 | +66 |
- #' @description `r lifecycle::badge("experimental")`
+ #' @description Obtain the trace of a matrix if the matrix is diagonal, otherwise raise an error. |
||
| 198 | +67 |
- #' Fine-grained specification of the MMRM fit details is possible using this+ #' |
||
| 199 | +68 |
- #' control function.+ #' @param x (`matrix`)\cr square matrix input. |
||
| 200 | +69 |
#' |
||
| 201 | +70 |
- #' @param n_cores (`count`)\cr number of cores to be used.+ #' @return The trace of the square matrix. |
||
| 202 | +71 |
- #' @param method (`string`)\cr adjustment method for degrees of freedom.+ #' |
||
| 203 | +72 |
- #' @param vcov (`string`)\cr coefficients covariance matrix adjustment method.+ #' @keywords internal |
||
| 204 | +73 |
- #' @param start (`NULL`, `numeric` or `function`)\cr optional start values for variance+ h_tr <- function(x) {
|
||
| 205 | -+ | |||
| 74 | +1790x |
- #' parameters. See details for more information.+ if (nrow(x) != ncol(x)) {
|
||
| 206 | -+ | |||
| 75 | +1x |
- #' @param accept_singular (`flag`)\cr whether singular design matrices are reduced+ stop("x must be square matrix")
|
||
| 207 | +76 |
- #' to full rank automatically and additional coefficient estimates will be missing.+ } |
||
| 208 | -+ | |||
| 77 | +1789x |
- #' @param optimizers (`list`)\cr optimizer specification, created with [h_get_optimizers()].+ sum(Matrix::diag(x)) |
||
| 209 | +78 |
- #' @param drop_visit_levels (`flag`)\cr whether to drop levels for visit variable,+ } |
||
| 210 | +79 |
- #' if visit variable is a factor, see details.+ |
||
| 211 | +80 |
- #' @param ... additional arguments passed to [h_get_optimizers()].+ #' Split Control List |
||
| 212 | +81 |
#' |
||
| 213 | +82 |
- #' @details+ #' @description Split the [mmrm_control()] object according to its optimizers and use additional arguments |
||
| 214 | +83 |
- # - The `drop_visit_levels` flag will decide whether unobserved visits will be kept for analysis.+ #' to replace the elements in the original object. |
||
| 215 | +84 |
- #' For example, if the data only has observations at visits `VIS1`, `VIS3` and `VIS4`, by default+ #' |
||
| 216 | +85 |
- #' they are treated to be equally spaced, the distance from `VIS1` to `VIS3`, and from `VIS3` to `VIS4`,+ #' @param control (`mmrm_control`)\cr object. |
||
| 217 | +86 |
- #' are identical. However, you can manually convert this visit into a factor, with+ #' @param ... additional parameters to update the `control` object. |
||
| 218 | +87 |
- #' `levels = c("VIS1", "VIS2", "VIS3", "VIS4")`, and also use `drop_visits_levels = FALSE`,
+ #' |
||
| 219 | +88 |
- #' then the distance from `VIS1` to `VIS3` will be double, as `VIS2` is a valid visit.+ #' @return A `list` of `mmrm_control` entries. |
||
| 220 | +89 |
- #' However, please be cautious because this can lead to convergence failure+ #' @keywords internal |
||
| 221 | +90 |
- #' when using an unstructured covariance matrix and there are no observations+ h_split_control <- function(control, ...) {
|
||
| 222 | -+ | |||
| 91 | +8x |
- #' at the missing visits.+ assert_class(control, "mmrm_control") |
||
| 223 | -+ | |||
| 92 | +8x |
- #' - The `method` and `vcov` arguments specify the degrees of freedom and coefficients+ l <- length(control$optimizers) |
||
| 224 | -+ | |||
| 93 | +8x |
- #' covariance matrix adjustment methods, respectively.+ lapply(seq_len(l), function(i) {
|
||
| 225 | -+ | |||
| 94 | +22x |
- #' - Allowed `vcov` includes: "Asymptotic", "Kenward-Roger", "Kenward-Roger-Linear", "Empirical" (CR0),+ ret <- utils::modifyList(control, list(...)) |
||
| 226 | -+ | |||
| 95 | +22x |
- #' "Empirical-Jackknife" (CR3), and "Empirical-Bias-Reduced" (CR2).+ ret$optimizers <- control$optimizers[i] |
||
| 227 | -+ | |||
| 96 | +22x |
- #' - Allowed `method` includes: "Satterthwaite", "Kenward-Roger", "Between-Within" and "Residual".+ ret |
||
| 228 | +97 |
- #' - If `method` is "Kenward-Roger" then only "Kenward-Roger" or "Kenward-Roger-Linear" are allowed for `vcov`.+ }) |
||
| 229 | +98 |
- #' - The `vcov` argument can be `NULL` to use the default covariance method depending on the `method`- |
- ||
| 230 | -- |
- #' used for degrees of freedom, see the following table:+ } |
||
| 231 | +99 |
- #'+ |
||
| 232 | +100 |
- #' | `method` | Default `vcov`|+ #' Obtain Optimizer according to Optimizer String Value |
||
| 233 | +101 |
- #' |-----------|----------|+ #' |
||
| 234 | +102 |
- #' |Satterthwaite| Asymptotic|+ #' @description This function creates optimizer functions with arguments. |
||
| 235 | +103 |
- #' |Kenward-Roger| Kenward-Roger|+ #' |
||
| 236 | +104 |
- #' |Residual| Empirical|+ #' @param optimizer (`character`)\cr names of built-in optimizers to try, subset |
||
| 237 | +105 |
- #' |Between-Within| Asymptotic|+ #' of "L-BFGS-B", "BFGS", "CG" and "nlminb". |
||
| 238 | +106 |
- #'+ #' @param optimizer_fun (`function` or `list` of `function`)\cr alternatively to `optimizer`, |
||
| 239 | +107 |
- #' - Please note that "Kenward-Roger" for "Unstructured" covariance gives different results+ #' an optimizer function or a list of optimizer functions can be passed directly here. |
||
| 240 | +108 |
- #' compared to SAS; Use "Kenward-Roger-Linear" for `vcov` instead for better matching+ #' @param optimizer_args (`list`)\cr additional arguments for `optimizer_fun`. |
||
| 241 | +109 |
- #' of the SAS results.+ #' @param optimizer_control (`list`)\cr passed to argument `control` in `optimizer_fun`. |
||
| 242 | +110 |
#' |
||
| 243 | +111 |
- #' - The argument `start` is used to facilitate the choice of initial values for fitting the model.+ #' @details |
||
| 244 | +112 |
- #' If `function` is provided, make sure its parameter is a valid element of `mmrm_tmb_data`+ #' If you want to use only the built-in optimizers: |
||
| 245 | +113 |
- #' or `mmrm_tmb_formula_parts` and it returns a numeric vector.+ #' - `optimizer` is a shortcut to create a list of built-in optimizer functions |
||
| 246 | +114 |
- #' By default or if `NULL` is provided, `std_start` will be used.+ #' passed to `optimizer_fun`. |
||
| 247 | +115 |
- #' Other implemented methods include `emp_start`.+ #' - Allowed are "L-BFGS-B", "BFGS", "CG" (using [stats::optim()] with corresponding method) |
||
| 248 | +116 |
- #'+ #' and "nlminb" (using [stats::nlminb()]). |
||
| 249 | +117 |
- #' @return List of class `mmrm_control` with the control parameters.+ #' - Other arguments should go into `optimizer_args`. |
||
| 250 | +118 |
- #' @export+ #' |
||
| 251 | +119 |
- #'+ #' If you want to use your own optimizer function: |
||
| 252 | +120 |
- #' @examples+ #' - Make sure that there are three arguments: parameter (start value), objective function |
||
| 253 | +121 |
- #' mmrm_control(+ #' and gradient function are sequentially in the function arguments. |
||
| 254 | +122 |
- #' optimizer_fun = stats::optim,+ #' - If there are other named arguments in front of these, make sure they are correctly |
||
| 255 | +123 |
- #' optimizer_args = list(method = "L-BFGS-B")+ #' specified through `optimizer_args`. |
||
| 256 | +124 |
- #' )+ #' - If the hessian can be used, please make sure its argument name is `hessian` and |
||
| 257 | +125 |
- mmrm_control <- function(n_cores = 1L,+ #' please add attribute `use_hessian = TRUE` to the function, |
||
| 258 | +126 |
- method = c("Satterthwaite", "Kenward-Roger", "Residual", "Between-Within"),
+ #' using `attr(fun, "use_hessian) <- TRUE`. |
||
| 259 | +127 |
- vcov = NULL,+ #' |
||
| 260 | +128 |
- start = std_start,+ #' @return Named `list` of optimizers created by [h_partial_fun_args()]. |
||
| 261 | +129 |
- accept_singular = TRUE,+ #' |
||
| 262 | +130 |
- drop_visit_levels = TRUE,+ #' @keywords internal |
||
| 263 | +131 |
- ...,+ h_get_optimizers <- function(optimizer = c("L-BFGS-B", "BFGS", "CG", "nlminb"),
|
||
| 264 | +132 |
- optimizers = h_get_optimizers(...)) {
- |
- ||
| 265 | -242x | -
- assert_count(n_cores, positive = TRUE)- |
- ||
| 266 | -242x | -
- assert_character(method)- |
- ||
| 267 | -242x | -
- if (is.null(start)) {
- |
- ||
| 268 | -1x | -
- start <- std_start+ optimizer_fun = h_optimizer_fun(optimizer), |
||
| 269 | +133 |
- }- |
- ||
| 270 | -242x | -
- assert(- |
- ||
| 271 | -242x | -
- check_function(start, args = "..."),- |
- ||
| 272 | -242x | -
- check_numeric(start, null.ok = FALSE),- |
- ||
| 273 | -242x | -
- combine = "or"+ optimizer_args = list(), |
||
| 274 | +134 |
- )+ optimizer_control = list()) {
|
||
| 275 | -242x | +135 | +245x |
- assert_flag(accept_singular)+ if ("automatic" %in% optimizer) {
|
| 276 | -242x | +136 | +1x |
- assert_flag(drop_visit_levels)+ lifecycle::deprecate_warn( |
| 277 | -242x | +137 | +1x |
- assert_list(optimizers, names = "unique", types = c("function", "partial"))
+ when = "0.2.0", |
| 278 | -242x | +138 | +1x |
- assert_string(vcov, null.ok = TRUE)+ what = I("\"automatic\" optimizer"),
|
| 279 | -242x | +139 | +1x |
- method <- match.arg(method)+ details = "please just omit optimizer argument" |
| 280 | -242x | +|||
| 140 | +
- if (is.null(vcov)) {
+ ) |
|||
| 281 | -191x | +141 | +1x |
- vcov <- h_get_cov_default(method)+ optimizer_fun <- h_optimizer_fun() |
| 282 | +142 |
} |
||
| 283 | -242x | +143 | +245x |
- assert_subset(+ assert( |
| 284 | -242x | +144 | +245x |
- vcov,+ test_function(optimizer_fun), |
| 285 | -242x | +145 | +245x |
- c(+ test_list(optimizer_fun, types = "function", names = "unique") |
| 286 | -242x | +|||
| 146 | +
- "Asymptotic",+ ) |
|||
| 287 | -242x | +147 | +245x |
- "Empirical",+ if (is.function(optimizer_fun)) {
|
| 288 | -242x | +148 | +7x |
- "Empirical-Bias-Reduced",+ optimizer_fun <- list(custom_optimizer = optimizer_fun) |
| 289 | -242x | +|||
| 149 | +
- "Empirical-Jackknife",+ } |
|||
| 290 | -242x | +150 | +245x |
- "Kenward-Roger",+ lapply(optimizer_fun, function(x) {
|
| 291 | -242x | +151 | +920x |
- "Kenward-Roger-Linear"+ do.call(h_partial_fun_args, c(list(fun = x, control = optimizer_control), optimizer_args)) |
| 292 | +152 |
- )+ }) |
||
| 293 | +153 |
- )+ } |
||
| 294 | -242x | +|||
| 154 | +
- if (xor(identical(method, "Kenward-Roger"), vcov %in% c("Kenward-Roger", "Kenward-Roger-Linear"))) {
+
|
|||
| 295 | -5x | +|||
| 155 | +
- stop(paste(+ #' Obtain Optimizer Function with Character |
|||
| 296 | -5x | +|||
| 156 | +
- "Kenward-Roger degrees of freedom must work together with Kenward-Roger",+ #' @description Obtain the optimizer function through the character provided. |
|||
| 297 | -5x | +|||
| 157 | +
- "or Kenward-Roger-Linear covariance!"+ #' @param optimizer (`character`)\cr vector of optimizers. |
|||
| 298 | +158 |
- ))+ #' |
||
| 299 | +159 |
- }+ #' @return A (`list`)\cr of optimizer functions generated from [h_partial_fun_args()]. |
||
| 300 | -237x | +|||
| 160 | +
- structure(+ #' @keywords internal |
|||
| 301 | -237x | +|||
| 161 | +
- list(+ h_optimizer_fun <- function(optimizer = c("L-BFGS-B", "BFGS", "CG", "nlminb")) {
|
|||
| 302 | -237x | +162 | +239x |
- optimizers = optimizers,+ optimizer <- match.arg(optimizer, several.ok = TRUE) |
| 303 | -237x | +163 | +239x |
- start = start,+ lapply(stats::setNames(optimizer, optimizer), function(x) {
|
| 304 | -237x | +164 | +916x |
- accept_singular = accept_singular,+ switch(x, |
| 305 | -237x | +165 | +228x |
- method = method,+ "L-BFGS-B" = h_partial_fun_args(fun = stats::optim, method = x), |
| 306 | -237x | +166 | +229x |
- vcov = vcov,+ "BFGS" = h_partial_fun_args(fun = stats::optim, method = x), |
| 307 | -237x | +167 | +227x |
- n_cores = as.integer(n_cores),+ "CG" = h_partial_fun_args(fun = stats::optim, method = x), |
| 308 | -237x | +168 | +232x |
- drop_visit_levels = drop_visit_levels+ "nlminb" = h_partial_fun_args(fun = stats::nlminb, additional_attr = list(use_hessian = TRUE)) |
| 309 | +169 |
- ),- |
- ||
| 310 | -237x | -
- class = "mmrm_control"+ ) |
||
| 311 | +170 |
- )+ }) |
||
| 312 | +171 |
} |
||
| 313 | +172 | |||
| 314 | -- |
- #' Fit an MMRM- |
- ||
| 315 | +173 |
- #'+ #' Create Partial Functions |
||
| 316 | +174 |
- #' @description `r lifecycle::badge("experimental")`
+ #' @description Creates partial functions with arguments. |
||
| 317 | +175 |
#' |
||
| 318 | +176 |
- #' This is the main function fitting the MMRM.+ #' @param fun (`function`)\cr to be wrapped. |
||
| 319 | +177 |
- #'+ #' @param ... Additional arguments for `fun`. |
||
| 320 | +178 |
- #' @param formula (`formula`)\cr the model formula, see details.+ #' @param additional_attr (`list`)\cr of additional attributes to apply to the result. |
||
| 321 | +179 |
- #' @param data (`data`)\cr the data to be used for the model.+ #' |
||
| 322 | +180 |
- #' @param weights (`vector`)\cr an optional vector of weights to be used in+ #' @details This function add `args` attribute to the original function, |
||
| 323 | +181 |
- #' the fitting process. Should be `NULL` or a numeric vector.+ #' and add an extra class `partial` to the function. |
||
| 324 | +182 |
- #' @param reml (`flag`)\cr whether restricted maximum likelihood (REML)+ #' `args` is the argument for the function, and elements in `...` will override the existing |
||
| 325 | +183 |
- #' estimation is used, otherwise maximum likelihood (ML) is used.+ #' arguments in attribute `args`. `additional_attr` will override the existing attributes. |
||
| 326 | +184 |
- #' @param covariance (`cov_struct`)\cr a covariance structure type definition+ #' |
||
| 327 | +185 |
- #' as produced with [cov_struct()], or value that can be coerced to a+ #' @return Object with S3 class `"partial"`, a `function` with `args` attribute (and possibly more |
||
| 328 | +186 |
- #' covariance structure using [as.cov_struct()]. If no value is provided,+ #' attributes from `additional_attr`). |
||
| 329 | +187 |
- #' a structure is derived from the provided formula.+ #' @keywords internal |
||
| 330 | +188 |
- #' @param control (`mmrm_control`)\cr fine-grained fitting specifications list+ h_partial_fun_args <- function(fun, ..., additional_attr = list()) {
|
||
| 331 | -+ | |||
| 189 | +1840x |
- #' created with [mmrm_control()].+ assert_function(fun) |
||
| 332 | -+ | |||
| 190 | +1840x |
- #' @param ... arguments passed to [mmrm_control()].+ assert_list(additional_attr, names = "unique") |
||
| 333 | -+ | |||
| 191 | +1840x |
- #'+ a_args <- list(...) |
||
| 334 | -+ | |||
| 192 | +1840x |
- #' @details+ assert_list(a_args, names = "unique") |
||
| 335 | -+ | |||
| 193 | +1840x |
- #' The `formula` typically looks like:+ args <- attr(fun, "args") |
||
| 336 | -+ | |||
| 194 | +1840x |
- #' `FEV1 ~ RACE + SEX + ARMCD * AVISIT + us(AVISIT | USUBJID)`+ if (is.null(args)) {
|
||
| 337 | -+ | |||
| 195 | +928x |
- #' so specifies response and covariates as usual, and exactly one special term+ args <- list() |
||
| 338 | +196 |
- #' defines which covariance structure is used and what are the time point and+ } |
||
| 339 | -+ | |||
| 197 | +1840x |
- #' subject variables. The covariance structures in the formula can be+ do.call( |
||
| 340 | -+ | |||
| 198 | +1840x |
- #' found in [`covariance_types`].+ structure, |
||
| 341 | -+ | |||
| 199 | +1840x |
- #'+ args = utils::modifyList( |
||
| 342 | -+ | |||
| 200 | +1840x |
- #' The time points have to be unique for each subject. That is,+ list( |
||
| 343 | -+ | |||
| 201 | +1840x |
- #' there cannot be time points with multiple observations for any subject.+ .Data = fun, |
||
| 344 | -+ | |||
| 202 | +1840x |
- #' The rationale is that these observations would need to be correlated, but it+ args = utils::modifyList(args, a_args), |
||
| 345 | -+ | |||
| 203 | +1840x |
- #' is not possible within the currently implemented covariance structure framework+ class = c("partial", "function")
|
||
| 346 | +204 |
- #' to do that correctly. Moreover, for non-spatial covariance structures, the time+ ), |
||
| 347 | -+ | |||
| 205 | +1840x |
- #' variable must be a factor variable.+ additional_attr |
||
| 348 | +206 |
- #'+ ) |
||
| 349 | +207 |
- #' When optimizer is not set, first the default optimizer+ ) |
||
| 350 | +208 |
- #' (`L-BFGS-B`) is used to fit the model. If that converges, this is returned.+ } |
||
| 351 | +209 |
- #' If not, the other available optimizers from [h_get_optimizers()],+ |
||
| 352 | +210 |
- #' including `BFGS`, `CG` and `nlminb` are+ #' Obtain Default Covariance Method |
||
| 353 | +211 |
- #' tried (in parallel if `n_cores` is set and not on Windows).+ #' |
||
| 354 | +212 |
- #' If none of the optimizers converge, then the function fails. Otherwise+ #' @description Obtain the default covariance method depending on |
||
| 355 | +213 |
- #' the best fit is returned.+ #' the degrees of freedom method used. |
||
| 356 | +214 |
#' |
||
| 357 | +215 |
- #' Note that fine-grained control specifications can either be passed directly+ #' @param method (`string`)\cr degrees of freedom method. |
||
| 358 | +216 |
- #' to the `mmrm` function, or via the `control` argument for bundling together+ #' |
||
| 359 | +217 |
- #' with the [mmrm_control()] function. Both cannot be used together, since+ #' @details The default covariance method is different for different degrees of freedom method. |
||
| 360 | +218 |
- #' this would delete the arguments passed via `mmrm`.+ #' For "Satterthwaite" or "Between-Within", "Asymptotic" is returned. |
||
| 361 | +219 |
- #'+ #' For "Kenward-Roger" only, "Kenward-Roger" is returned. |
||
| 362 | +220 |
- #' @return An `mmrm` object.+ #' For "Residual" only, "Empirical" is returned. |
||
| 363 | +221 |
#' |
||
| 364 | +222 |
- #' @note The `mmrm` object is also an `mmrm_fit` and an `mmrm_tmb` object,+ #' @return String of the default covariance method. |
||
| 365 | +223 |
- #' therefore corresponding methods also work (see [`mmrm_tmb_methods`]).+ #' @keywords internal |
||
| 366 | +224 |
- #'+ h_get_cov_default <- function(method = c("Satterthwaite", "Kenward-Roger", "Residual", "Between-Within")) {
|
||
| 367 | -+ | |||
| 225 | +196x |
- #' Additional contents depend on the choice of the adjustment `method`:+ assert_string(method) |
||
| 368 | -+ | |||
| 226 | +196x |
- #' - If Satterthwaite adjustment is used, the Jacobian information `jac_list`+ method <- match.arg(method) |
||
| 369 | -+ | |||
| 227 | +195x |
- #' is included.+ switch(method, |
||
| 370 | -+ | |||
| 228 | +1x |
- #' - If Kenward-Roger adjustment is used, `kr_comp` contains necessary+ "Residual" = "Empirical", |
||
| 371 | -+ | |||
| 229 | +157x |
- #' components and `beta_vcov_adj` includes the adjusted coefficients covariance+ "Satterthwaite" = "Asymptotic", |
||
| 372 | -+ | |||
| 230 | +35x |
- #' matrix.+ "Kenward-Roger" = "Kenward-Roger",+ |
+ ||
| 231 | +2x | +
+ "Between-Within" = "Asymptotic" |
||
| 373 | +232 |
- #'+ ) |
||
| 374 | +233 |
- #' Use of the package `emmeans` is supported, see [`emmeans_support`].+ } |
||
| 375 | +234 |
- #'+ |
||
| 376 | +235 |
- #' NA values are always omitted regardless of `na.action` setting.+ #' Complete `character` Vector Names From Values |
||
| 377 | +236 |
#' |
||
| 378 | +237 |
- #' When the number of visit levels is large, it usually requires large memory to create the+ #' @param x (`character` or `list`)\cr value whose names should be completed |
||
| 379 | +238 |
- #' covariance matrix. By default, the maximum allowed visit levels is 100, and if there are more+ #' from element values. |
||
| 380 | +239 |
- #' visit levels, a confirmation is needed if run interactively.+ #' |
||
| 381 | +240 |
- #' You can use `options(mmrm.max_visits = <target>)` to increase the maximum allowed number of visit+ #' @return A named vector or list. |
||
| 382 | +241 |
- #' levels. In non-interactive sessions the confirmation is not raised and will directly give you an error if+ #' |
||
| 383 | +242 |
- #' the number of visit levels exceeds the maximum.+ #' @keywords internal |
||
| 384 | +243 |
- #'+ fill_names <- function(x) {
|
||
| 385 | -+ | |||
| 244 | +4x |
- #' @export+ n <- names(x) |
||
| 386 | -+ | |||
| 245 | +4x |
- #'+ is_unnamed <- if (is.null(n)) rep_len(TRUE, length(x)) else n == "" |
||
| 387 | -+ | |||
| 246 | +4x |
- #' @examples+ names(x)[is_unnamed] <- x[is_unnamed] |
||
| 388 | -+ | |||
| 247 | +4x |
- #' fit <- mmrm(+ x |
||
| 389 | +248 |
- #' formula = FEV1 ~ RACE + SEX + ARMCD * AVISIT + us(AVISIT | USUBJID),+ } |
||
| 390 | +249 |
- #' data = fev_data+ |
||
| 391 | +250 |
- #' )+ #' Drop Items from an Indexible |
||
| 392 | +251 |
#' |
||
| 393 | +252 |
- #' # Direct specification of control details:+ #' Drop elements from an indexible object (`vector`, `list`, etc.). |
||
| 394 | +253 |
- #' fit <- mmrm(+ #' |
||
| 395 | +254 |
- #' formula = FEV1 ~ RACE + SEX + ARMCD * AVISIT + us(AVISIT | USUBJID),+ #' @param x Any object that can be consumed by [seq_along()] and indexed by a |
||
| 396 | +255 |
- #' data = fev_data,+ #' logical vector of the same length. |
||
| 397 | +256 |
- #' weights = fev_data$WEIGHTS,+ #' @param n (`integer`)\cr the number of terms to drop. |
||
| 398 | +257 |
- #' method = "Kenward-Roger"+ #' |
||
| 399 | +258 |
- #' )+ #' @return A subset of `x`. |
||
| 400 | +259 |
#' |
||
| 401 | +260 |
- #' # Alternative specification via control argument (but you cannot mix the+ #' @keywords internal |
||
| 402 | +261 |
- #' # two approaches):+ drop_elements <- function(x, n) {
+ |
+ ||
| 262 | +816x | +
+ x[seq_along(x) > n] |
||
| 403 | +263 |
- #' fit <- mmrm(+ } |
||
| 404 | +264 |
- #' formula = FEV1 ~ RACE + SEX + ARMCD * AVISIT + us(AVISIT | USUBJID),+ |
||
| 405 | +265 |
- #' data = fev_data,+ #' Ask for Confirmation on Large Visit Levels |
||
| 406 | +266 |
- #' control = mmrm_control(method = "Kenward-Roger")+ #' |
||
| 407 | +267 |
- #' )+ #' @description Ask the user for confirmation if there are too many visit levels |
||
| 408 | +268 |
- mmrm <- function(formula,+ #' for non-spatial covariance structure in interactive sessions. |
||
| 409 | +269 |
- data,+ #' |
||
| 410 | +270 |
- weights = NULL,+ #' @param x (`numeric`)\cr number of visit levels. |
||
| 411 | +271 |
- covariance = NULL,+ #' |
||
| 412 | +272 |
- reml = TRUE,+ #' @return Logical value `TRUE`. |
||
| 413 | +273 |
- control = mmrm_control(...),+ #' @keywords internal |
||
| 414 | +274 |
- ...) {
+ h_confirm_large_levels <- function(x) {
|
||
| 415 | -174x | +275 | +296x |
- assert_false(!missing(control) && !missing(...))+ assert_count(x) |
| 416 | -173x | +276 | +296x |
- assert_class(control, "mmrm_control")+ allowed_lvls <- x <= getOption("mmrm.max_visits", 100)
|
| 417 | -168x | +277 | +296x |
- assert_list(control$optimizers, min.len = 1)+ if (allowed_lvls) {
+ |
+
| 278 | +294x | +
+ return(TRUE) |
||
| 418 | +279 |
-
+ } |
||
| 419 | -168x | +280 | +2x |
- if (control$method %in% c("Kenward-Roger", "Kenward-Roger-Linear") && !reml) {
+ if (!interactive()) {
|
| 420 | -! | +|||
| 281 | +2x |
- stop("Kenward-Roger only works for REML")
+ stop("Visit levels too large!", call. = FALSE)
|
||
| 421 | +282 |
} |
||
| 422 | -168x | +|||
| 283 | +! |
- h_valid_formula(formula)+ proceed <- utils::askYesNo( |
||
| 423 | -167x | +|||
| 284 | +! |
- covariance <- h_reconcile_cov_struct(formula, covariance)+ paste( |
||
| 424 | -166x | +|||
| 285 | +! |
- formula_parts <- h_mmrm_tmb_formula_parts(formula, covariance)+ "Visit levels is possibly too large.", |
||
| 425 | -+ | |||
| 286 | +! |
-
+ "This requires large memory. Are you sure to continue?", |
||
| 426 | -166x | +|||
| 287 | +! |
- if (!missing(data)) {
+ collapse = " " |
||
| 427 | -165x | +|||
| 288 | +
- attr(data, which = "dataname") <- toString(match.call()$data)+ ) |
|||
| 428 | +289 |
- } else {
+ ) |
||
| 429 | -+ | |||
| 290 | +! |
- # na.action set to na.pass to allow data to be full; will be futher trimmed later+ if (!identical(proceed, TRUE)) {
|
||
| 430 | -1x | +|||
| 291 | +! |
- data <- model.frame(formula_parts$full_formula, na.action = "na.pass")+ stop("Visit levels too large!", call. = FALSE)
|
||
| 431 | +292 |
} |
||
| 293 | +! | +
+ return(TRUE)+ |
+ ||
| 432 | +294 |
-
+ } |
||
| 433 | -166x | +|||
| 295 | +
- if (is.null(weights)) {
+
|
|||
| 434 | -150x | +|||
| 296 | +
- weights <- rep(1, nrow(data))+ #' Default Value on NULL |
|||
| 435 | +297 |
- } else {
+ #' Return default value when first argument is NULL. |
||
| 436 | -16x | +|||
| 298 | +
- attr(weights, which = "dataname") <- deparse(match.call()$weights)+ #' |
|||
| 437 | +299 |
- }+ #' @param x Object. |
||
| 438 | -166x | +|||
| 300 | +
- tmb_data <- h_mmrm_tmb_data(+ #' @param y Object. |
|||
| 439 | -166x | +|||
| 301 | +
- formula_parts, data, weights, reml,+ #' |
|||
| 440 | -166x | +|||
| 302 | +
- singular = if (control$accept_singular) "drop" else "error",+ #' @details If `x` is NULL, returns `y`. Otherwise return `x`. |
|||
| 441 | -166x | +|||
| 303 | +
- drop_visit_levels = control$drop_visit_levels,+ #' |
|||
| 442 | -166x | +|||
| 304 | +
- allow_na_response = FALSE+ #' @keywords internal |
|||
| 443 | +305 |
- )+ h_default_value <- function(x, y) {
|
||
| 444 | -166x | +306 | +311x |
- fit <- structure("", class = "try-error")
+ if (is.null(x)) {
|
| 445 | -166x | +307 | +276x |
- names_all_optimizers <- names(control$optimizers)+ y |
| 446 | -166x | +|||
| 308 | +
- while (is(fit, "try-error") && length(control$optimizers) > 0) {
+ } else {
|
|||
| 447 | -170x | +309 | +35x |
- fit <- fit_single_optimizer(+ x |
| 448 | -170x | +|||
| 310 | +
- tmb_data = tmb_data,+ } |
|||
| 449 | -170x | +|||
| 311 | +
- formula_parts = formula_parts,+ } |
|||
| 450 | -170x | +|||
| 312 | +
- control = control+ |
|||
| 451 | +313 |
- )+ #' Warn on na.action |
||
| 452 | -167x | +|||
| 314 | +
- if (is(fit, "try-error")) {
+ #' @keywords internal |
|||
| 453 | -6x | +|||
| 315 | +
- warning(paste0(+ h_warn_na_action <- function() {
|
|||
| 454 | -6x | +316 | +259x |
- "Divergence with optimizer ", names(control$optimizers[1L]), " due to problems: ",+ if (!identical(getOption("na.action"), "na.omit")) {
|
| 455 | +317 | 6x |
- toString(attr(fit, "divergence"))+ warning("na.action is always set to `na.omit` for `mmrm` fit!")
|
|
| 456 | +318 |
- ))+ } |
||
| 457 | +319 |
- }+ } |
||
| 458 | -167x | +|||
| 320 | +
- control$optimizers <- control$optimizers[-1]+ |
|||
| 459 | +321 |
- }+ #' Obtain `na.action` as Function |
||
| 460 | -163x | +|||
| 322 | +
- if (!attr(fit, "converged")) {
+ #' @keywords internal |
|||
| 461 | -7x | +|||
| 323 | +
- more_optimizers <- length(control$optimizers) >= 1L+ h_get_na_action <- function(na_action) {
|
|||
| 462 | -7x | +324 | +56x |
- if (more_optimizers) {
+ if (is.function(na_action) && identical(methods::formalArgs(na_action), c("object", "..."))) {
|
| 463 | +325 | 5x |
- fit <- refit_multiple_optimizers(+ return(na_action) |
|
| 464 | -5x | +|||
| 326 | +
- fit = fit,+ } |
|||
| 465 | -5x | +327 | +51x |
- control = control+ if (is.character(na_action) && length(na_action) == 1L) {
|
| 466 | -+ | |||
| 328 | +51x |
- )+ assert_subset(na_action, c("na.omit", "na.exclude", "na.fail", "na.pass", "na.contiguous"))
|
||
| 467 | -+ | |||
| 329 | +51x |
- } else {
+ return(get(na_action, mode = "function", pos = "package:stats")) |
||
| 468 | -2x | +|||
| 330 | +
- all_problems <- unlist(+ } |
|||
| 469 | -2x | +|||
| 331 | +
- attributes(fit)[c("errors", "warnings")],
+ } |
|||
| 470 | -2x | +|||
| 332 | +
- use.names = FALSE+ |
|||
| 471 | +333 |
- )+ #' Validate mmrm Formula |
||
| 472 | -2x | +|||
| 334 | +
- stop(paste0(+ #' @param formula (`formula`)\cr to check. |
|||
| 473 | -2x | +|||
| 335 | +
- "Chosen optimizers '", toString(names_all_optimizers), "' led to problems during model fit:\n",+ #' |
|||
| 474 | -2x | +|||
| 336 | +
- paste(paste0(seq_along(all_problems), ") ", all_problems), collapse = ";\n"), "\n",+ #' @details In mmrm models, `.` is not allowed as it introduces ambiguity of covariates |
|||
| 475 | -2x | +|||
| 337 | +
- "Consider trying multiple or different optimizers."+ #' to be used, so it is not allowed to be in formula. |
|||
| 476 | +338 |
- ))+ #' |
||
| 477 | +339 |
- }+ #' @keywords internal |
||
| 478 | +340 |
- }+ h_valid_formula <- function(formula) {
|
||
| 479 | -160x | +341 | +182x |
- fit_msg <- attr(fit, "messages")+ assert_formula(formula) |
| 480 | -160x | +342 | +182x |
- if (!is.null(fit_msg)) {
+ if ("." %in% all.vars(formula)) {
|
| 481 | -! | +|||
| 343 | +2x |
- message(paste(fit_msg, collapse = "\n"))+ stop("`.` is not allowed in mmrm models!")
|
||
| 482 | +344 |
} |
||
| 483 | -160x | +|||
| 345 | +
- fit$call <- match.call()+ } |
|||
| 484 | -160x | +|||
| 346 | +
- fit$call$formula <- formula+ |
|||
| 485 | -160x | +|||
| 347 | +
- fit$method <- control$method+ #' Standard Starting Value |
|||
| 486 | -160x | +|||
| 348 | +
- fit$vcov <- control$vcov+ #' |
|||
| 487 | -160x | +|||
| 349 | +
- if (control$vcov %in% c("Kenward-Roger", "Kenward-Roger-Linear")) {
+ #' @description Obtain standard start values. |
|||
| 488 | -47x | +|||
| 350 | +
- fit$kr_comp <- h_get_kr_comp(fit$tmb_data, fit$theta_est)+ #' |
|||
| 489 | -47x | +|||
| 351 | +
- fit$beta_vcov_adj <- h_var_adj(+ #' @param cov_type (`string`)\cr name of the covariance structure. |
|||
| 490 | -47x | +|||
| 352 | +
- v = fit$beta_vcov,+ #' @param n_visits (`int`)\cr number of visits. |
|||
| 491 | -47x | +|||
| 353 | +
- w = component(fit, "theta_vcov"),+ #' @param n_groups (`int`)\cr number of groups. |
|||
| 492 | -47x | +|||
| 354 | +
- p = fit$kr_comp$P,+ #' @param ... not used. |
|||
| 493 | -47x | +|||
| 355 | +
- q = fit$kr_comp$Q,+ #' |
|||
| 494 | -47x | +|||
| 356 | +
- r = fit$kr_comp$R,+ #' @details |
|||
| 495 | -47x | +|||
| 357 | +
- linear = (control$vcov == "Kenward-Roger-Linear")+ #' `std_start` will try to provide variance parameter from identity matrix. |
|||
| 496 | +358 |
- )+ #' However, for `ar1` and `ar1h` the corresponding values are not ideal because the |
||
| 497 | -113x | +|||
| 359 | +
- } else if (control$vcov %in% c("Empirical", "Empirical-Bias-Reduced", "Empirical-Jackknife")) {
+ #' \eqn{\rho} is usually a positive number thus using 0 as starting value can lead to
|
|||
| 498 | -31x | +|||
| 360 | +
- empirical_comp <- h_get_empirical(+ #' incorrect optimization result, and we use 0.5 as the initial value of \eqn{\rho}.
|
|||
| 499 | -31x | +|||
| 361 | +
- fit$tmb_data, fit$theta_est, fit$beta_est, fit$beta_vcov, control$vcov+ #' |
|||
| 500 | +362 |
- )+ #' @return A numeric vector of starting values. |
||
| 501 | -31x | +|||
| 363 | +
- fit$beta_vcov_adj <- empirical_comp$cov+ #' |
|||
| 502 | -31x | +|||
| 364 | +
- fit$empirical_df_mat <- empirical_comp$df_mat+ #' @export+ |
+ |||
| 365 | ++ |
+ std_start <- function(cov_type, n_visits, n_groups, ...) {
|
||
| 503 | -31x | +366 | +500x |
- dimnames(fit$beta_vcov_adj) <- dimnames(fit$beta_vcov)+ assert_string(cov_type) |
| 504 | -82x | +367 | +500x |
- } else if (identical(control$vcov, "Asymptotic")) {
+ assert_subset(cov_type, cov_types(c("abbr", "habbr")))
|
| 505 | -+ | |||
| 368 | +500x |
- # Note that we only need the Jacobian list under Asymptotic covariance method,+ assert_int(n_visits, lower = 1L) |
||
| 506 | -+ | |||
| 369 | +500x |
- # cf. the Satterthwaite vignette.+ assert_int(n_groups, lower = 1L) |
||
| 507 | -82x | +370 | +500x |
- if (identical(fit$method, "Satterthwaite")) {
+ start_value <- switch(cov_type, |
| 508 | -80x | +371 | +500x |
- fit$jac_list <- h_jac_list(fit$tmb_data, fit$theta_est, fit$beta_vcov)+ us = rep(0, n_visits * (n_visits + 1) / 2), |
| 509 | -+ | |||
| 372 | +500x |
- }+ toep = rep(0, n_visits),+ |
+ ||
| 373 | +500x | +
+ toeph = rep(0, 2 * n_visits - 1),+ |
+ ||
| 374 | +500x | +
+ ar1 = c(0, 0.5),+ |
+ ||
| 375 | +500x | +
+ ar1h = c(rep(0, n_visits), 0.5),+ |
+ ||
| 376 | +500x | +
+ ad = rep(0, n_visits),+ |
+ ||
| 377 | +500x | +
+ adh = rep(0, 2 * n_visits - 1),+ |
+ ||
| 378 | +500x | +
+ cs = rep(0, 2),+ |
+ ||
| 379 | +500x | +
+ csh = rep(0, n_visits + 1),+ |
+ ||
| 380 | +500x | +
+ sp_exp = rep(0, 2) |
||
| 510 | +381 |
- } else {
+ ) |
||
| 511 | -! | +|||
| 382 | +500x |
- stop("Unrecognized coefficent variance-covariance method!")
+ rep(start_value, n_groups) |
||
| 512 | +383 |
- }+ } |
||
| 513 | +384 | |||
| 514 | -160x | +|||
| 385 | +
- class(fit) <- c("mmrm", class(fit))
+ #' Empirical Starting Value |
|||
| 515 | -160x | +|||
| 386 | +
- fit+ #' |
|||
| 516 | +387 |
- }+ #' @description Obtain empirical start value for unstructured covariance |
| 1 | +388 |
- #' Calculation of Degrees of Freedom for One-Dimensional Contrast+ #' |
||
| 2 | +389 |
- #'+ #' @param data (`data.frame`)\cr data used for model fitting. |
||
| 3 | +390 |
- #' @description `r lifecycle::badge("experimental")`
+ #' @param model_formula (`formula`)\cr the formula in mmrm model without covariance structure part. |
||
| 4 | +391 |
- #' Calculates the estimate, adjusted standard error, degrees of freedom,+ #' @param visit_var (`string`)\cr visit variable. |
||
| 5 | +392 |
- #' t statistic and p-value for one-dimensional contrast.+ #' @param subject_var (`string`)\cr subject id variable. |
||
| 6 | +393 |
- #'+ #' @param subject_groups (`factor`)\cr subject group assignment. |
||
| 7 | +394 |
- #' @param object (`mmrm`)\cr the MMRM fit.+ #' @param ... not used. |
||
| 8 | +395 |
- #' @param contrast (`numeric`)\cr contrast vector. Note that this should not include+ #' |
||
| 9 | +396 |
- #' elements for singular coefficient estimates, i.e. only refer to the+ #' @details |
||
| 10 | +397 |
- #' actually estimated coefficients.+ #' This `emp_start` only works for unstructured covariance structure. |
||
| 11 | +398 |
- #' @return List with `est`, `se`, `df`, `t_stat` and `p_val`.+ #' It uses linear regression to first obtain the coefficients and use the residuals |
||
| 12 | +399 |
- #' @export+ #' to obtain the empirical variance-covariance, and it is then used to obtain the |
||
| 13 | +400 |
- #'+ #' starting values. |
||
| 14 | +401 |
- #' @examples+ #' |
||
| 15 | +402 |
- #' object <- mmrm(+ #' @note `data` is used instead of `full_frame` because `full_frame` is already |
||
| 16 | +403 |
- #' formula = FEV1 ~ RACE + SEX + ARMCD * AVISIT + us(AVISIT | USUBJID),+ #' transformed if model contains transformations, e.g. `log(FEV1) ~ exp(FEV1_BL)` will |
||
| 17 | +404 |
- #' data = fev_data+ #' drop `FEV1` and `FEV1_BL` but add `log(FEV1)` and `exp(FEV1_BL)` in `full_frame`. |
||
| 18 | +405 |
- #' )+ #' |
||
| 19 | +406 |
- #' contrast <- numeric(length(object$beta_est))+ #' @return A numeric vector of starting values. |
||
| 20 | +407 |
- #' contrast[3] <- 1+ #' |
||
| 21 | +408 |
- #' df_1d(object, contrast)+ #' @export |
||
| 22 | +409 |
- df_1d <- function(object, contrast) {
+ emp_start <- function(data, model_formula, visit_var, subject_var, subject_groups, ...) {
|
||
| 23 | -338x | +410 | +4x |
- assert_class(object, "mmrm")+ assert_formula(model_formula) |
| 24 | -338x | +411 | +4x |
- assert_numeric(contrast, len = length(component(object, "beta_est")), any.missing = FALSE)+ assert_data_frame(data) |
| 25 | -338x | +412 | +4x |
- contrast <- as.vector(contrast)+ assert_subset(all.vars(model_formula), colnames(data)) |
| 26 | -338x | +413 | +4x |
- switch(object$method,+ assert_string(visit_var) |
| 27 | -318x | +414 | +4x |
- "Satterthwaite" = h_df_1d_sat(object, contrast),+ assert_string(subject_var) |
| 28 | -19x | +415 | +4x |
- "Kenward-Roger" = h_df_1d_kr(object, contrast),+ assert_factor(data[[visit_var]]) |
| 29 | -! | +|||
| 416 | +4x |
- "Residual" = h_df_1d_res(object, contrast),+ n_visits <- length(levels(data[[visit_var]])) |
||
| 30 | -1x | +417 | +4x |
- "Between-Within" = h_df_1d_bw(object, contrast),+ assert_factor(data[[subject_var]]) |
| 31 | -! | +|||
| 418 | +4x |
- stop("Unrecognized degrees of freedom method: ", object$method)
+ subjects <- droplevels(data[[subject_var]]) |
||
| 32 | -+ | |||
| 419 | +4x |
- )+ n_subjects <- length(levels(subjects)) |
||
| 33 | -+ | |||
| 420 | +4x |
- }+ fit <- stats::lm(formula = model_formula, data = data) |
||
| 34 | -+ | |||
| 421 | +4x |
-
+ res <- rep(NA, n_subjects * n_visits) |
||
| 35 | -+ | |||
| 422 | +4x |
-
+ res[ |
||
| 36 | -+ | |||
| 423 | +4x |
- #' Calculation of Degrees of Freedom for Multi-Dimensional Contrast+ n_visits * as.integer(subjects) - n_visits + as.integer(data[[visit_var]]) |
||
| 37 | -+ | |||
| 424 | +4x |
- #'+ ] <- residuals(fit) |
||
| 38 | -+ | |||
| 425 | +4x |
- #' @description `r lifecycle::badge("experimental")`
+ res_mat <- matrix(res, ncol = n_visits, nrow = n_subjects, byrow = TRUE) |
||
| 39 | -+ | |||
| 426 | +4x |
- #' Calculates the estimate, standard error, degrees of freedom,+ emp_covs <- lapply( |
||
| 40 | -+ | |||
| 427 | +4x |
- #' t statistic and p-value for one-dimensional contrast, depending on the method+ unname(split(seq_len(n_subjects), subject_groups)), |
||
| 41 | -+ | |||
| 428 | +4x |
- #' used in [mmrm()].+ function(x) {
|
||
| 42 | -+ | |||
| 429 | +4x |
- #'+ stats::cov(res_mat[x, , drop = FALSE], use = "pairwise.complete.obs") |
||
| 43 | +430 |
- #' @param object (`mmrm`)\cr the MMRM fit.+ } |
||
| 44 | +431 |
- #' @param contrast (`matrix`)\cr numeric contrast matrix, if given a `numeric`+ ) |
||
| 45 | -+ | |||
| 432 | +4x |
- #' then this is coerced to a row vector. Note that this should not include+ unlist(lapply(emp_covs, h_get_theta_from_cov)) |
||
| 46 | +433 |
- #' elements for singular coefficient estimates, i.e. only refer to the+ } |
||
| 47 | +434 |
- #' actually estimated coefficients.+ #' Obtain Theta from Covariance Matrix |
||
| 48 | +435 |
#' |
||
| 49 | -- |
- #' @return List with `num_df`, `denom_df`, `f_stat` and `p_val` (2-sided p-value).- |
- ||
| 50 | +436 |
- #' @export+ #' @description Obtain unstructured theta from covariance matrix. |
||
| 51 | +437 |
#' |
||
| 52 | +438 |
- #' @examples+ #' @param covariance (`matrix`) of covariance matrix values. |
||
| 53 | +439 |
- #' object <- mmrm(+ #' |
||
| 54 | +440 |
- #' formula = FEV1 ~ RACE + SEX + ARMCD * AVISIT + us(AVISIT | USUBJID),+ #' @details |
||
| 55 | +441 |
- #' data = fev_data+ #' If the covariance matrix has `NA` in some of the elements, they will be replaced by |
||
| 56 | +442 |
- #' )+ #' 0 (non-diagonal) and 1 (diagonal). This ensures that the matrix is positive definite. |
||
| 57 | +443 |
- #' contrast <- matrix(data = 0, nrow = 2, ncol = length(object$beta_est))+ #' |
||
| 58 | +444 |
- #' contrast[1, 2] <- contrast[2, 3] <- 1+ #' @return Numeric vector of the theta values. |
||
| 59 | +445 |
- #' df_md(object, contrast)+ #' @keywords internal |
||
| 60 | +446 |
- df_md <- function(object, contrast) {
- |
- ||
| 61 | -150x | -
- assert_class(object, "mmrm")+ h_get_theta_from_cov <- function(covariance) {
|
||
| 62 | -150x | +447 | +7x |
- assert_numeric(contrast, any.missing = FALSE)+ assert_matrix(covariance, mode = "numeric", ncols = nrow(covariance)) |
| 63 | -150x | +448 | +7x |
- if (!is.matrix(contrast)) {
+ covariance[is.na(covariance)] <- 0 |
| 64 | -113x | +449 | +7x |
- contrast <- matrix(contrast, ncol = length(contrast))+ diag(covariance)[diag(covariance) == 0] <- 1 |
| 65 | +450 |
- }+ # empirical is not always positive definite in some special cases of numeric singularity. |
||
| 66 | -150x | +451 | +7x |
- assert_matrix(contrast, ncols = length(component(object, "beta_est")))+ qr_res <- qr(covariance) |
| 67 | -150x | +452 | +7x |
- if (nrow(contrast) == 0) {
+ if (qr_res$rank < ncol(covariance)) {
|
| 68 | -1x | -
- return(- |
- ||
| 69 | -1x | -
- list(- |
- ||
| 70 | -1x | -
- num_df = 0,- |
- ||
| 71 | -1x | -
- denom_df = NA_real_,- |
- ||
| 72 | -1x | -
- f_stat = NA_real_,- |
- ||
| 73 | -1x | -
- p_val = NA_real_- |
- ||
| 74 | -- |
- )- |
- ||
| 75 | -+ | |||
| 453 | +! |
- )+ covariance <- Matrix::nearPD(covariance)$mat |
||
| 76 | +454 |
} |
||
| 77 | -149x | +455 | +7x |
- switch(object$method,+ emp_chol <- t(chol(covariance)) |
| 78 | -145x | +456 | +7x |
- "Satterthwaite" = h_df_md_sat(object, contrast),+ mat <- t(solve(diag(diag(emp_chol)), emp_chol)) |
| 79 | -3x | -
- "Kenward-Roger" = h_df_md_kr(object, contrast),- |
- ||
| 80 | -! | +457 | +7x |
- "Residual" = h_df_md_res(object, contrast),+ ret <- c(log(diag(emp_chol)), mat[upper.tri(mat)]) |
| 81 | -1x | -
- "Between-Within" = h_df_md_bw(object, contrast),- |
- ||
| 82 | -! | -
- stop("Unrecognized degrees of freedom method: ", object$method)
- |
- ||
| 83 | -+ | 458 | +7x |
- )+ unname(ret) |
| 84 | +459 |
} |
||
| 85 | +460 | |||
| 86 | +461 |
- #' Creating T-Statistic Test Results For One-Dimensional Contrast+ #' Register S3 Method |
||
| 87 | +462 |
- #'+ #' Register S3 method to a generic. |
||
| 88 | +463 |
- #' @description Creates a list of results for one-dimensional contrasts using+ #' |
||
| 89 | +464 |
- #' a t-test statistic and the given degrees of freedom.+ #' @param pkg (`string`) name of the package name. |
||
| 90 | +465 |
- #'+ #' @param generic (`string`) name of the generic. |
||
| 91 | +466 |
- #' @inheritParams df_1d+ #' @param class (`string`) class name the function want to dispatch. |
||
| 92 | +467 |
- #' @param df (`number`)\cr degrees of freedom for the one-dimensional contrast.+ #' @param envir (`environment`) the location the method is defined. |
||
| 93 | +468 |
#' |
||
| 94 | +469 |
- #' @return List with `est`, `se`, `df`, `t_stat` and `p_val` (2-sided p-value).+ #' @details This function is adapted from `emmeans:::register_s3_method()`. |
||
| 95 | +470 |
#' |
||
| 96 | +471 |
#' @keywords internal |
||
| 97 | -- |
- h_test_1d <- function(object,- |
- ||
| 98 | -- |
- contrast,- |
- ||
| 99 | +472 |
- df) {
- |
- ||
| 100 | -486x | -
- assert_class(object, "mmrm")+ h_register_s3 <- function(pkg, generic, class, envir = parent.frame()) {
|
||
| 101 | -486x | +473 | +1x |
- assert_numeric(contrast, len = length(component(object, "beta_est")))+ assert_string(pkg) |
| 102 | -486x | -
- assert_number(df, lower = .Machine$double.xmin)- |
- ||
| 103 | -+ | 474 | +1x |
-
+ assert_string(generic) |
| 104 | -486x | +475 | +1x |
- est <- sum(contrast * component(object, "beta_est"))+ assert_string(class) |
| 105 | -486x | +476 | +1x |
- var <- h_quad_form_vec(contrast, component(object, "beta_vcov"))+ assert_environment(envir) |
| 106 | -486x | +477 | +1x |
- se <- sqrt(var)+ fun <- get(paste0(generic, ".", class), envir = envir) |
| 107 | -486x | +478 | +1x |
- t_stat <- est / se+ if (isNamespaceLoaded(pkg)) {
|
| 108 | -486x | +479 | +1x |
- p_val <- 2 * stats::pt(q = abs(t_stat), df = df, lower.tail = FALSE)+ registerS3method(generic, class, fun, envir = asNamespace(pkg)) |
| 109 | +480 | - - | -||
| 110 | -486x | -
- list(- |
- ||
| 111 | -486x | -
- est = est,- |
- ||
| 112 | -486x | -
- se = se,- |
- ||
| 113 | -486x | -
- df = df,+ } |
||
| 114 | -486x | +481 | +1x |
- t_stat = t_stat,+ setHook(packageEvent(pkg, "onLoad"), function(...) {
|
| 115 | -486x | +|||
| 482 | +! |
- p_val = p_val+ registerS3method(generic, class, fun, envir = asNamespace(pkg)) |
||
| 116 | +483 |
- )+ }) |
||
| 117 | +484 |
} |
||
| 118 | +485 | |||
| 119 | +486 |
- #' Creating F-Statistic Test Results For Multi-Dimensional Contrast+ #' Check if a Factor Should Drop Levels |
||
| 120 | +487 |
#' |
||
| 121 | -- |
- #' @description Creates a list of results for multi-dimensional contrasts using- |
- ||
| 122 | +488 |
- #' an F-test statistic and the given degrees of freedom.+ #' @param x (`vector`) vector to check. |
||
| 123 | +489 |
#' |
||
| 124 | +490 |
- #' @inheritParams df_md+ #' @keywords internal |
||
| 125 | +491 |
- #' @param contrast (`matrix`)\cr numeric contrast matrix.+ h_extra_levels <- function(x) {
|
||
| 126 | -+ | |||
| 492 | +1623x |
- #' @param df (`number`)\cr denominator degrees of freedom for the multi-dimensional contrast.+ is.factor(x) && length(levels(x)) > length(unique(x)) |
||
| 127 | +493 |
- #' @param f_stat_factor (`number`)\cr optional scaling factor on top of the standard F-statistic.+ } |
||
| 128 | +494 |
- #'+ |
||
| 129 | +495 |
- #' @return List with `num_df`, `denom_df`, `f_stat` and `p_val` (2-sided p-value).+ #' Drop Levels from Dataset |
||
| 130 | +496 |
- #'+ #' @param data (`data.frame`) data to drop levels. |
||
| 131 | +497 |
- #' @keywords internal+ #' @param subject_var (`character`) subject variable. |
||
| 132 | +498 |
- h_test_md <- function(object,+ #' @param visit_var (`character`) visit variable. |
||
| 133 | +499 |
- contrast,+ #' @param except (`character`) variables to exclude from dropping. |
||
| 134 | +500 |
- df,+ #' @keywords internal |
||
| 135 | +501 |
- f_stat_factor = 1) {
+ h_drop_levels <- function(data, subject_var, visit_var, except) {
|
||
| 136 | -15x | +502 | +262x |
- assert_class(object, "mmrm")+ assert_data_frame(data) |
| 137 | -15x | +503 | +262x |
- assert_matrix(contrast, ncols = length(component(object, "beta_est")))+ assert_character(subject_var) |
| 138 | -15x | +504 | +262x |
- num_df <- nrow(contrast)+ assert_character(visit_var) |
| 139 | -15x | +505 | +262x |
- assert_number(df, lower = .Machine$double.xmin)+ assert_character(except, null.ok = TRUE) |
| 140 | -15x | -
- assert_number(f_stat_factor, lower = .Machine$double.xmin)- |
- ||
| 141 | -+ | 506 | +262x |
-
+ all_cols <- colnames(data) |
| 142 | -15x | +507 | +262x |
- prec_contrast <- solve(h_quad_form_mat(contrast, component(object, "beta_vcov")))+ to_drop <- vapply( |
| 143 | -15x | +508 | +262x |
- contrast_est <- component(object, "beta_est") %*% t(contrast)+ data, |
| 144 | -15x | +509 | +262x |
- f_statistic <- as.numeric(f_stat_factor / num_df * h_quad_form_mat(contrast_est, prec_contrast))+ h_extra_levels, |
| 145 | -15x | +510 | +262x |
- p_val <- stats::pf(+ logical(1L) |
| 146 | -15x | +|||
| 511 | +
- q = f_statistic,+ ) |
|||
| 147 | -15x | +512 | +262x |
- df1 = num_df,+ to_drop <- all_cols[to_drop] |
| 148 | -15x | +|||
| 513 | +
- df2 = df,+ # only drop levels for those not defined in excep and not in visit_var. |
|||
| 149 | -15x | +514 | +262x |
- lower.tail = FALSE+ to_drop <- setdiff(to_drop, c(visit_var, except)) |
| 150 | -+ | |||
| 515 | +262x |
- )+ data[to_drop] <- lapply(data[to_drop], droplevels) |
||
| 151 | +516 |
-
+ # subject var are always dropped and no message given. |
||
| 152 | -15x | +517 | +262x |
- list(+ dropped <- setdiff(to_drop, subject_var) |
| 153 | -15x | +518 | +262x |
- num_df = num_df,+ if (length(dropped) > 0) {
|
| 154 | -15x | +519 | +3x |
- denom_df = df,+ message( |
| 155 | -15x | +520 | +3x |
- f_stat = f_statistic,+ "Some factor levels are dropped due to singular design matrix: ", |
| 156 | -15x | +521 | +3x |
- p_val = p_val+ toString(dropped) |
| 157 | +522 |
- )+ ) |
||
| 158 | +523 |
- }+ } |
| 1 | -+ | ||
| 524 | +262x |
- #' Register `mmrm` For Use With `car::Anova`+ data |
|
| 2 | +525 |
- #'+ } |
|
| 3 | +526 |
- #' @inheritParams base::requireNamespace+ |
|
| 4 | +527 |
- #' @return A logical value indicating whether registration was successful.+ #' Warn if TMB is Configured to Optimize Instantly |
|
| 5 | +528 |
#' |
|
| 6 | +529 |
- #' @keywords internal+ #' This function checks the TMB configuration for the `optimize.instantly` setting.+ |
+ |
| 530 | ++ |
+ #' If it is set to `TRUE`, a warning is issued indicating that this may lead to+ |
+ |
| 531 | ++ |
+ #' unreproducible results.+ |
+ |
| 532 | ++ |
+ #'+ |
+ |
| 533 | ++ |
+ #' @return No return value, called for side effects.+ |
+ |
| 534 | ++ |
+ #' @keywords internal+ |
+ |
| 535 | ++ |
+ h_tmb_warn_optimization <- function() {
+ |
+ |
| 536 | +247x | +
+ tmb_config <- TMB::config("optimize.instantly", DLL = "mmrm")
+ |
+ |
| 537 | +247x | +
+ if (tmb_config$optimize.instantly) {
+ |
+ |
| 538 | +1x | +
+ msg <- paste(+ |
+ |
| 539 | +1x | +
+ "TMB is configured to optimize instantly, this may lead to unreproducible results.",+ |
+ |
| 540 | +1x | +
+ "To disable this behavior, use `TMB::config(optimize.instantly = 0)`.",+ |
+ |
| 541 | +1x | +
+ sep = "\n"+ |
+ |
| 542 | ++ |
+ )+ |
+ |
| 543 | +1x | +
+ rlang::warn(msg, .frequency = "once", .frequency_id = "tmb_warn_optimization")+ |
+ |
| 544 | ++ |
+ }+ |
+ |
| 545 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Register `mmrm` For Use With `car::Anova`+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @inheritParams base::requireNamespace+ |
+
| 4 | ++ |
+ #' @return A logical value indicating whether registration was successful.+ |
+
| 5 | ++ |
+ #'+ |
+
| 6 | ++ |
+ #' @keywords internal |
| 1 |
- #' Capture all Output+ #' Fitting an MMRM with Single Optimizer |
|||
| 3 |
- #' This function silences all warnings, errors & messages and instead returns a list+ #' @description `r lifecycle::badge("stable")`
|
|||
| 4 |
- #' containing the results (if it didn't error), as well as the warnings, errors+ #' |
|||
| 5 |
- #' and messages and divergence signals as character vectors.+ #' This function helps to fit an MMRM using `TMB` with a single optimizer, |
|||
| 6 |
- #'+ #' while capturing messages and warnings. |
|||
| 7 |
- #' @param expr (`expression`)\cr to be executed.+ #' |
|||
| 8 |
- #' @param remove (`list`)\cr optional list with elements `warnings`, `errors`,+ #' @inheritParams mmrm |
|||
| 9 |
- #' `messages` which can be character vectors, which will be removed from the+ #' @param control (`mmrm_control`)\cr object. |
|||
| 10 |
- #' results if specified.+ #' @param tmb_data (`mmrm_tmb_data`)\cr object. |
|||
| 11 |
- #' @param divergence (`list`)\cr optional list similar as `remove`, but these+ #' @param formula_parts (`mmrm_tmb_formula_parts`)\cr object. |
|||
| 12 |
- #' character vectors will be moved to the `divergence` result and signal+ #' @param ... Additional arguments to pass to [mmrm_control()]. |
|||
| 13 |
- #' that the fit did not converge.+ #' |
|||
| 14 |
- #'+ #' @details |
|||
| 15 |
- #' @return+ #' `fit_single_optimizer` will fit the `mmrm` model using the `control` provided. |
|||
| 16 |
- #' A list containing+ #' If there are multiple optimizers provided in `control`, only the first optimizer |
|||
| 17 |
- #'+ #' will be used. |
|||
| 18 |
- #' - `result`: The object returned by `expr` or `list()` if an error was thrown.+ #' If `tmb_data` and `formula_parts` are both provided, `formula`, `data`, `weights`, |
|||
| 19 |
- #' - `warnings`: `NULL` or a character vector if warnings were thrown.+ #' `reml`, and `covariance` are ignored. |
|||
| 20 |
- #' - `errors`: `NULL` or a string if an error was thrown.+ #' |
|||
| 21 |
- #' - `messages`: `NULL` or a character vector if messages were produced.+ #' @return The `mmrm_fit` object, with additional attributes containing warnings, |
|||
| 22 |
- #' - `divergence`: `NULL` or a character vector if divergence messages were caught.+ #' messages, optimizer used and convergence status in addition to the |
|||
| 23 |
- #'+ #' `mmrm_tmb` contents. |
|||
| 24 |
- #' @keywords internal+ #' @export |
|||
| 25 |
- h_record_all_output <- function(expr,+ #' |
|||
| 26 |
- remove = list(),+ #' @examples |
|||
| 27 |
- divergence = list()) {
+ #' mod_fit <- fit_single_optimizer( |
|||
| 28 |
- # Note: We don't need to and cannot assert `expr` here.+ #' formula = FEV1 ~ RACE + SEX + ARMCD * AVISIT + us(AVISIT | USUBJID), |
|||
| 29 | -200x | +
- assert_list(remove, types = "character")+ #' data = fev_data, |
||
| 30 | -200x | +
- assert_list(divergence, types = "character")+ #' weights = rep(1, nrow(fev_data)), |
||
| 31 | -200x | +
- env <- new.env()+ #' optimizer = "nlminb" |
||
| 32 | -200x | +
- result <- withCallingHandlers(+ #' ) |
||
| 33 | -200x | +
- withRestarts(+ #' attr(mod_fit, "converged") |
||
| 34 | -200x | +
- expr,+ fit_single_optimizer <- function(formula, |
||
| 35 | -200x | +
- muffleStop = function(e) structure(e$message, class = "try-error")+ data, |
||
| 36 |
- ),+ weights, |
|||
| 37 | -200x | +
- message = function(m) {
+ reml = TRUE, |
||
| 38 | -6x | +
- msg_without_newline <- gsub(m$message, pattern = "\n$", replacement = "")+ covariance = NULL, |
||
| 39 | -6x | +
- env$message <- c(env$message, msg_without_newline)+ tmb_data, |
||
| 40 | -6x | +
- invokeRestart("muffleMessage")
+ formula_parts, |
||
| 41 |
- },+ ..., |
|||
| 42 | -200x | +
- warning = function(w) {
+ control = mmrm_control(...)) {
|
||
| 43 | -14x | +198x |
- env$warning <- c(env$warning, w$message)+ to_remove <- list( |
|
| 44 | -14x | +
- invokeRestart("muffleWarning")
+ # Transient visit to invalid parameters. |
||
| 45 | -+ | 198x |
- },+ warnings = c("NA/NaN function evaluation")
|
|
| 46 | -200x | +
- error = function(e) {
+ ) |
||
| 47 | -14x | +198x |
- env$error <- c(env$error, e$message)+ as_diverged <- list( |
|
| 48 | -14x | +198x |
- invokeRestart("muffleStop", e)
+ errors = c( |
|
| 49 | -+ | 198x |
- }+ "NA/NaN Hessian evaluation", |
|
| 50 | -+ | 198x |
- )+ "L-BFGS-B needs finite values of 'fn'" |
|
| 51 | -200x | +
- list(+ ) |
||
| 52 | -200x | +
- result = result,+ ) |
||
| 53 | -200x | +198x |
- warnings = setdiff(env$warning, c(remove$warnings, divergence$warnings)),+ if (missing(tmb_data) || missing(formula_parts)) {
|
|
| 54 | -200x | +14x |
- errors = setdiff(env$error, c(remove$errors, divergence$errors)),+ h_valid_formula(formula) |
|
| 55 | -200x | +13x |
- messages = setdiff(env$message, c(remove$messages, divergence$messages)),+ assert_data_frame(data) |
|
| 56 | -200x | +13x |
- divergence = c(+ assert_numeric(weights, any.missing = FALSE, lower = .Machine$double.xmin) |
|
| 57 | -200x | +13x |
- intersect(env$warning, divergence$warnings),+ assert_flag(reml) |
|
| 58 | -200x | +13x |
- intersect(env$error, divergence$errors),+ assert_class(control, "mmrm_control") |
|
| 59 | -200x | +13x |
- intersect(env$message, divergence$messages)+ assert_list(control$optimizers, names = "unique", types = c("function", "partial"))
|
|
| 60 | -+ | 13x |
- )+ quiet_fit <- h_record_all_output( |
|
| 61 | -+ | 13x |
- )+ fit_mmrm( |
|
| 62 | -+ | 13x |
- }+ formula = formula, |
|
| 63 | -+ | 13x |
-
+ data = data, |
|
| 64 | -+ | 13x |
- #' Trace of a Matrix+ weights = weights, |
|
| 65 | -+ | 13x |
- #'+ reml = reml, |
|
| 66 | -+ | 13x |
- #' @description Obtain the trace of a matrix if the matrix is diagonal, otherwise raise an error.+ covariance = covariance, |
|
| 67 | -+ | 13x |
- #'+ control = control |
|
| 68 |
- #' @param x (`matrix`)\cr square matrix input.+ ), |
|||
| 69 | -+ | 13x |
- #'+ remove = to_remove, |
|
| 70 | -+ | 13x |
- #' @return The trace of the square matrix.+ divergence = as_diverged |
|
| 71 |
- #'+ ) |
|||
| 72 |
- #' @keywords internal+ } else {
|
|||
| 73 | -+ | 184x |
- h_tr <- function(x) {
+ assert_class(tmb_data, "mmrm_tmb_data") |
|
| 74 | -1790x | +184x |
- if (nrow(x) != ncol(x)) {
+ assert_class(formula_parts, "mmrm_tmb_formula_parts") |
|
| 75 | -1x | +184x |
- stop("x must be square matrix")
+ quiet_fit <- h_record_all_output( |
|
| 76 | -+ | 184x |
- }+ fit_mmrm( |
|
| 77 | -1789x | +184x |
- sum(Matrix::diag(x))+ formula_parts = formula_parts, |
|
| 78 | -+ | 184x |
- }+ tmb_data = tmb_data, |
|
| 79 | -+ | 184x |
-
+ control = control |
|
| 80 |
- #' Split Control List+ ), |
|||
| 81 | -+ | 184x |
- #'+ remove = to_remove, |
|
| 82 | -+ | 184x |
- #' @description Split the [mmrm_control()] object according to its optimizers and use additional arguments+ divergence = as_diverged |
|
| 83 |
- #' to replace the elements in the original object.+ ) |
|||
| 84 |
- #'+ } |
|||
| 85 | -+ | 197x |
- #' @param control (`mmrm_control`)\cr object.+ if (length(quiet_fit$errors)) {
|
|
| 86 | -+ | 4x |
- #' @param ... additional parameters to update the `control` object.+ stop(quiet_fit$errors) |
|
| 87 |
- #'+ } |
|||
| 88 | -+ | 193x |
- #' @return A `list` of `mmrm_control` entries.+ converged <- (length(quiet_fit$warnings) == 0L) && |
|
| 89 | -+ | 193x |
- #' @keywords internal+ (length(quiet_fit$divergence) == 0L) && |
|
| 90 | -+ | 193x |
- h_split_control <- function(control, ...) {
+ isTRUE(quiet_fit$result$opt_details$convergence == 0) |
|
| 91 | -8x | +193x |
- assert_class(control, "mmrm_control")+ structure( |
|
| 92 | -8x | +193x |
- l <- length(control$optimizers)+ quiet_fit$result, |
|
| 93 | -8x | +193x |
- lapply(seq_len(l), function(i) {
+ warnings = quiet_fit$warnings, |
|
| 94 | -22x | +193x |
- ret <- modifyList(control, list(...))+ messages = quiet_fit$messages, |
|
| 95 | -22x | +193x |
- ret$optimizers <- control$optimizers[i]+ divergence = quiet_fit$divergence, |
|
| 96 | -22x | +193x |
- ret+ converged = converged, |
|
| 97 | -+ | 193x |
- })+ class = c("mmrm_fit", class(quiet_fit$result))
|
|
| 98 |
- }+ ) |
|||
| 99 |
-
+ } |
|||
| 100 |
- #' Obtain Optimizer according to Optimizer String Value+ |
|||
| 101 |
- #'+ #' Summarizing List of Fits |
|||
| 102 |
- #' @description This function creates optimizer functions with arguments.+ #' |
|||
| 103 |
- #'+ #' @param all_fits (`list` of `mmrm_fit` or `try-error`)\cr list of fits. |
|||
| 104 |
- #' @param optimizer (`character`)\cr names of built-in optimizers to try, subset+ #' |
|||
| 105 |
- #' of "L-BFGS-B", "BFGS", "CG" and "nlminb".+ #' @return List with `warnings`, `messages`, `log_liks` and `converged` results. |
|||
| 106 |
- #' @param optimizer_fun (`function` or `list` of `function`)\cr alternatively to `optimizer`,+ #' @keywords internal |
|||
| 107 |
- #' an optimizer function or a list of optimizer functions can be passed directly here.+ h_summarize_all_fits <- function(all_fits) {
|
|||
| 108 | -+ | 8x |
- #' @param optimizer_args (`list`)\cr additional arguments for `optimizer_fun`.+ assert_list(all_fits, types = c("mmrm_fit", "try-error"))
|
|
| 109 | -+ | 8x |
- #' @param optimizer_control (`list`)\cr passed to argument `control` in `optimizer_fun`.+ is_error <- vapply(all_fits, is, logical(1), class2 = "try-error") |
|
| 110 |
- #'+ |
|||
| 111 | -+ | 8x |
- #' @details+ warnings <- messages <- vector(mode = "list", length = length(all_fits)) |
|
| 112 | -+ | 8x |
- #' If you want to use only the built-in optimizers:+ warnings[is_error] <- lapply(all_fits[is_error], as.character) |
|
| 113 | -+ | 8x |
- #' - `optimizer` is a shortcut to create a list of built-in optimizer functions+ warnings[!is_error] <- lapply(all_fits[!is_error], attr, which = "warnings") |
|
| 114 | -+ | 8x |
- #' passed to `optimizer_fun`.+ messages[!is_error] <- lapply(all_fits[!is_error], attr, which = "messages") |
|
| 115 | -+ | 8x |
- #' - Allowed are "L-BFGS-B", "BFGS", "CG" (using [stats::optim()] with corresponding method)+ log_liks <- as.numeric(rep(NA, length.out = length(all_fits))) |
|
| 116 | -+ | 8x |
- #' and "nlminb" (using [stats::nlminb()]).+ log_liks[!is_error] <- vapply(all_fits[!is_error], stats::logLik, numeric(1L)) |
|
| 117 | -+ | 8x |
- #' - Other arguments should go into `optimizer_args`.+ converged <- rep(FALSE, length.out = length(all_fits)) |
|
| 118 | -+ | 8x |
- #'+ converged[!is_error] <- vapply(all_fits[!is_error], attr, logical(1), which = "converged") |
|
| 119 |
- #' If you want to use your own optimizer function:+ |
|||
| 120 | -+ | 8x |
- #' - Make sure that there are three arguments: parameter (start value), objective function+ list( |
|
| 121 | -+ | 8x |
- #' and gradient function are sequentially in the function arguments.+ warnings = warnings, |
|
| 122 | -+ | 8x |
- #' - If there are other named arguments in front of these, make sure they are correctly+ messages = messages, |
|
| 123 | -+ | 8x |
- #' specified through `optimizer_args`.+ log_liks = log_liks, |
|
| 124 | -+ | 8x |
- #' - If the hessian can be used, please make sure its argument name is `hessian` and+ converged = converged |
|
| 125 |
- #' please add attribute `use_hessian = TRUE` to the function,+ ) |
|||
| 126 |
- #' using `attr(fun, "use_hessian) <- TRUE`.+ } |
|||
| 127 |
- #'+ |
|||
| 128 |
- #' @return Named `list` of optimizers created by [h_partial_fun_args()].+ #' Refitting MMRM with Multiple Optimizers |
|||
| 130 |
- #' @keywords internal+ #' @description `r lifecycle::badge("stable")`
|
|||
| 131 |
- h_get_optimizers <- function(optimizer = c("L-BFGS-B", "BFGS", "CG", "nlminb"),
+ #' |
|||
| 132 |
- optimizer_fun = h_optimizer_fun(optimizer),+ #' @param fit (`mmrm_fit`)\cr original model fit from [fit_single_optimizer()]. |
|||
| 133 |
- optimizer_args = list(),+ #' @param ... Additional arguments passed to [mmrm_control()]. |
|||
| 134 |
- optimizer_control = list()) {
+ #' @param control (`mmrm_control`)\cr object. |
|||
| 135 | -245x | +
- if ("automatic" %in% optimizer) {
+ #' |
||
| 136 | -1x | +
- lifecycle::deprecate_warn(+ #' @return The best (in terms of log likelihood) fit which converged. |
||
| 137 | -1x | +
- when = "0.2.0",+ #' |
||
| 138 | -1x | +
- what = I("\"automatic\" optimizer"),
+ #' @note For Windows, no parallel computations are currently implemented. |
||
| 139 | -1x | +
- details = "please just omit optimizer argument"+ #' @export |
||
| 140 |
- )+ #' |
|||
| 141 | -1x | +
- optimizer_fun <- h_optimizer_fun()+ #' @examples |
||
| 142 |
- }+ #' fit <- fit_single_optimizer( |
|||
| 143 | -245x | +
- assert(+ #' formula = FEV1 ~ RACE + SEX + ARMCD * AVISIT + us(AVISIT | USUBJID), |
||
| 144 | -245x | +
- test_function(optimizer_fun),+ #' data = fev_data, |
||
| 145 | -245x | +
- test_list(optimizer_fun, types = "function", names = "unique")+ #' weights = rep(1, nrow(fev_data)), |
||
| 146 |
- )+ #' optimizer = "nlminb" |
|||
| 147 | -245x | +
- if (is.function(optimizer_fun)) {
+ #' ) |
||
| 148 | -7x | +
- optimizer_fun <- list(custom_optimizer = optimizer_fun)+ #' best_fit <- refit_multiple_optimizers(fit) |
||
| 149 |
- }+ refit_multiple_optimizers <- function(fit, |
|||
| 150 | -245x | +
- lapply(optimizer_fun, function(x) {
+ ..., |
||
| 151 | -920x | +
- do.call(h_partial_fun_args, c(list(fun = x, control = optimizer_control), optimizer_args))+ control = mmrm_control(...)) {
|
||
| 152 | -+ | 6x |
- })+ assert_class(fit, "mmrm_fit") |
|
| 153 | -+ | 6x |
- }+ assert_class(control, "mmrm_control") |
|
| 155 | -+ | 6x |
- #' Obtain Optimizer Function with Character+ n_cores_used <- ifelse( |
|
| 156 | -+ | 6x |
- #' @description Obtain the optimizer function through the character provided.+ .Platform$OS.type == "windows", |
|
| 157 | -+ | 6x |
- #' @param optimizer (`character`)\cr vector of optimizers.+ 1L, |
|
| 158 | -+ | 6x |
- #'+ min( |
|
| 159 | -+ | 6x |
- #' @return A (`list`)\cr of optimizer functions generated from [h_partial_fun_args()].+ length(control$optimizers), |
|
| 160 | -+ | 6x |
- #' @keywords internal+ control$n_cores |
|
| 161 |
- h_optimizer_fun <- function(optimizer = c("L-BFGS-B", "BFGS", "CG", "nlminb")) {
+ ) |
|||
| 162 | -239x | +
- optimizer <- match.arg(optimizer, several.ok = TRUE)+ ) |
||
| 163 | -239x | +6x |
- lapply(stats::setNames(optimizer, optimizer), function(x) {
+ controls <- h_split_control( |
|
| 164 | -916x | +6x |
- switch(x,+ control, |
|
| 165 | -228x | +6x |
- "L-BFGS-B" = h_partial_fun_args(fun = stats::optim, method = x),+ start = fit$theta_est |
|
| 166 | -229x | +
- "BFGS" = h_partial_fun_args(fun = stats::optim, method = x),+ ) |
||
| 167 | -227x | +
- "CG" = h_partial_fun_args(fun = stats::optim, method = x),+ |
||
| 168 | -232x | +
- "nlminb" = h_partial_fun_args(fun = stats::nlminb, additional_attr = list(use_hessian = TRUE))+ # Take the results from old fit as starting values for new fits. |
||
| 169 | -+ | 6x |
- )+ all_fits <- suppressWarnings(parallel::mcmapply( |
|
| 170 | -+ | 6x |
- })+ FUN = fit_single_optimizer, |
|
| 171 | -+ | 6x |
- }+ control = controls, |
|
| 172 | -+ | 6x |
-
+ MoreArgs = list( |
|
| 173 | -+ | 6x |
- #' Create Partial Functions+ tmb_data = fit$tmb_data, |
|
| 174 | -+ | 6x |
- #' @description Creates partial functions with arguments.+ formula_parts = fit$formula_parts |
|
| 175 |
- #'+ ), |
|||
| 176 | -+ | 6x |
- #' @param fun (`function`)\cr to be wrapped.+ mc.cores = n_cores_used, |
|
| 177 | -+ | 6x |
- #' @param ... Additional arguments for `fun`.+ mc.silent = TRUE, |
|
| 178 | -+ | 6x |
- #' @param additional_attr (`list`)\cr of additional attributes to apply to the result.+ SIMPLIFY = FALSE |
|
| 179 |
- #'+ )) |
|||
| 180 | -+ | 6x |
- #' @details This function add `args` attribute to the original function,+ all_fits <- c(all_fits, list(old_result = fit)) |
|
| 181 |
- #' and add an extra class `partial` to the function.+ |
|||
| 182 |
- #' `args` is the argument for the function, and elements in `...` will override the existing+ # Find the results that are ok and return best in terms of log-likelihood. |
|||
| 183 | -+ | 6x |
- #' arguments in attribute `args`. `additional_attr` will override the existing attributes.+ all_fits_summary <- h_summarize_all_fits(all_fits) |
|
| 184 | -+ | 6x |
- #'+ is_ok <- all_fits_summary$converged |
|
| 185 | -+ | 6x |
- #' @return Object with S3 class `"partial"`, a `function` with `args` attribute (and possibly more+ if (!any(is_ok)) {
|
|
| 186 | -+ | 1x |
- #' attributes from `additional_attr`).+ stop( |
|
| 187 | -+ | 1x |
- #' @keywords internal+ "No optimizer led to a successful model fit. ", |
|
| 188 | -+ | 1x |
- h_partial_fun_args <- function(fun, ..., additional_attr = list()) {
+ "Please try to use a different covariance structure or other covariates." |
|
| 189 | -1840x | +
- assert_function(fun)+ ) |
||
| 190 | -1840x | +
- assert_list(additional_attr, names = "unique")+ } |
||
| 191 | -1840x | +5x |
- a_args <- list(...)+ best_optimizer <- which.max(all_fits_summary$log_liks[is_ok]) |
|
| 192 | -1840x | +5x |
- assert_list(a_args, names = "unique")+ all_fits[[which(is_ok)[best_optimizer]]] |
|
| 193 | -1840x | +
- args <- attr(fun, "args")+ } |
||
| 194 | -1840x | +
- if (is.null(args)) {
+
|
||
| 195 | -928x | +
- args <- list()+ #' Control Parameters for Fitting an MMRM |
||
| 196 |
- }+ #' |
|||
| 197 | -1840x | +
- do.call(+ #' @description `r lifecycle::badge("stable")`
|
||
| 198 | -1840x | +
- structure,+ #' Fine-grained specification of the MMRM fit details is possible using this |
||
| 199 | -1840x | +
- args = modifyList(list(+ #' control function. |
||
| 200 | -1840x | +
- .Data = fun, args = modifyList(args, a_args),+ #' |
||
| 201 | -1840x | +
- class = c("partial", "function")
+ #' @param n_cores (`count`)\cr number of cores to be used. |
||
| 202 | -1840x | +
- ), additional_attr)+ #' @param method (`string`)\cr adjustment method for degrees of freedom. |
||
| 203 |
- )+ #' @param vcov (`string`)\cr coefficients covariance matrix adjustment method. |
|||
| 204 |
- }+ #' @param start (`NULL`, `numeric` or `function`)\cr optional start values for variance |
|||
| 205 |
-
+ #' parameters. See details for more information. |
|||
| 206 |
- #' Obtain Default Covariance Method+ #' @param accept_singular (`flag`)\cr whether singular design matrices are reduced |
|||
| 207 |
- #'+ #' to full rank automatically and additional coefficient estimates will be missing. |
|||
| 208 |
- #' @description Obtain the default covariance method depending on+ #' @param optimizers (`list`)\cr optimizer specification, created with [h_get_optimizers()]. |
|||
| 209 |
- #' the degrees of freedom method used.+ #' @param drop_visit_levels (`flag`)\cr whether to drop levels for visit variable, |
|||
| 210 |
- #'+ #' if visit variable is a factor, see details. |
|||
| 211 |
- #' @param method (`string`)\cr degrees of freedom method.+ #' @param ... additional arguments passed to [h_get_optimizers()]. |
|||
| 213 |
- #' @details The default covariance method is different for different degrees of freedom method.+ #' @details |
|||
| 214 |
- #' For "Satterthwaite" or "Between-Within", "Asymptotic" is returned.+ # - The `drop_visit_levels` flag will decide whether unobserved visits will be kept for analysis. |
|||
| 215 |
- #' For "Kenward-Roger" only, "Kenward-Roger" is returned.+ #' For example, if the data only has observations at visits `VIS1`, `VIS3` and `VIS4`, by default |
|||
| 216 |
- #' For "Residual" only, "Empirical" is returned.+ #' they are treated to be equally spaced, the distance from `VIS1` to `VIS3`, and from `VIS3` to `VIS4`, |
|||
| 217 |
- #'+ #' are identical. However, you can manually convert this visit into a factor, with |
|||
| 218 |
- #' @return String of the default covariance method.+ #' `levels = c("VIS1", "VIS2", "VIS3", "VIS4")`, and also use `drop_visits_levels = FALSE`,
|
|||
| 219 |
- #' @keywords internal+ #' then the distance from `VIS1` to `VIS3` will be double, as `VIS2` is a valid visit. |
|||
| 220 |
- h_get_cov_default <- function(method = c("Satterthwaite", "Kenward-Roger", "Residual", "Between-Within")) {
+ #' However, please be cautious because this can lead to convergence failure |
|||
| 221 | -196x | +
- assert_string(method)+ #' when using an unstructured covariance matrix and there are no observations |
||
| 222 | -196x | +
- method <- match.arg(method)+ #' at the missing visits. |
||
| 223 | -195x | +
- switch(method,+ #' - The `method` and `vcov` arguments specify the degrees of freedom and coefficients |
||
| 224 | -1x | +
- "Residual" = "Empirical",+ #' covariance matrix adjustment methods, respectively. |
||
| 225 | -157x | +
- "Satterthwaite" = "Asymptotic",+ #' - Allowed `vcov` includes: "Asymptotic", "Kenward-Roger", "Kenward-Roger-Linear", "Empirical" (CR0), |
||
| 226 | -35x | +
- "Kenward-Roger" = "Kenward-Roger",+ #' "Empirical-Jackknife" (CR3), and "Empirical-Bias-Reduced" (CR2). |
||
| 227 | -2x | +
- "Between-Within" = "Asymptotic"+ #' - Allowed `method` includes: "Satterthwaite", "Kenward-Roger", "Between-Within" and "Residual". |
||
| 228 |
- )+ #' - If `method` is "Kenward-Roger" then only "Kenward-Roger" or "Kenward-Roger-Linear" are allowed for `vcov`. |
|||
| 229 |
- }+ #' - The `vcov` argument can be `NULL` to use the default covariance method depending on the `method` |
|||
| 230 |
-
+ #' used for degrees of freedom, see the following table: |
|||
| 231 |
- #' Complete `character` Vector Names From Values+ #' |
|||
| 232 |
- #'+ #' | `method` | Default `vcov`| |
|||
| 233 |
- #' @param x (`character` or `list`)\cr value whose names should be completed+ #' |-----------|----------| |
|||
| 234 |
- #' from element values.+ #' |Satterthwaite| Asymptotic| |
|||
| 235 |
- #'+ #' |Kenward-Roger| Kenward-Roger| |
|||
| 236 |
- #' @return A named vector or list.+ #' |Residual| Empirical| |
|||
| 237 |
- #'+ #' |Between-Within| Asymptotic| |
|||
| 238 |
- #' @keywords internal+ #' |
|||
| 239 |
- fill_names <- function(x) {
+ #' - Please note that "Kenward-Roger" for "Unstructured" covariance gives different results |
|||
| 240 | -4x | +
- n <- names(x)+ #' compared to SAS; Use "Kenward-Roger-Linear" for `vcov` instead for better matching |
||
| 241 | -4x | +
- is_unnamed <- if (is.null(n)) rep_len(TRUE, length(x)) else n == ""+ #' of the SAS results. |
||
| 242 | -4x | +
- names(x)[is_unnamed] <- x[is_unnamed]+ #' |
||
| 243 | -4x | +
- x+ #' - The argument `start` is used to facilitate the choice of initial values for fitting the model. |
||
| 244 |
- }+ #' If `function` is provided, make sure its parameter is a valid element of `mmrm_tmb_data` |
|||
| 245 |
-
+ #' or `mmrm_tmb_formula_parts` and it returns a numeric vector. |
|||
| 246 |
- #' Drop Items from an Indexible+ #' By default or if `NULL` is provided, `std_start` will be used. |
|||
| 247 |
- #'+ #' Other implemented methods include `emp_start`. |
|||
| 248 |
- #' Drop elements from an indexible object (`vector`, `list`, etc.).+ #' |
|||
| 249 |
- #'+ #' @return List of class `mmrm_control` with the control parameters. |
|||
| 250 |
- #' @param x Any object that can be consumed by [seq_along()] and indexed by a+ #' @export |
|||
| 251 |
- #' logical vector of the same length.+ #' |
|||
| 252 |
- #' @param n (`integer`)\cr the number of terms to drop.+ #' @examples |
|||
| 253 |
- #'+ #' mmrm_control( |
|||
| 254 |
- #' @return A subset of `x`.+ #' optimizer_fun = stats::optim, |
|||
| 255 |
- #'+ #' optimizer_args = list(method = "L-BFGS-B") |
|||
| 256 |
- #' @keywords internal+ #' ) |
|||
| 257 |
- drop_elements <- function(x, n) {
+ mmrm_control <- function(n_cores = 1L, |
|||
| 258 | -816x | +
- x[seq_along(x) > n]+ method = c("Satterthwaite", "Kenward-Roger", "Residual", "Between-Within"),
|
||
| 259 |
- }+ vcov = NULL, |
|||
| 260 |
-
+ start = std_start, |
|||
| 261 |
- #' Ask for Confirmation on Large Visit Levels+ accept_singular = TRUE, |
|||
| 262 |
- #'+ drop_visit_levels = TRUE, |
|||
| 263 |
- #' @description Ask the user for confirmation if there are too many visit levels+ ..., |
|||
| 264 |
- #' for non-spatial covariance structure in interactive sessions.+ optimizers = h_get_optimizers(...)) {
|
|||
| 265 | -+ | 242x |
- #'+ assert_count(n_cores, positive = TRUE) |
|
| 266 | -+ | 242x |
- #' @param x (`numeric`)\cr number of visit levels.+ assert_character(method) |
|
| 267 | -+ | 242x |
- #'+ if (is.null(start)) {
|
|
| 268 | -+ | 1x |
- #' @return Logical value `TRUE`.+ start <- std_start |
|
| 269 |
- #' @keywords internal+ } |
|||
| 270 | -+ | 242x |
- h_confirm_large_levels <- function(x) {
+ assert( |
|
| 271 | -296x | +242x |
- assert_count(x)+ check_function(start, args = "..."), |
|
| 272 | -296x | +242x |
- allowed_lvls <- x <= getOption("mmrm.max_visits", 100)
+ check_numeric(start, null.ok = FALSE), |
|
| 273 | -296x | +242x |
- if (allowed_lvls) {
+ combine = "or" |
|
| 274 | -294x | +
- return(TRUE)+ ) |
||
| 275 | -+ | 242x |
- }+ assert_flag(accept_singular) |
|
| 276 | -2x | +242x |
- if (!interactive()) {
+ assert_flag(drop_visit_levels) |
|
| 277 | -2x | +242x |
- stop("Visit levels too large!", call. = FALSE)
+ assert_list(optimizers, names = "unique", types = c("function", "partial"))
|
|
| 278 | -+ | 242x |
- }+ assert_string(vcov, null.ok = TRUE) |
|
| 279 | -! | +242x |
- proceed <- utils::askYesNo(+ method <- match.arg(method) |
|
| 280 | -! | +242x |
- paste(+ if (is.null(vcov)) {
|
|
| 281 | -! | +191x |
- "Visit levels is possibly too large.",+ vcov <- h_get_cov_default(method) |
|
| 282 | -! | +
- "This requires large memory. Are you sure to continue?",+ } |
||
| 283 | -! | +242x |
- collapse = " "+ assert_subset( |
|
| 284 | -+ | 242x |
- )+ vcov, |
|
| 285 | -+ | 242x |
- )+ c( |
|
| 286 | -! | +242x |
- if (!identical(proceed, TRUE)) {
+ "Asymptotic", |
|
| 287 | -! | +242x |
- stop("Visit levels too large!", call. = FALSE)
+ "Empirical", |
|
| 288 | -+ | 242x |
- }+ "Empirical-Bias-Reduced", |
|
| 289 | -! | +242x |
- return(TRUE)+ "Empirical-Jackknife", |
|
| 290 | -+ | 242x |
- }+ "Kenward-Roger", |
|
| 291 | -+ | 242x |
-
+ "Kenward-Roger-Linear" |
|
| 292 |
- #' Default Value on NULL+ ) |
|||
| 293 |
- #' Return default value when first argument is NULL.+ ) |
|||
| 294 | -+ | 242x |
- #'+ if (xor(identical(method, "Kenward-Roger"), vcov %in% c("Kenward-Roger", "Kenward-Roger-Linear"))) {
|
|
| 295 | -+ | 5x |
- #' @param x Object.+ stop(paste( |
|
| 296 | -+ | 5x |
- #' @param y Object.+ "Kenward-Roger degrees of freedom must work together with Kenward-Roger", |
|
| 297 | -+ | 5x |
- #'+ "or Kenward-Roger-Linear covariance!" |
|
| 298 |
- #' @details If `x` is NULL, returns `y`. Otherwise return `x`.+ )) |
|||
| 299 |
- #'+ } |
|||
| 300 | -+ | 237x |
- #' @keywords internal+ structure( |
|
| 301 | -+ | 237x |
- h_default_value <- function(x, y) {
+ list( |
|
| 302 | -311x | +237x |
- if (is.null(x)) {
+ optimizers = optimizers, |
|
| 303 | -276x | +237x |
- y+ start = start, |
|
| 304 | -+ | 237x |
- } else {
+ accept_singular = accept_singular, |
|
| 305 | -35x | +237x |
- x+ method = method, |
|
| 306 | -+ | 237x |
- }+ vcov = vcov, |
|
| 307 | -+ | 237x |
- }+ n_cores = as.integer(n_cores), |
|
| 308 | -+ | 237x |
-
+ drop_visit_levels = drop_visit_levels |
|
| 309 |
- #' Warn on na.action+ ), |
|||
| 310 | -+ | 237x |
- #' @keywords internal+ class = "mmrm_control" |
|
| 311 |
- h_warn_na_action <- function() {
+ ) |
|||
| 312 | -259x | +
- if (!identical(getOption("na.action"), "na.omit")) {
+ } |
||
| 313 | -6x | +
- warning("na.action is always set to `na.omit` for `mmrm` fit!")
+
|
||
| 314 |
- }+ #' Fit an MMRM |
|||
| 315 |
- }+ #' |
|||
| 316 |
-
+ #' @description `r lifecycle::badge("stable")`
|
|||
| 317 |
- #' Obtain `na.action` as Function+ #' |
|||
| 318 |
- #' @keywords internal+ #' This is the main function fitting the MMRM. |
|||
| 319 |
- h_get_na_action <- function(na_action) {
+ #' |
|||
| 320 | -56x | +
- if (is.function(na_action) && identical(methods::formalArgs(na_action), c("object", "..."))) {
+ #' @param formula (`formula`)\cr the model formula, see details. |
||
| 321 | -5x | +
- return(na_action)+ #' @param data (`data`)\cr the data to be used for the model. |
||
| 322 |
- }+ #' @param weights (`vector`)\cr an optional vector of weights to be used in |
|||
| 323 | -51x | +
- if (is.character(na_action) && length(na_action) == 1L) {
+ #' the fitting process. Should be `NULL` or a numeric vector. |
||
| 324 | -51x | +
- assert_subset(na_action, c("na.omit", "na.exclude", "na.fail", "na.pass", "na.contiguous"))
+ #' @param reml (`flag`)\cr whether restricted maximum likelihood (REML) |
||
| 325 | -51x | +
- return(get(na_action, mode = "function", pos = "package:stats"))+ #' estimation is used, otherwise maximum likelihood (ML) is used. |
||
| 326 |
- }+ #' @param covariance (`cov_struct`)\cr a covariance structure type definition |
|||
| 327 |
- }+ #' as produced with [cov_struct()], or value that can be coerced to a |
|||
| 328 |
-
+ #' covariance structure using [as.cov_struct()]. If no value is provided, |
|||
| 329 |
- #' Validate mmrm Formula+ #' a structure is derived from the provided formula. |
|||
| 330 |
- #' @param formula (`formula`)\cr to check.+ #' @param control (`mmrm_control`)\cr fine-grained fitting specifications list |
|||
| 331 |
- #'+ #' created with [mmrm_control()]. |
|||
| 332 |
- #' @details In mmrm models, `.` is not allowed as it introduces ambiguity of covariates+ #' @param ... arguments passed to [mmrm_control()]. |
|||
| 333 |
- #' to be used, so it is not allowed to be in formula.+ #' |
|||
| 334 |
- #'+ #' @details |
|||
| 335 |
- #' @keywords internal+ #' The `formula` typically looks like: |
|||
| 336 |
- h_valid_formula <- function(formula) {
+ #' `FEV1 ~ RACE + SEX + ARMCD * AVISIT + us(AVISIT | USUBJID)` |
|||
| 337 | -182x | +
- assert_formula(formula)+ #' so specifies response and covariates as usual, and exactly one special term |
||
| 338 | -182x | +
- if ("." %in% all.vars(formula)) {
+ #' defines which covariance structure is used and what are the time point and |
||
| 339 | -2x | +
- stop("`.` is not allowed in mmrm models!")
+ #' subject variables. The covariance structures in the formula can be |
||
| 340 |
- }+ #' found in [`covariance_types`]. |
|||
| 341 |
- }+ #' |
|||
| 342 |
-
+ #' The time points have to be unique for each subject. That is, |
|||
| 343 |
- #' Standard Starting Value+ #' there cannot be time points with multiple observations for any subject. |
|||
| 344 |
- #'+ #' The rationale is that these observations would need to be correlated, but it |
|||
| 345 |
- #' @description Obtain standard start values.+ #' is not possible within the currently implemented covariance structure framework |
|||
| 346 |
- #'+ #' to do that correctly. Moreover, for non-spatial covariance structures, the time |
|||
| 347 |
- #' @param cov_type (`string`)\cr name of the covariance structure.+ #' variable must be a factor variable. |
|||
| 348 |
- #' @param n_visits (`int`)\cr number of visits.+ #' |
|||
| 349 |
- #' @param n_groups (`int`)\cr number of groups.+ #' When optimizer is not set, first the default optimizer |
|||
| 350 |
- #' @param ... not used.+ #' (`L-BFGS-B`) is used to fit the model. If that converges, this is returned. |
|||
| 351 |
- #'+ #' If not, the other available optimizers from [h_get_optimizers()], |
|||
| 352 |
- #' @details+ #' including `BFGS`, `CG` and `nlminb` are |
|||
| 353 |
- #' `std_start` will try to provide variance parameter from identity matrix.+ #' tried (in parallel if `n_cores` is set and not on Windows). |
|||
| 354 |
- #' However, for `ar1` and `ar1h` the corresponding values are not ideal because the+ #' If none of the optimizers converge, then the function fails. Otherwise |
|||
| 355 |
- #' \eqn{\rho} is usually a positive number thus using 0 as starting value can lead to
+ #' the best fit is returned. |
|||
| 356 |
- #' incorrect optimization result, and we use 0.5 as the initial value of \eqn{\rho}.
+ #' |
|||
| 357 |
- #'+ #' Note that fine-grained control specifications can either be passed directly |
|||
| 358 |
- #' @return A numeric vector of starting values.+ #' to the `mmrm` function, or via the `control` argument for bundling together |
|||
| 359 |
- #'+ #' with the [mmrm_control()] function. Both cannot be used together, since |
|||
| 360 |
- #' @export+ #' this would delete the arguments passed via `mmrm`. |
|||
| 361 |
- std_start <- function(cov_type, n_visits, n_groups, ...) {
+ #' |
|||
| 362 | -500x | +
- assert_string(cov_type)+ #' @return An `mmrm` object. |
||
| 363 | -500x | +
- assert_subset(cov_type, cov_types(c("abbr", "habbr")))
+ #' |
||
| 364 | -500x | +
- assert_int(n_visits, lower = 1L)+ #' @note The `mmrm` object is also an `mmrm_fit` and an `mmrm_tmb` object, |
||
| 365 | -500x | +
- assert_int(n_groups, lower = 1L)+ #' therefore corresponding methods also work (see [`mmrm_tmb_methods`]). |
||
| 366 | -500x | +
- start_value <- switch(cov_type,+ #' |
||
| 367 | -500x | +
- us = rep(0, n_visits * (n_visits + 1) / 2),+ #' Additional contents depend on the choice of the adjustment `method`: |
||
| 368 | -500x | +
- toep = rep(0, n_visits),+ #' - If Satterthwaite adjustment is used, the Jacobian information `jac_list` |
||
| 369 | -500x | +
- toeph = rep(0, 2 * n_visits - 1),+ #' is included. |
||
| 370 | -500x | +
- ar1 = c(0, 0.5),+ #' - If Kenward-Roger adjustment is used, `kr_comp` contains necessary |
||
| 371 | -500x | +
- ar1h = c(rep(0, n_visits), 0.5),+ #' components and `beta_vcov_adj` includes the adjusted coefficients covariance |
||
| 372 | -500x | +
- ad = rep(0, n_visits),+ #' matrix. |
||
| 373 | -500x | +
- adh = rep(0, 2 * n_visits - 1),+ #' |
||
| 374 | -500x | +
- cs = rep(0, 2),+ #' Use of the package `emmeans` is supported, see [`emmeans_support`]. |
||
| 375 | -500x | +
- csh = rep(0, n_visits + 1),+ #' |
||
| 376 | -500x | +
- sp_exp = rep(0, 2)+ #' NA values are always omitted regardless of `na.action` setting. |
||
| 377 |
- )+ #' |
|||
| 378 | -500x | +
- rep(start_value, n_groups)+ #' When the number of visit levels is large, it usually requires large memory to create the |
||
| 379 |
- }+ #' covariance matrix. By default, the maximum allowed visit levels is 100, and if there are more |
|||
| 380 |
-
+ #' visit levels, a confirmation is needed if run interactively. |
|||
| 381 |
- #' Empirical Starting Value+ #' You can use `options(mmrm.max_visits = <target>)` to increase the maximum allowed number of visit |
|||
| 382 |
- #'+ #' levels. In non-interactive sessions the confirmation is not raised and will directly give you an error if |
|||
| 383 |
- #' @description Obtain empirical start value for unstructured covariance+ #' the number of visit levels exceeds the maximum. |
|||
| 385 |
- #' @param data (`data.frame`)\cr data used for model fitting.+ #' @export |
|||
| 386 |
- #' @param model_formula (`formula`)\cr the formula in mmrm model without covariance structure part.+ #' |
|||
| 387 |
- #' @param visit_var (`string`)\cr visit variable.+ #' @examples |
|||
| 388 |
- #' @param subject_var (`string`)\cr subject id variable.+ #' fit <- mmrm( |
|||
| 389 |
- #' @param subject_groups (`factor`)\cr subject group assignment.+ #' formula = FEV1 ~ RACE + SEX + ARMCD * AVISIT + us(AVISIT | USUBJID), |
|||
| 390 |
- #' @param ... not used.+ #' data = fev_data |
|||
| 391 |
- #'+ #' ) |
|||
| 392 |
- #' @details+ #' |
|||
| 393 |
- #' This `emp_start` only works for unstructured covariance structure.+ #' # Direct specification of control details: |
|||
| 394 |
- #' It uses linear regression to first obtain the coefficients and use the residuals+ #' fit <- mmrm( |
|||
| 395 |
- #' to obtain the empirical variance-covariance, and it is then used to obtain the+ #' formula = FEV1 ~ RACE + SEX + ARMCD * AVISIT + us(AVISIT | USUBJID), |
|||
| 396 |
- #' starting values.+ #' data = fev_data, |
|||
| 397 |
- #'+ #' weights = fev_data$WEIGHTS, |
|||
| 398 |
- #' @note `data` is used instead of `full_frame` because `full_frame` is already+ #' method = "Kenward-Roger" |
|||
| 399 |
- #' transformed if model contains transformations, e.g. `log(FEV1) ~ exp(FEV1_BL)` will+ #' ) |
|||
| 400 |
- #' drop `FEV1` and `FEV1_BL` but add `log(FEV1)` and `exp(FEV1_BL)` in `full_frame`.+ #' |
|||
| 401 |
- #'+ #' # Alternative specification via control argument (but you cannot mix the |
|||
| 402 |
- #' @return A numeric vector of starting values.+ #' # two approaches): |
|||
| 403 |
- #'+ #' fit <- mmrm( |
|||
| 404 |
- #' @export+ #' formula = FEV1 ~ RACE + SEX + ARMCD * AVISIT + us(AVISIT | USUBJID), |
|||
| 405 |
- emp_start <- function(data, model_formula, visit_var, subject_var, subject_groups, ...) {
+ #' data = fev_data, |
|||
| 406 | -4x | +
- assert_formula(model_formula)+ #' control = mmrm_control(method = "Kenward-Roger") |
||
| 407 | -4x | +
- assert_data_frame(data)+ #' ) |
||
| 408 | -4x | +
- assert_subset(all.vars(model_formula), colnames(data))+ mmrm <- function(formula, |
||
| 409 | -4x | +
- assert_string(visit_var)+ data, |
||
| 410 | -4x | +
- assert_string(subject_var)+ weights = NULL, |
||
| 411 | -4x | +
- assert_factor(data[[visit_var]])+ covariance = NULL, |
||
| 412 | -4x | +
- n_visits <- length(levels(data[[visit_var]]))+ reml = TRUE, |
||
| 413 | -4x | +
- assert_factor(data[[subject_var]])+ control = mmrm_control(...), |
||
| 414 | -4x | +
- subjects <- droplevels(data[[subject_var]])+ ...) {
|
||
| 415 | -4x | +174x |
- n_subjects <- length(levels(subjects))+ assert_false(!missing(control) && !missing(...)) |
|
| 416 | -4x | +173x |
- fit <- stats::lm(formula = model_formula, data = data)+ assert_class(control, "mmrm_control") |
|
| 417 | -4x | +168x |
- res <- rep(NA, n_subjects * n_visits)+ assert_list(control$optimizers, min.len = 1) |
|
| 418 | -4x | +
- res[+ |
||
| 419 | -4x | +168x |
- n_visits * as.integer(subjects) - n_visits + as.integer(data[[visit_var]])+ if (control$method %in% c("Kenward-Roger", "Kenward-Roger-Linear") && !reml) {
|
|
| 420 | -4x | +! |
- ] <- residuals(fit)+ stop("Kenward-Roger only works for REML")
|
|
| 421 | -4x | +
- res_mat <- matrix(res, ncol = n_visits, nrow = n_subjects, byrow = TRUE)+ } |
||
| 422 | -4x | +168x |
- emp_covs <- lapply(+ h_valid_formula(formula) |
|
| 423 | -4x | +167x |
- unname(split(seq_len(n_subjects), subject_groups)),+ covariance <- h_reconcile_cov_struct(formula, covariance) |
|
| 424 | -4x | +166x |
- function(x) {
+ formula_parts <- h_mmrm_tmb_formula_parts(formula, covariance) |
|
| 425 | -4x | +
- stats::cov(res_mat[x, , drop = FALSE], use = "pairwise.complete.obs")+ |
||
| 426 | -+ | 166x |
- }+ if (!missing(data)) {
|
|
| 427 | -+ | 165x |
- )+ attr(data, which = "dataname") <- toString(match.call()$data) |
|
| 428 | -4x | +
- unlist(lapply(emp_covs, h_get_theta_from_cov))+ } else {
|
||
| 429 |
- }+ # na.action set to na.pass to allow data to be full; will be futher trimmed later |
|||
| 430 | -+ | 1x |
- #' Obtain Theta from Covariance Matrix+ data <- model.frame(formula_parts$full_formula, na.action = "na.pass") |
|
| 431 |
- #'+ } |
|||
| 432 |
- #' @description Obtain unstructured theta from covariance matrix.+ |
|||
| 433 | -+ | 166x |
- #'+ if (is.null(weights)) {
|
|
| 434 | -+ | 150x |
- #' @param covariance (`matrix`) of covariance matrix values.+ weights <- rep(1, nrow(data)) |
|
| 435 |
- #'+ } else {
|
|||
| 436 | -+ | 16x |
- #' @details+ attr(weights, which = "dataname") <- deparse(match.call()$weights) |
|
| 437 |
- #' If the covariance matrix has `NA` in some of the elements, they will be replaced by+ } |
|||
| 438 | -+ | 166x |
- #' 0 (non-diagonal) and 1 (diagonal). This ensures that the matrix is positive definite.+ tmb_data <- h_mmrm_tmb_data( |
|
| 439 | -+ | 166x |
- #'+ formula_parts, data, weights, reml, |
|
| 440 | -+ | 166x |
- #' @return Numeric vector of the theta values.+ singular = if (control$accept_singular) "drop" else "error", |
|
| 441 | -+ | 166x |
- #' @keywords internal+ drop_visit_levels = control$drop_visit_levels, |
|
| 442 | -+ | 166x |
- h_get_theta_from_cov <- function(covariance) {
+ allow_na_response = FALSE |
|
| 443 | -7x | +
- assert_matrix(covariance, mode = "numeric", ncols = nrow(covariance))+ ) |
||
| 444 | -7x | +166x |
- covariance[is.na(covariance)] <- 0+ fit <- structure("", class = "try-error")
|
|
| 445 | -7x | +166x |
- diag(covariance)[diag(covariance) == 0] <- 1+ names_all_optimizers <- names(control$optimizers) |
|
| 446 | -+ | 166x |
- # empirical is not always positive definite in some special cases of numeric singularity.+ while (is(fit, "try-error") && length(control$optimizers) > 0) {
|
|
| 447 | -7x | +170x |
- qr_res <- qr(covariance)+ fit <- fit_single_optimizer( |
|
| 448 | -7x | +170x |
- if (qr_res$rank < ncol(covariance)) {
+ tmb_data = tmb_data, |
|
| 449 | -! | +170x |
- covariance <- Matrix::nearPD(covariance)$mat+ formula_parts = formula_parts, |
|
| 450 | -+ | 170x |
- }+ control = control |
|
| 451 | -7x | +
- emp_chol <- t(chol(covariance))+ ) |
||
| 452 | -7x | +167x |
- mat <- t(solve(diag(diag(emp_chol)), emp_chol))+ if (is(fit, "try-error")) {
|
|
| 453 | -7x | +6x |
- ret <- c(log(diag(emp_chol)), mat[upper.tri(mat)])+ warning(paste0( |
|
| 454 | -7x | +6x |
- unname(ret)+ "Divergence with optimizer ", names(control$optimizers[1L]), " due to problems: ", |
|
| 455 | -+ | 6x |
- }+ toString(attr(fit, "divergence")) |
|
| 456 |
-
+ )) |
|||
| 457 |
- #' Register S3 Method+ } |
|||
| 458 | -+ | 167x |
- #' Register S3 method to a generic.+ control$optimizers <- control$optimizers[-1] |
|
| 459 |
- #'+ } |
|||
| 460 | -+ | 163x |
- #' @param pkg (`string`) name of the package name.+ if (!attr(fit, "converged")) {
|
|
| 461 | -+ | 7x |
- #' @param generic (`string`) name of the generic.+ more_optimizers <- length(control$optimizers) >= 1L |
|
| 462 | -+ | 7x |
- #' @param class (`string`) class name the function want to dispatch.+ if (more_optimizers) {
|
|
| 463 | -+ | 5x |
- #' @param envir (`environment`) the location the method is defined.+ fit <- refit_multiple_optimizers( |
|
| 464 | -+ | 5x |
- #'+ fit = fit, |
|
| 465 | -+ | 5x |
- #' @details This function is adapted from `emmeans:::register_s3_method()`.+ control = control |
|
| 466 |
- #'+ ) |
|||
| 467 |
- #' @keywords internal+ } else {
|
|||
| 468 | -+ | 2x |
- h_register_s3 <- function(pkg, generic, class, envir = parent.frame()) {
+ all_problems <- unlist( |
|
| 469 | -1x | +2x |
- assert_string(pkg)+ attributes(fit)[c("errors", "warnings")],
|
|
| 470 | -1x | +2x |
- assert_string(generic)+ use.names = FALSE |
|
| 471 | -1x | +
- assert_string(class)+ ) |
||
| 472 | -1x | +2x |
- assert_environment(envir)+ stop(paste0( |
|
| 473 | -1x | +2x |
- fun <- get(paste0(generic, ".", class), envir = envir)+ "Chosen optimizers '", toString(names_all_optimizers), "' led to problems during model fit:\n", |
|
| 474 | -1x | +2x |
- if (isNamespaceLoaded(pkg)) {
+ paste(paste0(seq_along(all_problems), ") ", all_problems), collapse = ";\n"), "\n", |
|
| 475 | -1x | +2x |
- registerS3method(generic, class, fun, envir = asNamespace(pkg))+ "Consider trying multiple or different optimizers." |
|
| 476 |
- }+ )) |
|||
| 477 | -1x | +
- setHook(packageEvent(pkg, "onLoad"), function(...) {
+ } |
||
| 478 | -! | +
- registerS3method(generic, class, fun, envir = asNamespace(pkg))+ } |
||
| 479 | -+ | 160x |
- })+ fit_msg <- attr(fit, "messages") |
|
| 480 | -+ | 160x |
- }+ if (!is.null(fit_msg)) {
|
|
| 481 | -+ | ! |
-
+ message(paste(fit_msg, collapse = "\n")) |
|
| 482 |
- #' Check if a Factor Should Drop Levels+ } |
|||
| 483 | -+ | 160x |
- #'+ fit$call <- match.call() |
|
| 484 | -+ | 160x |
- #' @param x (`vector`) vector to check.+ fit$call$formula <- formula |
|
| 485 | -+ | 160x |
- #'+ fit$method <- control$method |
|
| 486 | -+ | 160x |
- #' @keywords internal+ fit$vcov <- control$vcov |
|
| 487 | -+ | 160x |
- h_extra_levels <- function(x) {
+ if (control$vcov %in% c("Kenward-Roger", "Kenward-Roger-Linear")) {
|
|
| 488 | -1623x | +47x |
- is.factor(x) && length(levels(x)) > length(unique(x))+ fit$kr_comp <- h_get_kr_comp(fit$tmb_data, fit$theta_est) |
|
| 489 | -+ | 47x |
- }+ fit$beta_vcov_adj <- h_var_adj( |
|
| 490 | -+ | 47x |
-
+ v = fit$beta_vcov, |
|
| 491 | -+ | 47x |
- #' Drop Levels from Dataset+ w = component(fit, "theta_vcov"), |
|
| 492 | -+ | 47x |
- #' @param data (`data.frame`) data to drop levels.+ p = fit$kr_comp$P, |
|
| 493 | -+ | 47x |
- #' @param subject_var (`character`) subject variable.+ q = fit$kr_comp$Q, |
|
| 494 | -+ | 47x |
- #' @param visit_var (`character`) visit variable.+ r = fit$kr_comp$R, |
|
| 495 | -+ | 47x |
- #' @param except (`character`) variables to exclude from dropping.+ linear = (control$vcov == "Kenward-Roger-Linear") |
|
| 496 |
- #' @keywords internal+ ) |
|||
| 497 | -+ | 113x |
- h_drop_levels <- function(data, subject_var, visit_var, except) {
+ } else if (control$vcov %in% c("Empirical", "Empirical-Bias-Reduced", "Empirical-Jackknife")) {
|
|
| 498 | -262x | +31x |
- assert_data_frame(data)+ empirical_comp <- h_get_empirical( |
|
| 499 | -262x | +31x |
- assert_character(subject_var)+ fit$tmb_data, fit$theta_est, fit$beta_est, fit$beta_vcov, control$vcov |
|
| 500 | -262x | +
- assert_character(visit_var)+ ) |
||
| 501 | -262x | +31x |
- assert_character(except, null.ok = TRUE)+ fit$beta_vcov_adj <- empirical_comp$cov |
|
| 502 | -262x | +31x |
- all_cols <- colnames(data)+ fit$empirical_df_mat <- empirical_comp$df_mat |
|
| 503 | -262x | +31x |
- to_drop <- vapply(+ dimnames(fit$beta_vcov_adj) <- dimnames(fit$beta_vcov) |
|
| 504 | -262x | +82x |
- data,+ } else if (identical(control$vcov, "Asymptotic")) {
|
|
| 505 | -262x | +
- h_extra_levels,+ # Note that we only need the Jacobian list under Asymptotic covariance method, |
||
| 506 | -262x | +
- logical(1L)+ # cf. the Satterthwaite vignette. |
||
| 507 | -+ | 82x |
- )+ if (identical(fit$method, "Satterthwaite")) {
|
|
| 508 | -262x | +80x |
- to_drop <- all_cols[to_drop]+ fit$jac_list <- h_jac_list(fit$tmb_data, fit$theta_est, fit$beta_vcov) |
|
| 509 |
- # only drop levels for those not defined in excep and not in visit_var.+ } |
|||
| 510 | -262x | +
- to_drop <- setdiff(to_drop, c(visit_var, except))+ } else {
|
||
| 511 | -262x | +! |
- data[to_drop] <- lapply(data[to_drop], droplevels)+ stop("Unrecognized coefficent variance-covariance method!")
|
|
| 512 | - |
- # subject var are always dropped and no message given.- |
- ||
| 513 | -262x | -
- dropped <- setdiff(to_drop, subject_var)- |
- ||
| 514 | -262x | -
- if (length(dropped) > 0) {
- |
- ||
| 515 | -3x | -
- message(- |
- ||
| 516 | -3x | -
- "Some factor levels are dropped due to singular design matrix: ",- |
- ||
| 517 | -3x | -
- toString(dropped)- |
- ||
| 518 | -- |
- )- |
- ||
| 519 | -
} |
|||
| 520 | -262x | -
- data- |
- ||
| 521 | -- |
- }- |
- ||
| 522 | +513 | |||
| 523 | -- |
- #' Warn if TMB is Configured to Optimize Instantly- |
- ||
| 524 | -- |
- #'- |
- ||
| 525 | -- |
- #' This function checks the TMB configuration for the `optimize.instantly` setting.- |
- ||
| 526 | -- |
- #' If it is set to `TRUE`, a warning is issued indicating that this may lead to- |
- ||
| 527 | -- |
- #' unreproducible results.- |
- ||
| 528 | -- |
- #'- |
- ||
| 529 | -- |
- #' @return No return value, called for side effects.- |
- ||
| 530 | -- |
- #' @keywords internal- |
- ||
| 531 | -- |
- h_tmb_warn_optimization <- function() {
- |
- ||
| 532 | -247x | -
- tmb_config <- TMB::config("optimize.instantly", DLL = "mmrm")
- |
- ||
| 533 | -247x | -
- if (tmb_config$optimize.instantly) {
- |
- ||
| 534 | -1x | -
- msg <- paste(- |
- ||
| 535 | -1x | -
- "TMB is configured to optimize instantly, this may lead to unreproducible results.",- |
- ||
| 536 | -1x | -
- "To disable this behavior, use `TMB::config(optimize.instantly = 0)`.",- |
- ||
| 537 | -1x | -
- sep = "\n"- |
- ||
| 538 | -+ | 514 | +160x |
- )+ class(fit) <- c("mmrm", class(fit))
|
| 539 | -1x | -
- rlang::warn(msg, .frequency = "once", .frequency_id = "tmb_warn_optimization")- |
- ||
| 540 | -+ | 515 | +160x |
- }+ fit |
| 541 | +516 |
}@@ -14343,14 +13933,14 @@ mmrm coverage - 97.08% |
| 1 |
- #' Extract Formula Terms used for Covariance Structure Definition+ #' Processing the Formula for `TMB` Fit |
||
| 3 |
- #' @param f (`formula`)\cr a formula from which covariance terms should be+ #' @param formula (`formula`)\cr Original formula. |
||
| 4 |
- #' extracted.+ #' @param covariance (`cov_struct`)\cr A covariance structure from which |
||
| 5 |
- #'+ #' additional formula parts should be added. |
||
| 6 |
- #' @return A list of covariance structure expressions found in `f`.+ #' |
||
| 7 |
- #'+ #' @return List of class `mmrm_tmb_formula_parts` with elements: |
||
| 8 |
- #' @importFrom stats terms+ #' |
||
| 9 |
- #' @keywords internal+ #' - `formula`: the original input. |
||
| 10 |
- h_extract_covariance_terms <- function(f) {
+ #' - `model_formula`: `formula` with the covariance term is removed. |
||
| 11 | -290x | +
- specials <- cov_types(c("abbr", "habbr"))
+ #' - `model_formula`: `formula` with the covariance term removed. |
|
| 12 | -290x | +
- terms <- stats::terms(formula_rhs(f), specials = specials)+ #' - `full_formula`: same as `model_formula` but includes the covariance |
|
| 13 | -290x | +
- covariance_terms <- Filter(length, attr(terms, "specials"))+ #' structure's subject, visit and (optionally) group variables. |
|
| 14 | -290x | +
- variables <- attr(terms, "variables")+ #' - `cov_type`: `string` with covariance term type (e.g. `"us"`). |
|
| 15 | -290x | +
- lapply(covariance_terms, function(i) variables[[i + 1]])+ #' - `is_spatial`: `flag` indicator of whether the covariance structure is |
|
| 16 |
- }+ #' spatial |
||
| 17 |
-
+ #' - `visit_var`: `character` with the visit variable name. |
||
| 18 |
- #' Drop Formula Terms used for Covariance Structure Definition+ #' - `subject_var`: `string` with the subject variable name. |
||
| 19 |
- #'+ #' - `group_var`: `string` with the group variable name. If no group specified, |
||
| 20 |
- #' @param f (`formula`)\cr a formula from which covariance terms should be+ #' this element is `NULL`. |
||
| 21 |
- #' dropped.+ #' - `model_var`: `character` with the variables names of the formula, except `subject_var`. |
||
| 23 |
- #' @return The formula without accepted covariance terms.+ #' @keywords internal |
||
| 24 |
- #'+ h_mmrm_tmb_formula_parts <- function( |
||
| 25 |
- #' @details `terms` is used and it will preserve the environment attribute.+ formula, |
||
| 26 |
- #' This ensures the returned formula and the input formula have the same environment.+ covariance = as.cov_struct(formula, warn_partial = FALSE)) {
|
||
| 27 | -+ | 269x |
- #' @importFrom stats terms drop.terms+ assert_formula(formula) |
| 28 | -+ | 269x |
- #' @keywords internal+ assert_true(identical(length(formula), 3L)) |
| 29 |
- h_drop_covariance_terms <- function(f) {
+
|
||
| 30 | -273x | +269x |
- specials <- cov_types(c("abbr", "habbr"))
+ model_formula <- h_drop_covariance_terms(formula) |
| 32 | -273x | +269x |
- terms <- stats::terms(f, specials = specials)+ structure( |
| 33 | -273x | +269x |
- covariance_terms <- Filter(Negate(is.null), attr(terms, "specials"))+ list( |
| 34 | -+ | 269x |
-
+ formula = formula, |
| 35 | -+ | 269x |
- # if no covariance terms were found, return original formula+ model_formula = model_formula, |
| 36 | -273x | +269x |
- if (length(covariance_terms) == 0) {
+ full_formula = h_add_covariance_terms(model_formula, covariance), |
| 37 | -6x | +269x |
- return(f)+ cov_type = tmb_cov_type(covariance), |
| 38 | -+ | 269x |
- }+ is_spatial = covariance$type == "sp_exp", |
| 39 | -267x | +269x |
- if (length(f) != 3) {
+ visit_var = covariance$visits, |
| 40 | -1x | +269x |
- update_str <- "~ . -"+ subject_var = covariance$subject, |
| 41 | -+ | 269x |
- } else {
+ group_var = if (length(covariance$group) < 1) NULL else covariance$group, |
| 42 | -266x | +269x |
- update_str <- ". ~ . -"+ model_var = setdiff(all.vars(formula[[3]]), covariance$subject) |
| 43 |
- }+ ), |
||
| 44 | -267x | +269x |
- stats::update(+ class = "mmrm_tmb_formula_parts" |
| 45 | -267x | +
- f,+ ) |
|
| 46 | -267x | +
- stats::as.formula(paste(update_str, deparse(attr(terms, "variables")[[covariance_terms[[1]] + 1]])))+ } |
|
| 47 |
- )+ |
||
| 48 |
- }+ #' Data for `TMB` Fit |
||
| 49 |
-
+ #' |
||
| 50 |
- #' Add Individual Covariance Variables As Terms to Formula+ #' @param formula_parts (`mmrm_tmb_formula_parts`)\cr list with formula parts |
||
| 51 |
- #'+ #' from [h_mmrm_tmb_formula_parts()]. |
||
| 52 |
- #' @param f (`formula`)\cr a formula to which covariance structure terms should+ #' @param data (`data.frame`)\cr which contains variables used in `formula_parts`. |
||
| 53 |
- #' be added.+ #' @param weights (`vector`)\cr weights to be used in the fitting process. |
||
| 54 |
- #' @param covariance (`cov_struct`)\cr a covariance structure object from which+ #' @param reml (`flag`)\cr whether restricted maximum likelihood (REML) estimation is used, |
||
| 55 |
- #' additional variables should be sourced.+ #' otherwise maximum likelihood (ML) is used. |
||
| 56 |
- #'+ #' @param singular (`string`)\cr choices of method deal with rank-deficient matrices. "error" to |
||
| 57 |
- #' @return A new formula with included covariance terms.+ #' stop the function return the error, "drop" to drop these columns, and "keep" to keep all the columns. |
||
| 58 |
- #'+ #' @param drop_visit_levels (`flag`)\cr whether to drop levels for visit variable, if visit variable is a factor. |
||
| 59 |
- #' @details [stats::update()] is used to append the covariance structure and the environment+ #' @param allow_na_response (`flag`)\cr whether NA in response is allowed. |
||
| 60 |
- #' attribute will not be changed. This ensures the returned formula and the input formula+ #' @param drop_levels (`flag`)\cr whether drop levels for covariates. If not dropped could lead to singular matrix. |
||
| 61 |
- #' have the same environment.+ #' |
||
| 62 |
- #'+ #' @return List of class `mmrm_tmb_data` with elements: |
||
| 63 |
- #' @keywords internal+ #' - `full_frame`: `data.frame` with `n` rows containing all variables needed in the model. |
||
| 64 |
- h_add_covariance_terms <- function(f, covariance) {
+ #' - `data`: `data.frame` of input dataset. |
||
| 65 | -271x | +
- cov_terms <- with(covariance, c(subject, visits, group))+ #' - `x_matrix`: `matrix` with `n` rows and `p` columns specifying the overall design matrix. |
|
| 66 | -265x | +
- cov_terms <- paste(cov_terms, collapse = " + ")+ #' - `x_cols_aliased`: `logical` with potentially more than `p` elements indicating which |
|
| 67 | -265x | +
- stats::update(f, stats::as.formula(paste(". ~ . + ", cov_terms)))
+ #' columns in the original design matrix have been left out to obtain a full rank |
|
| 68 |
- }+ #' `x_matrix`. |
||
| 69 |
-
+ #' - `y_vector`: length `n` `numeric` specifying the overall response vector. |
||
| 70 |
- #' Add Formula Terms with Character+ #' - `weights_vector`: length `n` `numeric` specifying the weights vector. |
||
| 71 |
- #'+ #' - `n_visits`: `int` with the number of visits, which is the dimension of the |
||
| 72 |
- #' Add formula terms from the original formula with character representation.+ #' covariance matrix. |
||
| 73 |
- #'+ #' - `n_subjects`: `int` with the number of subjects. |
||
| 74 |
- #' @param f (`formula`)\cr a formula to be updated.+ #' - `subject_zero_inds`: length `n_subjects` `integer` containing the zero-based start |
||
| 75 |
- #' @param adds (`character`)\cr representation of elements to be added.+ #' indices for each subject. |
||
| 76 |
- #' @param drop_response (`flag`)\cr whether response should be dropped.+ #' - `subject_n_visits`: length `n_subjects` `integer` containing the number of |
||
| 77 |
- #'+ #' observed visits for each subjects. So the sum of this vector equals `n`. |
||
| 78 |
- #' @details Elements in `adds` will be added from the formula, while the environment+ #' - `cov_type`: `string` value specifying the covariance type. |
||
| 79 |
- #' of the formula is unchanged. If `adds` is `NULL` or `character(0)`, the formula is+ #' - `is_spatial_int`: `int` specifying whether the covariance structure is spatial(1) or not(0). |
||
| 80 |
- #' unchanged.+ #' - `reml`: `int` specifying whether REML estimation is used (1), otherwise ML (0). |
||
| 81 |
- #' @return A new formula with elements in `drops` removed.+ #' - `subject_groups`: `factor` specifying the grouping for each subject. |
||
| 82 |
- #'+ #' - `n_groups`: `int` with the number of total groups |
||
| 83 |
- #' @keywords internal+ #' |
||
| 84 |
- h_add_terms <- function(f, adds, drop_response = FALSE) {
+ #' @details Note that the `subject_var` must not be factor but can also be character. |
||
| 85 | -599x | +
- assert_character(adds, null.ok = TRUE)+ #' If it is character, then it will be converted to factor internally. Here |
|
| 86 | -599x | +
- if (length(adds) > 0L) {
+ #' the levels will be the unique values, sorted alphabetically and numerically if there |
|
| 87 | -321x | +
- add_terms <- stats::as.formula(sprintf(". ~ . + %s", paste(adds, collapse = "+")))
+ #' is a common string prefix of numbers in the character elements. For full control |
|
| 88 | -321x | +
- f <- stats::update(f, add_terms)+ #' on the order please use a factor. |
|
| 89 |
- }+ #' |
||
| 90 | -599x | +
- if (drop_response && length(f) == 3L) {
+ #' @keywords internal |
|
| 91 | -35x | +
- f[[2]] <- NULL+ h_mmrm_tmb_data <- function(formula_parts, |
|
| 92 |
- }+ data, |
||
| 93 | -599x | +
- f+ weights, |
|
| 94 |
- }+ reml, |
| 1 | +95 |
- #' Methods for `mmrm_tmb` Objects+ singular = c("drop", "error", "keep"),
|
||
| 2 | +96 |
- #'+ drop_visit_levels, |
||
| 3 | +97 |
- #' @description `r lifecycle::badge("experimental")`
+ allow_na_response = FALSE, |
||
| 4 | +98 |
- #'+ drop_levels = TRUE, |
||
| 5 | +99 |
- #' @param object (`mmrm_tmb`)\cr the fitted MMRM object.+ xlev = NULL, |
||
| 6 | +100 |
- #' @param x (`mmrm_tmb`)\cr same as `object`.+ contrasts = NULL) {
|
||
| 7 | -+ | |||
| 101 | +311x |
- #' @param formula (`mmrm_tmb`)\cr same as `object`.+ assert_class(formula_parts, "mmrm_tmb_formula_parts") |
||
| 8 | -+ | |||
| 102 | +311x |
- #' @param complete (`flag`)\cr whether to include potential non-estimable+ assert_data_frame(data) |
||
| 9 | -+ | |||
| 103 | +311x |
- #' coefficients.+ varname <- formula_parts[grepl("_var", names(formula_parts))]
|
||
| 10 | -+ | |||
| 104 | +311x |
- #' @param ... mostly not used;+ assert_names( |
||
| 11 | -+ | |||
| 105 | +311x |
- #' Exception is `model.matrix()` passing `...` to the default method.+ names(data), |
||
| 12 | -+ | |||
| 106 | +311x |
- #' @return Depends on the method, see Functions.+ must.include = unlist(varname, use.names = FALSE) |
||
| 13 | +107 |
- #'+ ) |
||
| 14 | -+ | |||
| 108 | +311x |
- #' @name mmrm_tmb_methods+ assert_true(is.factor(data[[formula_parts$subject_var]]) || is.character(data[[formula_parts$subject_var]])) |
||
| 15 | -+ | |||
| 109 | +311x |
- #'+ assert_numeric(weights, len = nrow(data)) |
||
| 16 | -+ | |||
| 110 | +311x |
- #' @seealso [`mmrm_methods`], [`mmrm_tidiers`] for additional methods.+ assert_flag(reml) |
||
| 17 | -+ | |||
| 111 | +311x |
- #'+ singular <- match.arg(singular) |
||
| 18 | -+ | |||
| 112 | +311x |
- #' @examples+ assert_flag(drop_visit_levels) |
||
| 19 | +113 |
- #' formula <- FEV1 ~ RACE + SEX + ARMCD * AVISIT + us(AVISIT | USUBJID)+ |
||
| 20 | -+ | |||
| 114 | +311x |
- #' object <- fit_mmrm(formula, fev_data, weights = rep(1, nrow(fev_data)))+ if (is.character(data[[formula_parts$subject_var]])) {
|
||
| 21 | -+ | |||
| 115 | +5x |
- NULL+ data[[formula_parts$subject_var]] <- factor( |
||
| 22 | -+ | |||
| 116 | +5x |
-
+ data[[formula_parts$subject_var]], |
||
| 23 | -+ | |||
| 117 | +5x |
- #' @describeIn mmrm_tmb_methods obtains the estimated coefficients.+ levels = stringr::str_sort(unique(data[[formula_parts$subject_var]]), numeric = TRUE) |
||
| 24 | +118 |
- #' @importFrom stats coef+ ) |
||
| 25 | +119 |
- #' @exportS3Method+ } |
||
| 26 | -+ | |||
| 120 | +311x |
- #' @examples+ data_order <- if (formula_parts$is_spatial) {
|
||
| 27 | -+ | |||
| 121 | +16x |
- #' # Estimated coefficients:+ order(data[[formula_parts$subject_var]]) |
||
| 28 | +122 |
- #' coef(object)+ } else {
|
||
| 29 | -+ | |||
| 123 | +295x |
- coef.mmrm_tmb <- function(object, complete = TRUE, ...) {
+ subject_visit_data <- data[, c(formula_parts$subject_var, formula_parts$visit_var)] |
||
| 30 | -58x | +124 | +295x |
- assert_flag(complete)+ is_duplicated <- duplicated(subject_visit_data) |
| 31 | -58x | +125 | +295x |
- nm <- if (complete) "beta_est_complete" else "beta_est"+ if (any(is_duplicated)) {
|
| 32 | -58x | +126 | +1x |
- component(object, name = nm)+ stop( |
| 33 | -+ | |||
| 127 | +1x |
- }+ "time points have to be unique for each subject, detected following duplicates in data:\n", |
||
| 34 | -+ | |||
| 128 | +1x |
-
+ paste(utils::capture.output(print(subject_visit_data[is_duplicated, ])), collapse = "\n") |
||
| 35 | +129 |
- #' @describeIn mmrm_tmb_methods obtains the fitted values.+ ) |
||
| 36 | +130 |
- #' @importFrom stats fitted+ } |
||
| 37 | -+ | |||
| 131 | +294x |
- #' @exportS3Method+ order(data[[formula_parts$subject_var]], data[[formula_parts$visit_var]]) |
||
| 38 | +132 |
- #' @examples+ } |
||
| 39 | -+ | |||
| 133 | +310x |
- #' # Fitted values:+ if (identical(formula_parts$is_spatial, FALSE)) {
|
||
| 40 | -+ | |||
| 134 | +294x |
- #' fitted(object)+ h_confirm_large_levels(length(levels(data[[formula_parts$visit_var]]))) |
||
| 41 | +135 |
- fitted.mmrm_tmb <- function(object, ...) {
+ } |
||
| 42 | -19x | +136 | +309x |
- fitted_col <- component(object, "x_matrix") %*% component(object, "beta_est")+ data <- data[data_order, ] |
| 43 | -19x | +137 | +309x |
- fitted_col[, 1L, drop = TRUE]+ weights <- weights[data_order] |
| 44 | -+ | |||
| 138 | +309x |
- }+ data <- data.frame(data, weights) |
||
| 45 | +139 |
-
+ # Weights is always the last column. |
||
| 46 | -+ | |||
| 140 | +309x |
- #' @describeIn mmrm_tmb_methods predict conditional means for new data;+ weights_name <- colnames(data)[ncol(data)] |
||
| 47 | +141 |
- #' optionally with standard errors and confidence or prediction intervals.+ # If `y` is allowed to be NA, then first replace y with 1:n, then replace it with original y. |
||
| 48 | -+ | |||
| 142 | +309x |
- #' Returns a vector of predictions if `se.fit == FALSE` and+ if (!allow_na_response) {
|
||
| 49 | -+ | |||
| 143 | +259x |
- #' `interval == "none"`; otherwise it returns a data.frame with multiple+ h_warn_na_action() |
||
| 50 | +144 |
- #' columns and one row per input data row.+ } |
||
| 51 | -+ | |||
| 145 | +309x |
- #'+ full_frame <- eval( |
||
| 52 | -+ | |||
| 146 | +309x |
- #' @param newdata (`data.frame`)\cr optional new data, otherwise data from `object` is used.+ bquote(stats::model.frame( |
||
| 53 | -+ | |||
| 147 | +309x |
- #' @param se.fit (`flag`)\cr indicator if standard errors are required.+ formula_parts$full_formula, |
||
| 54 | -+ | |||
| 148 | +309x |
- #' @param interval (`string`)\cr type of interval calculation. Can be abbreviated.+ data = data, |
||
| 55 | -+ | |||
| 149 | +309x |
- #' @param level (`number`)\cr tolerance/confidence level.+ weights = .(as.symbol(weights_name)), |
||
| 56 | -+ | |||
| 150 | +309x |
- #' @param nsim (`count`)\cr number of simulations to use.+ na.action = "na.pass", |
||
| 57 | -+ | |||
| 151 | +309x |
- #' @param conditional (`flag`)\cr indicator if the prediction is conditional on the observation or not.+ xlev = xlev |
||
| 58 | +152 |
- #'+ )) |
||
| 59 | +153 |
- #' @importFrom stats predict+ ) |
||
| 60 | -+ | |||
| 154 | +309x |
- #' @exportS3Method+ if (drop_levels) {
|
||
| 61 | -+ | |||
| 155 | +261x |
- #'+ full_frame <- h_drop_levels(full_frame, formula_parts$subject_var, formula_parts$visit_var, names(xlev)) |
||
| 62 | +156 |
- #' @examples+ } |
||
| 63 | -+ | |||
| 157 | +309x |
- #' predict(object, newdata = fev_data)+ has_response <- !identical(attr(attr(full_frame, "terms"), "response"), 0L) |
||
| 64 | -+ | |||
| 158 | +309x |
- predict.mmrm_tmb <- function(object,+ keep_ind <- if (allow_na_response && has_response) {
|
||
| 65 | +159 |
- newdata,+ # Note that response is always the first column if there is response. |
||
| 66 | -+ | |||
| 160 | +50x |
- se.fit = FALSE, # nolint+ stats::complete.cases(full_frame[, -1L, drop = FALSE]) |
||
| 67 | +161 |
- interval = c("none", "confidence", "prediction"),
+ } else {
|
||
| 68 | -+ | |||
| 162 | +259x |
- level = 0.95,+ stats::complete.cases(full_frame) |
||
| 69 | +163 |
- nsim = 1000L,+ } |
||
| 70 | -+ | |||
| 164 | +309x |
- conditional = FALSE,+ full_frame <- full_frame[keep_ind, ] |
||
| 71 | -+ | |||
| 165 | +309x |
- ...) {
+ if (drop_visit_levels && !formula_parts$is_spatial && h_extra_levels(full_frame[[formula_parts$visit_var]])) {
|
||
| 72 | -45x | +166 | +3x |
- if (missing(newdata)) {
+ visit_vec <- full_frame[[formula_parts$visit_var]] |
| 73 | -8x | +167 | +3x |
- newdata <- object$data+ old_levels <- levels(visit_vec) |
| 74 | -+ | |||
| 168 | +3x |
- }+ full_frame[[formula_parts$visit_var]] <- droplevels(visit_vec) |
||
| 75 | -45x | +169 | +3x |
- assert_data_frame(newdata)+ new_levels <- levels(full_frame[[formula_parts$visit_var]]) |
| 76 | -45x | +170 | +3x |
- orig_row_names <- row.names(newdata)+ dropped <- setdiff(old_levels, new_levels) |
| 77 | -45x | +171 | +3x |
- assert_flag(se.fit)+ message( |
| 78 | -45x | +172 | +3x |
- assert_number(level, lower = 0, upper = 1)+ "In ", formula_parts$visit_var, " there are dropped visits: ", toString(dropped), |
| 79 | -45x | +173 | +3x |
- assert_count(nsim, positive = TRUE)+ ".\n Additional attributes including contrasts are lost.\n", |
| 80 | -45x | +174 | +3x |
- assert_flag(conditional)+ "To avoid this behavior, make sure use `drop_visit_levels = FALSE`."+ |
+
| 175 | ++ |
+ )+ |
+ ||
| 176 | ++ |
+ } |
||
| 81 | -45x | +177 | +309x |
- interval <- match.arg(interval)+ is_factor_col <- vapply(full_frame, is.factor, FUN.VALUE = TRUE) |
| 82 | -45x | +178 | +309x |
- formula_parts <- object$formula_parts+ is_factor_col <- intersect(names(is_factor_col)[is_factor_col], all.vars(formula_parts$model_formula)) |
| 83 | -45x | +179 | +309x |
- if (any(object$tmb_data$x_cols_aliased)) {
+ x_matrix <- stats::model.matrix( |
| 84 | -1x | +180 | +309x |
- warning(+ formula_parts$model_formula, |
| 85 | -1x | +181 | +309x |
- "In fitted object there are co-linear variables and therefore dropped terms, ",+ data = full_frame, |
| 86 | -1x | +182 | +309x |
- "and this could lead to incorrect prediction on new data."+ contrasts.arg = h_default_value(contrasts, lapply(full_frame[is_factor_col], contrasts)) |
| 87 | +183 |
- )+ ) |
||
| 88 | -+ | |||
| 184 | +308x |
- }+ x_cols_aliased <- stats::setNames(rep(FALSE, ncol(x_matrix)), nm = colnames(x_matrix)) |
||
| 89 | -45x | +185 | +308x |
- colnames <- names(Filter(isFALSE, object$tmb_data$x_cols_aliased))+ qr_x_mat <- qr(x_matrix) |
| 90 | -45x | +186 | +308x |
- if (!conditional && interval %in% c("none", "confidence")) {
+ if (qr_x_mat$rank < ncol(x_matrix)) {
|
| 91 | -+ | |||
| 187 | +23x |
- # model.matrix always return a complete matrix (no NA allowed)+ cols_to_drop <- utils::tail(qr_x_mat$pivot, ncol(x_matrix) - qr_x_mat$rank) |
||
| 92 | -27x | +188 | +23x |
- x_mat <- stats::model.matrix(object, data = newdata, use_response = FALSE)[, colnames, drop = FALSE]+ if (identical(singular, "error")) {
|
| 93 | -27x | +189 | +1x |
- x_mat_full <- matrix(+ stop( |
| 94 | -27x | +190 | +1x |
- NA,+ "design matrix only has rank ", qr_x_mat$rank, " and ", length(cols_to_drop), |
| 95 | -27x | +191 | +1x |
- nrow = nrow(newdata), ncol = ncol(x_mat),+ " columns (", toString(colnames(x_matrix)[cols_to_drop]), ") could be dropped",
|
| 96 | -27x | +192 | +1x |
- dimnames = list(row.names(newdata), colnames(x_mat))+ " to achieve full rank ", ncol(x_matrix), " by using `accept_singular = TRUE`" |
| 97 | +193 |
- )+ ) |
||
| 98 | -27x | +194 | +22x |
- x_mat_full[row.names(x_mat), ] <- x_mat+ } else if (identical(singular, "drop")) {
|
| 99 | -27x | +195 | +11x |
- predictions <- (x_mat_full %*% component(object, "beta_est"))[, 1]+ assign_attr <- attr(x_matrix, "assign") |
| 100 | -27x | +196 | +11x |
- predictions_raw <- stats::setNames(rep(NA_real_, nrow(newdata)), row.names(newdata))+ contrasts_attr <- attr(x_matrix, "contrasts") |
| 101 | -27x | +197 | +11x |
- predictions_raw[names(predictions)] <- predictions+ x_matrix <- x_matrix[, -cols_to_drop, drop = FALSE] |
| 102 | -27x | +198 | +11x |
- if (identical(interval, "none")) {
+ x_cols_aliased[cols_to_drop] <- TRUE |
| 103 | -20x | +199 | +11x |
- return(predictions_raw)+ attr(x_matrix, "assign") <- assign_attr[-cols_to_drop] |
| 104 | -+ | |||
| 200 | +11x |
- }+ attr(x_matrix, "contrasts") <- contrasts_attr |
||
| 105 | -7x | +|||
| 201 | +
- se <- switch(interval,+ } |
|||
| 106 | +202 |
- # can be NA if there are aliased cols+ } |
||
| 107 | -7x | +203 | +307x |
- "confidence" = diag(x_mat_full %*% component(object, "beta_vcov") %*% t(x_mat_full)),+ y_vector <- if (has_response) {
|
| 108 | -7x | +204 | +307x |
- "none" = NA_real_+ as.numeric(stats::model.response(full_frame)) |
| 109 | +205 |
- )+ } else {
|
||
| 110 | -7x | +|||
| 206 | +! |
- res <- cbind(+ rep(NA_real_, nrow(full_frame)) |
||
| 111 | -7x | +|||
| 207 | +
- fit = predictions, se = se,+ } |
|||
| 112 | -7x | +208 | +307x |
- lwr = predictions - stats::qnorm(1 - level / 2) * se, upr = predictions + stats::qnorm(1 - level / 2) * se+ weights_vector <- as.numeric(stats::model.weights(full_frame)) |
| 113 | -+ | |||
| 209 | +307x |
- )+ n_subjects <- length(unique(full_frame[[formula_parts$subject_var]])) |
||
| 114 | -7x | +210 | +307x |
- if (!se.fit) {
+ subject_zero_inds <- which(!duplicated(full_frame[[formula_parts$subject_var]])) - 1L |
| 115 | -1x | +211 | +307x |
- res <- res[, setdiff(colnames(res), "se")]+ subject_n_visits <- c(utils::tail(subject_zero_inds, -1L), nrow(full_frame)) - subject_zero_inds |
| 116 | +212 |
- }+ # It is possible that `subject_var` is factor with more levels (and this does not affect fit)+ |
+ ||
| 213 | ++ |
+ # so no check is needed for `subject_visits`. |
||
| 117 | -7x | +214 | +307x |
- res_raw <- matrix(+ assert_true(all(subject_n_visits > 0)) |
| 118 | -7x | +215 | +307x |
- NA_real_,+ if (!is.null(formula_parts$group_var)) {
|
| 119 | -7x | +216 | +41x |
- ncol = ncol(res), nrow = nrow(newdata),+ assert_factor(data[[formula_parts$group_var]]) |
| 120 | -7x | +217 | +41x |
- dimnames = list(row.names(newdata), colnames(res))+ subject_groups <- full_frame[[formula_parts$group_var]][subject_zero_inds + 1L]+ |
+
| 218 | +41x | +
+ n_groups <- nlevels(subject_groups) |
||
| 121 | +219 |
- )+ } else {
|
||
| 122 | -7x | +220 | +266x |
- res_raw[row.names(res), ] <- res+ subject_groups <- factor(rep(0L, n_subjects)) |
| 123 | -7x | +221 | +266x |
- return(res_raw)+ n_groups <- 1L |
| 124 | +222 |
} |
||
| 125 | -18x | +223 | +307x |
- tmb_data <- h_mmrm_tmb_data(+ coordinates <- full_frame[, formula_parts$visit_var, drop = FALSE] |
| 126 | -18x | +224 | +307x |
- formula_parts, newdata,+ if (formula_parts$is_spatial) {
|
| 127 | -18x | +225 | +16x |
- weights = rep(1, nrow(newdata)),+ lapply(coordinates, assert_numeric) |
| 128 | -18x | +226 | +16x |
- reml = TRUE,+ coordinates_matrix <- as.matrix(coordinates) |
| 129 | -18x | +227 | +16x |
- singular = "keep",- |
-
| 130 | -18x | -
- drop_visit_levels = FALSE,- |
- ||
| 131 | -18x | -
- allow_na_response = TRUE,- |
- ||
| 132 | -18x | -
- drop_levels = FALSE,- |
- ||
| 133 | -18x | -
- xlev = component(object, "xlev"),- |
- ||
| 134 | -18x | -
- contrasts = component(object, "contrasts")+ n_visits <- max(subject_n_visits) |
||
| 135 | +228 |
- )+ } else {
|
||
| 136 | -18x | +229 | +291x |
- tmb_data$x_matrix <- tmb_data$x_matrix[, colnames, drop = FALSE]+ assert(identical(ncol(coordinates), 1L)) |
| 137 | -18x | +230 | +291x |
- predictions <- h_get_prediction(+ assert_factor(coordinates[[1L]]) |
| 138 | -18x | +231 | +291x |
- tmb_data, object$theta_est, object$beta_est, component(object, "beta_vcov")+ coordinates_matrix <- as.matrix(as.integer(coordinates[[1L]]) - 1, ncol = 1) |
| 139 | -18x | +232 | +291x |
- )$prediction+ n_visits <- nlevels(coordinates[[1L]]) |
| 140 | -18x | +233 | +291x |
- res <- cbind(fit = rep(NA_real_, nrow(newdata)))+ assert_true(all(subject_n_visits <= n_visits)) |
| 141 | -18x | +|||
| 234 | +
- new_order <- match(row.names(tmb_data$full_frame), orig_row_names)+ } |
|||
| 142 | -18x | +235 | +307x |
- res[new_order, "fit"] <- predictions[, "fit"]+ structure( |
| 143 | -18x | +236 | +307x |
- se <- switch(interval,+ list( |
| 144 | -18x | +237 | +307x |
- "confidence" = sqrt(predictions[, "conf_var"]),+ full_frame = full_frame, |
| 145 | -18x | +238 | +307x |
- "prediction" = sqrt(h_get_prediction_variance(object, nsim, tmb_data)),+ data = data, |
| 146 | -18x | +239 | +307x |
- "none" = NULL+ x_matrix = x_matrix, |
| 147 | -+ | |||
| 240 | +307x |
- )+ x_cols_aliased = x_cols_aliased, |
||
| 148 | -18x | +241 | +307x |
- if (interval != "none") {
+ coordinates = coordinates_matrix, |
| 149 | -7x | +242 | +307x |
- res <- cbind(+ y_vector = y_vector, |
| 150 | -7x | +243 | +307x |
- res,+ weights_vector = weights_vector, |
| 151 | -7x | +244 | +307x |
- se = NA_real_+ n_visits = n_visits, |
| 152 | -+ | |||
| 245 | +307x |
- )+ n_subjects = n_subjects, |
||
| 153 | -7x | +246 | +307x |
- res[new_order, "se"] <- se+ subject_zero_inds = subject_zero_inds, |
| 154 | -7x | +247 | +307x |
- alpha <- 1 - level+ subject_n_visits = subject_n_visits, |
| 155 | -7x | +248 | +307x |
- z <- stats::qnorm(1 - alpha / 2) * res[, "se"]+ cov_type = formula_parts$cov_type, |
| 156 | -7x | +249 | +307x |
- res <- cbind(+ is_spatial_int = as.integer(formula_parts$is_spatial), |
| 157 | -7x | +250 | +307x |
- res,+ reml = as.integer(reml), |
| 158 | -7x | +251 | +307x |
- lwr = res[, "fit"] - z,+ subject_groups = subject_groups, |
| 159 | -7x | +252 | +307x |
- upr = res[, "fit"] + z+ n_groups = n_groups |
| 160 | +253 |
- )+ ), |
||
| 161 | -7x | -
- if (!se.fit) {
- |
- ||
| 162 | -! | +254 | +307x |
- res <- res[, setdiff(colnames(res), "se")]+ class = "mmrm_tmb_data" |
| 163 | +255 |
- }+ ) |
||
| 164 | +256 |
- }+ } |
||
| 165 | +257 |
- # Use original names.- |
- ||
| 166 | -18x | -
- row.names(res) <- orig_row_names- |
- ||
| 167 | -18x | -
- if (ncol(res) == 1) {
- |
- ||
| 168 | -11x | -
- res <- res[, "fit"]+ |
||
| 169 | +258 |
- }- |
- ||
| 170 | -18x | -
- return(res)+ #' Start Parameters for `TMB` Fit |
||
| 171 | +259 |
- }+ #' |
||
| 172 | +260 |
-
+ #' @param formula_parts (`mmrm_tmb_formula_parts`)\cr produced by |
||
| 173 | +261 |
- #' Get Prediction+ #' [h_mmrm_tmb_formula_parts()]. |
||
| 174 | +262 |
- #'+ #' @param tmb_data (`mmrm_tmb_data`)\cr produced by [h_mmrm_tmb_data()]. |
||
| 175 | +263 |
- #' @description Get predictions with given `data`, `theta`, `beta`, `beta_vcov`.+ #' @param start (`numeric` or `NULL`)\cr optional start values for variance |
||
| 176 | +264 |
- #'+ #' parameters. |
||
| 177 | +265 |
- #' @details See `predict` function in `predict.cpp` which is called internally.+ #' @param n_groups (`int`)\cr number of groups. |
||
| 178 | +266 |
- #'+ #' @return List with element `theta` containing the start values for the variance |
||
| 179 | +267 |
- #' @param tmb_data (`mmrm_tmb_data`)\cr object.+ #' parameters. |
||
| 180 | +268 |
- #' @param theta (`numeric`)\cr theta value.+ #' |
||
| 181 | +269 |
- #' @param beta (`numeric`)\cr beta value.+ #' @keywords internal |
||
| 182 | +270 |
- #' @param beta_vcov (`matrix`)\cr beta_vcov matrix.+ h_mmrm_tmb_parameters <- function(formula_parts, |
||
| 183 | +271 |
- #'+ tmb_data, |
||
| 184 | +272 |
- #' @return List with:+ start, |
||
| 185 | +273 |
- #' - `prediction`: Matrix with columns `fit`, `conf_var`, and `var`.+ n_groups = 1L) {
|
||
| 186 | -+ | |||
| 274 | +264x |
- #' - `covariance`: List with subject specific covariance matrices.+ assert_class(formula_parts, "mmrm_tmb_formula_parts") |
||
| 187 | -+ | |||
| 275 | +264x |
- #' - `index`: List of zero-based subject indices.+ assert_class(tmb_data, "mmrm_tmb_data") |
||
| 188 | +276 |
- #'+ |
||
| 189 | -+ | |||
| 277 | +264x |
- #' @keywords internal+ m <- tmb_data$n_visits |
||
| 190 | -+ | |||
| 278 | +264x |
- h_get_prediction <- function(tmb_data, theta, beta, beta_vcov) {
+ start_value0 <- std_start(formula_parts$cov_type, m, n_groups) |
||
| 191 | -1696x | +279 | +264x |
- assert_class(tmb_data, "mmrm_tmb_data")+ theta_dim <- length(start_value0) |
| 192 | -1696x | +280 | +264x |
- assert_numeric(theta)+ start_values <- if (is.null(start)) {
|
| 193 | -1696x | +281 | +15x |
- n_beta <- ncol(tmb_data$x_matrix)+ start_value0 |
| 194 | -1696x | +282 | +264x |
- assert_numeric(beta, finite = TRUE, any.missing = FALSE, len = n_beta)+ } else if (test_function(start)) {
|
| 195 | -1696x | +283 | +232x |
- assert_matrix(beta_vcov, mode = "numeric", any.missing = FALSE, nrows = n_beta, ncols = n_beta)+ do.call(start, utils::modifyList(formula_parts, tmb_data))+ |
+
| 284 | ++ |
+ } else {
|
||
| 196 | -1696x | +285 | +17x |
- .Call(`_mmrm_predict`, PACKAGE = "mmrm", tmb_data, theta, beta, beta_vcov)+ start |
| 197 | +286 |
- }+ } |
||
| 198 | -+ | |||
| 287 | +263x |
-
+ assert_numeric(start_values, len = theta_dim, any.missing = FALSE, finite = TRUE)+ |
+ ||
| 288 | +261x | +
+ list(theta = start_values) |
||
| 199 | +289 |
- #' Get Prediction Variance+ } |
||
| 200 | +290 |
- #'+ |
||
| 201 | +291 |
- #' @description Get prediction variance with given fit, `tmb_data` with the Monte Carlo sampling method.+ #' Asserting Sane Start Values for `TMB` Fit |
||
| 202 | +292 |
#' |
||
| 203 | +293 |
- #' @param object (`mmrm_tmb`)\cr the fitted MMRM.+ #' @param tmb_object (`list`)\cr created with [TMB::MakeADFun()]. |
||
| 204 | +294 |
- #' @param nsim (`count`)\cr number of samples.+ #' |
||
| 205 | +295 |
- #' @param tmb_data (`mmrm_tmb_data`)\cr object.+ #' @return Nothing, only used for assertions. |
||
| 206 | +296 |
#' |
||
| 207 | +297 |
#' @keywords internal |
||
| 208 | +298 |
- h_get_prediction_variance <- function(object, nsim, tmb_data) {
+ h_mmrm_tmb_assert_start <- function(tmb_object) {
|
||
| 209 | -7x | +299 | +248x |
- assert_class(object, "mmrm_tmb")+ assert_list(tmb_object) |
| 210 | -7x | +300 | +248x |
- assert_class(tmb_data, "mmrm_tmb_data")+ assert_subset(c("fn", "gr", "par"), names(tmb_object))
|
| 211 | -7x | +|||
| 301 | +
- assert_count(nsim, positive = TRUE)+ |
|||
| 212 | -7x | +302 | +248x |
- theta_chol <- chol(object$theta_vcov)+ if (is.na(tmb_object$fn(tmb_object$par))) {
|
| 213 | -7x | +303 | +1x |
- n_theta <- length(object$theta_est)+ stop("negative log-likelihood is NaN at starting parameter values")
|
| 214 | -7x | +|||
| 304 | +
- res <- replicate(nsim, {
+ } |
|||
| 215 | -1150x | +305 | +247x |
- z <- stats::rnorm(n = n_theta)+ if (any(is.na(tmb_object$gr(tmb_object$par)))) {
|
| 216 | -1150x | +306 | +1x |
- theta_sample <- object$theta_est + z %*% theta_chol+ stop("some elements of gradient are NaN at starting parameter values")
|
| 217 | -1150x | +|||
| 307 | +
- cond_beta_results <- object$tmb_object$report(theta_sample)+ } |
|||
| 218 | -1150x | +|||
| 308 | +
- beta_mean <- cond_beta_results$beta+ } |
|||
| 219 | -1150x | -
- beta_cov <- cond_beta_results$beta_vcov+ | ||
| 309 | ++ | + | ||
| 220 | -1150x | +|||
| 310 | +
- h_get_prediction(tmb_data, theta_sample, beta_mean, beta_cov)$prediction+ #' Checking the `TMB` Optimization Result |
|||
| 221 | +311 |
- })+ #' |
||
| 222 | -7x | +|||
| 312 | +
- mean_of_var <- rowMeans(res[, "var", ])+ #' @param tmb_opt (`list`)\cr optimization result. |
|||
| 223 | -7x | +|||
| 313 | +
- var_of_mean <- apply(res[, "fit", ], 1, stats::var)+ #' @param mmrm_tmb (`mmrm_tmb`)\cr result from [h_mmrm_tmb_fit()]. |
|||
| 224 | -7x | +|||
| 314 | +
- mean_of_var + var_of_mean+ #' |
|||
| 225 | +315 |
- }+ #' @return Nothing, only used to generate warnings in case that the model |
||
| 226 | +316 |
-
+ #' did not converge. |
||
| 227 | +317 |
- #' @describeIn mmrm_tmb_methods obtains the model frame.+ #' |
||
| 228 | +318 |
- #' @param data (`data.frame`)\cr object in which to construct the frame.+ #' @keywords internal |
||
| 229 | +319 |
- #' @param include (`character`)\cr names of variable types to include.+ h_mmrm_tmb_check_conv <- function(tmb_opt, mmrm_tmb) {
+ |
+ ||
| 320 | +244x | +
+ assert_list(tmb_opt)+ |
+ ||
| 321 | +244x | +
+ assert_subset(c("par", "objective", "convergence", "message"), names(tmb_opt))
+ |
+ ||
| 322 | +244x | +
+ assert_class(mmrm_tmb, "mmrm_tmb") |
||
| 230 | +323 |
- #' Must be `NULL` or one or more of `c("subject_var", "visit_var", "group_var", "response_var")`.
+
+ |
+ ||
| 324 | +244x | +
+ if (!is.null(tmb_opt$convergence) && tmb_opt$convergence != 0) {
+ |
+ ||
| 325 | +3x | +
+ warning("Model convergence problem: ", tmb_opt$message, ".")
+ |
+ ||
| 326 | +3x | +
+ return() |
||
| 231 | +327 |
- #' @param full (`flag`)\cr indicator whether to return full model frame (deprecated).+ }+ |
+ ||
| 328 | +241x | +
+ theta_vcov <- mmrm_tmb$theta_vcov+ |
+ ||
| 329 | +241x | +
+ if (is(theta_vcov, "try-error")) {
+ |
+ ||
| 330 | +3x | +
+ warning("Model convergence problem: hessian is singular, theta_vcov not available.")
+ |
+ ||
| 331 | +3x | +
+ return() |
||
| 232 | +332 |
- #' @param na.action (`string`)\cr na action.+ }+ |
+ ||
| 333 | +238x | +
+ if (!all(is.finite(theta_vcov))) {
+ |
+ ||
| 334 | +3x | +
+ warning("Model convergence problem: theta_vcov contains non-finite values.")
+ |
+ ||
| 335 | +3x | +
+ return() |
||
| 233 | +336 |
- #' @importFrom stats model.frame+ }+ |
+ ||
| 337 | +235x | +
+ eigen_vals <- eigen(theta_vcov, only.values = TRUE)$values+ |
+ ||
| 338 | +235x | +
+ if (mode(eigen_vals) == "complex" || any(eigen_vals <= 0)) {
|
||
| 234 | +339 |
- #' @exportS3Method+ # Note: complex eigen values signal that the matrix is not symmetric, therefore not positive definite.+ |
+ ||
| 340 | +3x | +
+ warning("Model convergence problem: theta_vcov is not positive definite.")
+ |
+ ||
| 341 | +3x | +
+ return() |
||
| 235 | +342 |
- #'+ }+ |
+ ||
| 343 | +232x | +
+ qr_rank <- qr(theta_vcov)$rank+ |
+ ||
| 344 | +232x | +
+ if (qr_rank < ncol(theta_vcov)) {
+ |
+ ||
| 345 | +1x | +
+ warning("Model convergence problem: theta_vcov is numerically singular.")
|
||
| 236 | +346 |
- #' @details+ } |
||
| 237 | +347 |
- #' `include` argument controls the variables the returned model frame will include.+ } |
||
| 238 | +348 |
- #' Possible options are "response_var", "subject_var", "visit_var" and "group_var", representing the+ |
||
| 239 | +349 |
- #' response variable, subject variable, visit variable or group variable.+ #' Extract covariance matrix from `TMB` report and input data |
||
| 240 | +350 |
- #' `character` values in new data will always be factorized according to the data in the fit+ #' |
||
| 241 | +351 |
- #' to avoid mismatched in levels or issues in `model.matrix`.+ #' This helper does some simple post-processing to extract covariance matrix or named |
||
| 242 | +352 | ++ |
+ #' list of covariance matrices if the fitting is using grouped covariance matrices.+ |
+ |
| 353 |
#' |
|||
| 243 | +354 |
- #' @examples+ #' @param tmb_report (`list`)\cr report created with [TMB::MakeADFun()] report function. |
||
| 244 | +355 |
- #' # Model frame:+ #' @param tmb_data (`mmrm_tmb_data`)\cr produced by [h_mmrm_tmb_data()]. |
||
| 245 | +356 |
- #' model.frame(object)+ #' @param visit_var (`character`)\cr character vector of the visit variable |
||
| 246 | +357 |
- #' model.frame(object, include = "subject_var")+ #' @param is_spatial (`flag`)\cr indicator whether the covariance structure is spatial. |
||
| 247 | +358 |
- model.frame.mmrm_tmb <- function(formula, data, include = c("subject_var", "visit_var", "group_var", "response_var"),
+ #' @return Return a simple covariance matrix if there is no grouping, or a named |
||
| 248 | +359 |
- full, na.action = "na.omit", ...) { # nolint
+ #' list of estimated grouped covariance matrices, |
||
| 249 | +360 |
- # Construct updated formula and data arguments.+ #' with its name equal to the group levels. |
||
| 250 | -46x | +|||
| 361 | +
- lst_formula_and_data <-+ #' |
|||
| 251 | -46x | +|||
| 362 | +
- h_construct_model_frame_inputs(+ #' @keywords internal |
|||
| 252 | -46x | +|||
| 363 | +
- formula = formula,+ h_mmrm_tmb_extract_cov <- function(tmb_report, tmb_data, visit_var, is_spatial) {
|
|||
| 253 | -46x | +364 | +240x |
- data = data,+ d <- dim(tmb_report$covariance_lower_chol) |
| 254 | -46x | +365 | +240x |
- include = include,+ visit_names <- if (!is_spatial) {
|
| 255 | -46x | +366 | +227x |
- full = full+ levels(tmb_data$full_frame[[visit_var]]) |
| 256 | +367 |
- )+ } else {
|
||
| 257 | -+ | |||
| 368 | +13x |
- # Only if include is default (full) and also data is missing, and also na.action is na.omit we will+ c(0, 1) |
||
| 258 | +369 |
- # use the model frame from the tmb_data.+ } |
||
| 259 | -46x | +370 | +240x |
- include_choice <- c("subject_var", "visit_var", "group_var", "response_var")
+ cov <- lapply( |
| 260 | -46x | +371 | +240x |
- if (missing(data) && setequal(include, include_choice) && identical(h_get_na_action(na.action), stats::na.omit)) {
+ seq_len(d[1] / d[2]), |
| 261 | -2x | +372 | +240x |
- ret <- formula$tmb_data$full_frame+ function(i) {
|
| 262 | -+ | |||
| 373 | +277x |
- # Remove weights column.+ ret <- tcrossprod(tmb_report$covariance_lower_chol[seq(1 + (i - 1) * d[2], i * d[2]), ]) |
||
| 263 | -2x | +374 | +277x |
- ret[, "(weights)"] <- NULL+ dimnames(ret) <- list(visit_names, visit_names) |
| 264 | -2x | +375 | +277x |
- ret+ return(ret) |
| 265 | +376 |
- } else {
+ } |
||
| 266 | +377 |
- # Construct data frame to return to users.- |
- ||
| 267 | -44x | -
- ret <-- |
- ||
| 268 | -44x | -
- stats::model.frame(+ ) |
||
| 269 | -44x | +378 | +240x |
- formula = lst_formula_and_data$formula,+ if (identical(tmb_data$n_groups, 1L)) {
|
| 270 | -44x | +379 | +203x |
- data = h_get_na_action(na.action)(lst_formula_and_data$data),+ cov <- cov[[1]] |
| 271 | -44x | +|||
| 380 | +
- na.action = na.action,+ } else {
|
|||
| 272 | -44x | -
- xlev = stats::.getXlevels(terms(formula), formula$tmb_data$full_frame)- |
- ||
| 273 | -+ | 381 | +37x |
- )+ names(cov) <- levels(tmb_data$subject_groups) |
| 274 | +382 |
} |
||
| 275 | -45x | +383 | +240x |
- ret+ return(cov) |
| 276 | +384 |
} |
||
| 277 | +385 | |||
| 278 | +386 |
-
+ #' Build `TMB` Fit Result List |
||
| 279 | +387 |
- #' Construction of Model Frame Formula and Data Inputs+ #' |
||
| 280 | +388 |
- #'+ #' This helper does some simple post-processing of the `TMB` object and |
||
| 281 | +389 |
- #' @description+ #' optimization results, including setting names, inverting matrices etc. |
||
| 282 | +390 |
- #' Input formulas are converted from mmrm-style to a style compatible+ #' |
||
| 283 | +391 |
- #' with default [stats::model.frame()] and [stats::model.matrix()] methods.+ #' @param tmb_object (`list`)\cr created with [TMB::MakeADFun()]. |
||
| 284 | +392 |
- #'+ #' @param tmb_opt (`list`)\cr optimization result. |
||
| 285 | +393 |
- #' The full formula is returned so we can construct, for example, the+ #' @param formula_parts (`mmrm_tmb_formula_parts`)\cr produced by |
||
| 286 | +394 |
- #' `model.frame()` including all columns as well as the requested subset.+ #' [h_mmrm_tmb_formula_parts()]. |
||
| 287 | +395 |
- #' The full set is used to identify rows to include in the reduced model frame.+ #' @param tmb_data (`mmrm_tmb_data`)\cr produced by [h_mmrm_tmb_data()]. |
||
| 288 | +396 |
#' |
||
| 289 | +397 |
- #' @param formula (`mmrm`)\cr mmrm fit object.+ #' @return List of class `mmrm_tmb` with: |
||
| 290 | +398 |
- #' @param data optional data frame that will be+ #' - `cov`: estimated covariance matrix, or named list of estimated group specific covariance matrices. |
||
| 291 | +399 |
- #' passed to `model.frame()` or `model.matrix()`+ #' - `beta_est`: vector of coefficient estimates. |
||
| 292 | +400 |
- #' @param include (`character`)\cr names of variable to include+ #' - `beta_vcov`: Variance-covariance matrix for coefficient estimates. |
||
| 293 | +401 |
- #' @param full (`flag`)\cr indicator whether to return full model frame (deprecated).+ #' - `beta_vcov_inv_L`: Lower triangular matrix `L` of the inverse variance-covariance matrix decomposition. |
||
| 294 | +402 |
- #'+ #' - `beta_vcov_inv_D`: vector of diagonal matrix `D` of the inverse variance-covariance matrix decomposition. |
||
| 295 | +403 |
- #' @return named list with four elements:+ #' - `theta_est`: vector of variance parameter estimates. |
||
| 296 | +404 |
- #' - `"formula"`: the formula including the columns requested in the `include=` argument.+ #' - `theta_vcov`: variance-covariance matrix for variance parameter estimates. |
||
| 297 | +405 |
- #' - `"data"`: a data frame including all columns needed in the formula.+ #' - `neg_log_lik`: obtained negative log-likelihood. |
||
| 298 | +406 |
- #' full formula are identical+ #' - `formula_parts`: input. |
||
| 299 | +407 |
- #' @keywords internal+ #' - `data`: input. |
||
| 300 | +408 |
- h_construct_model_frame_inputs <- function(formula,+ #' - `weights`: input. |
||
| 301 | +409 |
- data,+ #' - `reml`: input as a flag. |
||
| 302 | +410 |
- include,+ #' - `opt_details`: list with optimization details including convergence code. |
||
| 303 | +411 |
- include_choice = c("subject_var", "visit_var", "group_var", "response_var"),
+ #' - `tmb_object`: original `TMB` object created with [TMB::MakeADFun()]. |
||
| 304 | +412 |
- full) {
+ #' - `tmb_data`: input. |
||
| 305 | -280x | +|||
| 413 | +
- if (!missing(full) && identical(full, TRUE)) {
+ #' |
|||
| 306 | -! | +|||
| 414 | +
- lifecycle::deprecate_warn("0.3", "model.frame.mmrm_tmb(full)")
+ #' @details Instead of inverting or decomposing `beta_vcov`, it can be more efficient to use its robust |
|||
| 307 | -! | +|||
| 415 | +
- include <- include_choice+ #' Cholesky decomposition `LDL^T`, therefore we return the corresponding two components `L` and `D` |
|||
| 308 | +416 |
- }+ #' as well since they have been available on the `C++` side already. |
||
| 309 | +417 |
-
+ #' |
||
| 310 | -280x | +|||
| 418 | +
- assert_class(formula, classes = "mmrm_tmb")+ #' @keywords internal |
|||
| 311 | -280x | +|||
| 419 | +
- assert_subset(include, include_choice)+ h_mmrm_tmb_fit <- function(tmb_object, |
|||
| 312 | -280x | +|||
| 420 | +
- if (missing(data)) {
+ tmb_opt, |
|||
| 313 | -256x | +|||
| 421 | +
- data <- formula$data+ formula_parts, |
|||
| 314 | +422 |
- }+ tmb_data) {
|
||
| 315 | -280x | +423 | +238x |
- assert_data_frame(data)+ assert_list(tmb_object) |
| 316 | -+ | |||
| 424 | +238x |
-
+ assert_subset(c("fn", "gr", "par", "he"), names(tmb_object))
|
||
| 317 | -280x | +425 | +238x |
- drop_response <- !"response_var" %in% include+ assert_list(tmb_opt) |
| 318 | -280x | +426 | +238x |
- add_vars <- unlist(formula$formula_parts[include])+ assert_subset(c("par", "objective", "convergence", "message"), names(tmb_opt))
|
| 319 | -280x | +427 | +238x |
- new_formula <- h_add_terms(formula$formula_parts$model_formula, add_vars, drop_response)+ assert_class(formula_parts, "mmrm_tmb_formula_parts")+ |
+
| 428 | +238x | +
+ assert_class(tmb_data, "mmrm_tmb_data") |
||
| 320 | +429 | |||
| 321 | -280x | +430 | +238x |
- drop_response_full <- !"response_var" %in% include_choice+ tmb_report <- tmb_object$report(par = tmb_opt$par) |
| 322 | -280x | +431 | +238x |
- add_vars_full <- unlist(formula$formula_parts[include_choice])+ x_matrix_cols <- colnames(tmb_data$x_matrix) |
| 323 | -280x | +432 | +238x |
- new_formula_full <-+ cov <- h_mmrm_tmb_extract_cov(tmb_report, tmb_data, formula_parts$visit_var, formula_parts$is_spatial) |
| 324 | -280x | -
- h_add_terms(formula$formula_parts$model_formula, add_vars_full, drop_response_full)- |
- ||
| 325 | -+ | 433 | +238x |
-
+ beta_est <- tmb_report$beta |
| 326 | -+ | |||
| 434 | +238x |
- # Update data based on the columns in the full formula return.+ names(beta_est) <- x_matrix_cols |
||
| 327 | -280x | +435 | +238x |
- all_vars <- all.vars(new_formula_full)+ beta_vcov <- tmb_report$beta_vcov |
| 328 | -280x | +436 | +238x |
- assert_names(colnames(data), must.include = all_vars)+ dimnames(beta_vcov) <- list(x_matrix_cols, x_matrix_cols) |
| 329 | -280x | +437 | +238x |
- data <- data[, all_vars, drop = FALSE]+ beta_vcov_inv_L <- tmb_report$XtWX_L # nolint |
| 330 | -+ | |||
| 438 | +238x |
-
+ beta_vcov_inv_D <- tmb_report$XtWX_D # nolint |
||
| 331 | -+ | |||
| 439 | +238x |
- # Return list with updated formula, data.+ theta_est <- tmb_opt$par |
||
| 332 | -280x | +440 | +238x |
- list(+ names(theta_est) <- NULL |
| 333 | -280x | +441 | +238x |
- formula = new_formula,+ theta_vcov <- try(solve(tmb_object$he(tmb_opt$par)), silent = TRUE) |
| 334 | -280x | +442 | +238x |
- data = data+ opt_details_names <- setdiff( |
| 335 | -+ | |||
| 443 | +238x |
- )+ names(tmb_opt), |
||
| 336 | -+ | |||
| 444 | +238x |
- }+ c("par", "objective")
|
||
| 337 | +445 |
-
+ ) |
||
| 338 | -+ | |||
| 446 | +238x |
- #' @describeIn mmrm_tmb_methods obtains the model matrix.+ structure( |
||
| 339 | -+ | |||
| 447 | +238x |
- #' @exportS3Method+ list( |
||
| 340 | -+ | |||
| 448 | +238x |
- #' @param use_response (`flag`)\cr whether to use the response for complete rows.+ cov = cov, |
||
| 341 | -+ | |||
| 449 | +238x |
- #'+ beta_est = beta_est, |
||
| 342 | -+ | |||
| 450 | +238x |
- #' @examples+ beta_vcov = beta_vcov, |
||
| 343 | -+ | |||
| 451 | +238x |
- #' # Model matrix:+ beta_vcov_inv_L = beta_vcov_inv_L, |
||
| 344 | -+ | |||
| 452 | +238x |
- #' model.matrix(object)+ beta_vcov_inv_D = beta_vcov_inv_D, |
||
| 345 | -+ | |||
| 453 | +238x |
- model.matrix.mmrm_tmb <- function(object, data, use_response = TRUE, ...) { # nolint
+ theta_est = theta_est, |
||
| 346 | -+ | |||
| 454 | +238x |
- # Always return the utilized model matrix if data not provided.+ theta_vcov = theta_vcov, |
||
| 347 | -37x | +455 | +238x |
- if (missing(data)) {
+ neg_log_lik = tmb_opt$objective, |
| 348 | -3x | +456 | +238x |
- return(object$tmb_data$x_matrix)+ formula_parts = formula_parts, |
| 349 | -+ | |||
| 457 | +238x |
- }+ data = tmb_data$data, |
||
| 350 | -34x | +458 | +238x |
- stats::model.matrix(+ weights = tmb_data$weights_vector, |
| 351 | -34x | +459 | +238x |
- h_add_terms(object$formula_parts$model_formula, NULL, drop_response = !use_response),+ reml = as.logical(tmb_data$reml), |
| 352 | -34x | +460 | +238x |
- data = data,+ opt_details = tmb_opt[opt_details_names], |
| 353 | -34x | +461 | +238x |
- contrasts.arg = attr(object$tmb_data$x_matrix, "contrasts"),+ tmb_object = tmb_object, |
| 354 | -34x | +462 | +238x |
- xlev = component(object, "xlev"),+ tmb_data = tmb_data |
| 355 | +463 |
- ...+ ),+ |
+ ||
| 464 | +238x | +
+ class = "mmrm_tmb" |
||
| 356 | +465 |
) |
||
| 357 | +466 |
} |
||
| 358 | +467 | |||
| 359 | +468 |
- #' @describeIn mmrm_tmb_methods obtains the terms object.+ #' Low-Level Fitting Function for MMRM |
||
| 360 | +469 |
- #' @importFrom stats model.frame+ #' |
||
| 361 | +470 |
- #' @exportS3Method+ #' @description `r lifecycle::badge("stable")`
|
||
| 362 | +471 |
#' |
||
| 363 | +472 |
- #' @examples+ #' This is the low-level function to fit an MMRM. Note that this does not |
||
| 364 | +473 |
- #' # terms:+ #' try different optimizers or adds Jacobian information etc. in contrast to |
||
| 365 | +474 |
- #' terms(object)+ #' [mmrm()]. |
||
| 366 | +475 |
- #' terms(object, include = "subject_var")+ #' |
||
| 367 | +476 |
- terms.mmrm_tmb <- function(x, include = "response_var", ...) { # nolint
+ #' @param formula (`formula`)\cr model formula with exactly one special term |
||
| 368 | +477 |
- # Construct updated formula and data arguments.+ #' specifying the visits within subjects, see details. |
||
| 369 | -231x | +|||
| 478 | +
- lst_formula_and_data <-+ #' @param data (`data.frame`)\cr input data containing the variables used in |
|||
| 370 | -231x | +|||
| 479 | +
- h_construct_model_frame_inputs(+ #' `formula`. |
|||
| 371 | -231x | +|||
| 480 | +
- formula = x,+ #' @param weights (`vector`)\cr input vector containing the weights. |
|||
| 372 | -231x | +|||
| 481 | +
- include = include+ #' @inheritParams h_mmrm_tmb_data |
|||
| 373 | +482 |
- )+ #' @param covariance (`cov_struct`)\cr A covariance structure type definition, |
||
| 374 | +483 |
-
+ #' or value that can be coerced to a covariance structure using |
||
| 375 | +484 |
- # Use formula method for `terms()` to construct the mmrm terms object.+ #' [as.cov_struct()]. If no value is provided, a structure is derived from |
||
| 376 | -231x | +|||
| 485 | +
- stats::terms(+ #' the provided formula. |
|||
| 377 | -231x | +|||
| 486 | +
- x = lst_formula_and_data$formula,+ #' @param control (`mmrm_control`)\cr list of control options produced by |
|||
| 378 | -231x | +|||
| 487 | +
- data = lst_formula_and_data$data+ #' [mmrm_control()]. |
|||
| 379 | +488 |
- )+ #' @inheritParams fit_single_optimizer |
||
| 380 | +489 |
- }+ #' |
||
| 381 | +490 |
-
+ #' @return List of class `mmrm_tmb`, see [h_mmrm_tmb_fit()] for details. |
||
| 382 | +491 |
-
+ #' In addition, it contains elements `call` and `optimizer`. |
||
| 383 | +492 |
- #' @describeIn mmrm_tmb_methods obtains the attained log likelihood value.+ #' |
||
| 384 | +493 |
- #' @importFrom stats logLik+ #' @details |
||
| 385 | +494 |
- #' @exportS3Method+ #' The `formula` typically looks like: |
||
| 386 | +495 |
- #' @examples+ #' |
||
| 387 | +496 |
- #' # Log likelihood given the estimated parameters:+ #' `FEV1 ~ RACE + SEX + ARMCD * AVISIT + us(AVISIT | USUBJID)` |
||
| 388 | +497 |
- #' logLik(object)+ #' |
||
| 389 | +498 |
- logLik.mmrm_tmb <- function(object, ...) {
- |
- ||
| 390 | -50x | -
- -component(object, "neg_log_lik")+ #' which specifies response and covariates as usual, and exactly one special term |
||
| 391 | +499 |
- }+ #' defines which covariance structure is used and what are the visit and |
||
| 392 | +500 |
-
+ #' subject variables. |
||
| 393 | +501 |
- #' @describeIn mmrm_tmb_methods obtains the used formula.+ #' |
||
| 394 | +502 |
- #' @importFrom stats formula+ #' Always use only the first optimizer if multiple optimizers are provided. |
||
| 395 | +503 |
- #' @exportS3Method+ #' |
||
| 396 | +504 |
- #' @examples+ #' @export |
||
| 397 | +505 |
- #' # Formula which was used:+ #' |
||
| 398 | +506 |
- #' formula(object)+ #' @examples |
||
| 399 | +507 |
- formula.mmrm_tmb <- function(x, ...) {
- |
- ||
| 400 | -5x | -
- x$formula_parts$formula+ #' formula <- FEV1 ~ RACE + SEX + ARMCD * AVISIT + us(AVISIT | USUBJID) |
||
| 401 | +508 |
- }+ #' data <- fev_data |
||
| 402 | +509 |
-
+ #' system.time(result <- fit_mmrm(formula, data, rep(1, nrow(fev_data)))) |
||
| 403 | +510 |
- #' @describeIn mmrm_tmb_methods obtains the variance-covariance matrix estimate+ fit_mmrm <- function(formula, |
||
| 404 | +511 |
- #' for the coefficients.+ data, |
||
| 405 | +512 |
- #' @importFrom stats vcov+ weights, |
||
| 406 | +513 |
- #' @exportS3Method+ reml = TRUE, |
||
| 407 | +514 |
- #' @examples+ covariance = NULL, |
||
| 408 | +515 |
- #' # Variance-covariance matrix estimate for coefficients:+ tmb_data, |
||
| 409 | +516 |
- #' vcov(object)+ formula_parts, |
||
| 410 | +517 |
- vcov.mmrm_tmb <- function(object, complete = TRUE, ...) {
+ control = mmrm_control()) {
|
||
| 411 | -3x | +518 | +251x |
- assert_flag(complete)+ if (missing(formula_parts) || missing(tmb_data)) {
|
| 412 | -3x | +519 | +67x |
- nm <- if (complete) "beta_vcov_complete" else "beta_vcov"+ covariance <- h_reconcile_cov_struct(formula, covariance) |
| 413 | -3x | +520 | +65x |
- component(object, name = nm)+ formula_parts <- h_mmrm_tmb_formula_parts(formula, covariance) |
| 414 | +521 |
- }+ |
||
| 415 | -+ | |||
| 522 | +65x |
-
+ if (!formula_parts$is_spatial && !is.factor(data[[formula_parts$visit_var]])) {
|
||
| 416 | -+ | |||
| 523 | +1x |
- #' @describeIn mmrm_tmb_methods obtains the variance-covariance matrix estimate+ stop("Time variable must be a factor for non-spatial covariance structures")
|
||
| 417 | +524 |
- #' for the residuals.+ } |
||
| 418 | +525 |
- #' @param sigma cannot be used (this parameter does not exist in MMRM).+ |
||
| 419 | -+ | |||
| 526 | +64x |
- #' @importFrom nlme VarCorr+ assert_class(control, "mmrm_control") |
||
| 420 | -+ | |||
| 527 | +64x |
- #' @export VarCorr+ assert_list(control$optimizers, min.len = 1) |
||
| 421 | -+ | |||
| 528 | +64x |
- #' @aliases VarCorr+ assert_numeric(weights, any.missing = FALSE) |
||
| 422 | -+ | |||
| 529 | +64x |
- #' @exportS3Method+ assert_true(all(weights > 0)) |
||
| 423 | -+ | |||
| 530 | +64x |
- #' @examples+ tmb_data <- h_mmrm_tmb_data( |
||
| 424 | -+ | |||
| 531 | +64x |
- #' # Variance-covariance matrix estimate for residuals:+ formula_parts, data, weights, reml, |
||
| 425 | -+ | |||
| 532 | +64x |
- #' VarCorr(object)+ singular = if (control$accept_singular) "drop" else "error", drop_visit_levels = control$drop_visit_levels |
||
| 426 | +533 |
- VarCorr.mmrm_tmb <- function(x, sigma = NA, ...) { # nolint
- |
- ||
| 427 | -10x | -
- assert_scalar_na(sigma)+ ) |
||
| 428 | +534 |
-
+ } else {
|
||
| 429 | -10x | -
- component(x, name = "varcor")- |
- ||
| 430 | -+ | 535 | +184x |
- }+ assert_class(tmb_data, "mmrm_tmb_data") |
| 431 | -+ | |||
| 536 | +184x |
-
+ assert_class(formula_parts, "mmrm_tmb_formula_parts") |
||
| 432 | +537 |
- #' @describeIn mmrm_tmb_methods obtains the deviance, which is defined here+ } |
||
| 433 | -+ | |||
| 538 | +248x |
- #' as twice the negative log likelihood, which can either be integrated+ tmb_parameters <- h_mmrm_tmb_parameters(formula_parts, tmb_data, start = control$start, n_groups = tmb_data$n_groups) |
||
| 434 | +539 |
- #' over the coefficients for REML fits or the usual one for ML fits.+ |
||
| 435 | -+ | |||
| 540 | +245x |
- #' @importFrom stats deviance+ h_tmb_warn_optimization() |
||
| 436 | +541 |
- #' @exportS3Method+ |
||
| 437 | -+ | |||
| 542 | +245x |
- #' @examples+ tmb_object <- TMB::MakeADFun( |
||
| 438 | -+ | |||
| 543 | +245x |
- #' # REML criterion (twice the negative log likelihood):+ data = tmb_data, |
||
| 439 | -+ | |||
| 544 | +245x |
- #' deviance(object)+ parameters = tmb_parameters, |
||
| 440 | -+ | |||
| 545 | +245x |
- deviance.mmrm_tmb <- function(object, ...) {
+ hessian = TRUE, |
||
| 441 | -74x | +546 | +245x |
- 2 * component(object, "neg_log_lik")+ DLL = "mmrm", |
| 442 | -+ | |||
| 547 | +245x |
- }+ silent = TRUE |
||
| 443 | +548 |
-
+ ) |
||
| 444 | -+ | |||
| 549 | +245x |
- #' @describeIn mmrm_tmb_methods obtains the Akaike Information Criterion,+ h_mmrm_tmb_assert_start(tmb_object) |
||
| 445 | -+ | |||
| 550 | +245x |
- #' where the degrees of freedom are the number of variance parameters (`n_theta`).+ used_optimizer <- control$optimizers[[1L]] |
||
| 446 | -+ | |||
| 551 | +245x |
- #' If `corrected`, then this is multiplied with `m / (m - n_theta - 1)` where+ used_optimizer_name <- names(control$optimizers)[1L] |
||
| 447 | -+ | |||
| 552 | +245x |
- #' `m` is the number of observations minus the number of coefficients, or+ args <- with( |
||
| 448 | -+ | |||
| 553 | +245x |
- #' `n_theta + 2` if it is smaller than that \insertCite{hurvich1989regression,burnham1998practical}{mmrm}.
+ tmb_object, |
||
| 449 | -+ | |||
| 554 | +245x |
- #' @param corrected (`flag`)\cr whether corrected AIC should be calculated.+ c( |
||
| 450 | -+ | |||
| 555 | +245x |
- #' @param k (`number`)\cr the penalty per parameter to be used; default `k = 2`+ list(par, fn, gr), |
||
| 451 | -+ | |||
| 556 | +245x |
- #' is the classical AIC.+ attr(used_optimizer, "args") |
||
| 452 | +557 |
- #' @importFrom stats AIC+ ) |
||
| 453 | +558 |
- #' @exportS3Method+ ) |
||
| 454 | -+ | |||
| 559 | +245x |
- #' @examples+ if (identical(attr(used_optimizer, "use_hessian"), TRUE)) {
|
||
| 455 | -+ | |||
| 560 | +8x |
- #' # AIC:+ args$hessian <- tmb_object$he |
||
| 456 | +561 |
- #' AIC(object)+ } |
||
| 457 | -+ | |||
| 562 | +245x |
- #' AIC(object, corrected = TRUE)+ tmb_opt <- do.call( |
||
| 458 | -+ | |||
| 563 | +245x |
- #' @references+ what = used_optimizer, |
||
| 459 | -+ | |||
| 564 | +245x |
- #' - \insertRef{hurvich1989regression}{mmrm}
+ args = args |
||
| 460 | +565 |
- #' - \insertRef{burnham1998practical}{mmrm}
+ ) |
||
| 461 | +566 |
- AIC.mmrm_tmb <- function(object, corrected = FALSE, ..., k = 2) {
+ # Ensure negative log likelihood is stored in `objective` element of list. |
||
| 462 | -+ | |||
| 567 | +236x |
- # nolint+ if ("value" %in% names(tmb_opt)) {
|
||
| 463 | -44x | +568 | +226x |
- assert_flag(corrected)+ tmb_opt$objective <- tmb_opt$value |
| 464 | -44x | +569 | +226x |
- assert_number(k, lower = 1)+ tmb_opt$value <- NULL |
| 465 | +570 |
-
+ } |
||
| 466 | -44x | +571 | +236x |
- n_theta <- length(component(object, "theta_est"))+ fit <- h_mmrm_tmb_fit(tmb_object, tmb_opt, formula_parts, tmb_data) |
| 467 | -44x | +572 | +236x |
- df <- if (!corrected) {
+ h_mmrm_tmb_check_conv(tmb_opt, fit) |
| 468 | -43x | +573 | +236x |
- n_theta+ fit$call <- match.call() |
| 469 | -+ | |||
| 574 | +236x |
- } else {
+ fit$call$formula <- formula_parts$formula |
||
| 470 | -1x | +575 | +236x |
- n_obs <- length(component(object, "y_vector"))+ fit$optimizer <- used_optimizer_name |
| 471 | -1x | +576 | +236x |
- n_beta <- length(component(object, "beta_est"))+ fit |
| 472 | -1x | +|||
| 577 | +
- m <- max(n_theta + 2, n_obs - n_beta)+ } |
|||
| 473 | -1x | +
| 1 | +
- n_theta * (m / (m - n_theta - 1))+ #' Tidying Methods for `mmrm` Objects |
|||
| 474 | +2 |
- }+ #' |
||
| 475 | +3 |
-
+ #' @description `r lifecycle::badge("stable")`
|
||
| 476 | -44x | +|||
| 4 | +
- 2 * component(object, "neg_log_lik") + k * df+ #' |
|||
| 477 | +5 |
- }+ #' These methods tidy the estimates from an `mmrm` object into a |
||
| 478 | +6 |
-
+ #' summary. |
||
| 479 | +7 |
- #' @describeIn mmrm_tmb_methods obtains the Bayesian Information Criterion,+ #' |
||
| 480 | +8 |
- #' which is using the natural logarithm of the number of subjects for the+ #' @param x (`mmrm`)\cr fitted model. |
||
| 481 | +9 |
- #' penalty parameter `k`.+ #' @param conf.int (`flag`)\cr if `TRUE` columns for the lower (`conf.low`) and upper bounds |
||
| 482 | +10 |
- #' @importFrom stats BIC+ #' (`conf.high`) of coefficient estimates are included. |
||
| 483 | +11 |
- #' @exportS3Method+ #' @param conf.level (`number`)\cr defines the range of the optional confidence internal. |
||
| 484 | +12 |
- #' @examples+ #' @param newdata (`data.frame` or `NULL`)\cr optional new data frame. |
||
| 485 | +13 |
- #' # BIC:+ #' @param se_fit (`flag`)\cr whether to return standard errors of fit. |
||
| 486 | +14 |
- #' BIC(object)+ #' @param interval (`string`)\cr type of interval calculation. |
||
| 487 | +15 |
- BIC.mmrm_tmb <- function(object, ...) {
+ #' @param type.residuals (`string`)\cr passed on to [residuals.mmrm_tmb()]. |
||
| 488 | +16 |
- # nolint+ #' @param ... only used by `augment()` to pass arguments to the [predict.mmrm_tmb()] method. |
||
| 489 | -21x | +|||
| 17 | +
- k <- log(component(object, "n_subjects"))+ #' |
|||
| 490 | -21x | +|||
| 18 | +
- AIC(object, corrected = FALSE, k = k)+ #' @name mmrm_tidiers |
|||
| 491 | +19 |
- }+ #' @aliases mmrm_tidiers |
||
| 492 | +20 |
-
+ #' |
||
| 493 | +21 |
-
+ #' @seealso [`mmrm_methods`], [`mmrm_tmb_methods`] for additional methods. |
||
| 494 | +22 |
- #' @describeIn mmrm_tmb_methods prints the object.+ #' |
||
| 495 | +23 |
- #' @exportS3Method+ #' @examples |
||
| 496 | +24 |
- print.mmrm_tmb <- function(x,+ #' fit <- mmrm( |
||
| 497 | +25 |
- ...) {
+ #' formula = FEV1 ~ RACE + SEX + ARMCD * AVISIT + us(AVISIT | USUBJID), |
||
| 498 | -2x | +|||
| 26 | +
- cat("mmrm fit\n\n")
+ #' data = fev_data |
|||
| 499 | +27 |
-
+ #' ) |
||
| 500 | -2x | +|||
| 28 | +
- h_print_call(+ NULL |
|||
| 501 | -2x | +|||
| 29 | +
- component(x, "call"), component(x, "n_obs"),+ |
|||
| 502 | -2x | +|||
| 30 | +
- component(x, "n_subjects"), component(x, "n_timepoints")+ #' @describeIn mmrm_tidiers derives tidy `tibble` from an `mmrm` object. |
|||
| 503 | +31 |
- )+ #' @exportS3Method |
||
| 504 | -2x | +|||
| 32 | +
- h_print_cov(component(x, "cov_type"), component(x, "n_theta"), component(x, "n_groups"))+ #' @examples |
|||
| 505 | +33 |
-
+ #' # Applying tidy method to return summary table of covariate estimates. |
||
| 506 | -2x | +|||
| 34 | +
- cat("Inference: ")
+ #' fit |> tidy() |
|||
| 507 | -2x | +|||
| 35 | +
- cat(ifelse(component(x, "reml"), "REML", "ML"))+ #' fit |> tidy(conf.int = TRUE, conf.level = 0.9) |
|||
| 508 | -2x | +|||
| 36 | +
- cat("\n")
+ tidy.mmrm <- function(x, # nolint |
|||
| 509 | -2x | +|||
| 37 | +
- cat("Deviance: ")
+ conf.int = FALSE, # nolint |
|||
| 510 | -2x | +|||
| 38 | +
- cat(deviance(x))+ conf.level = 0.95, # nolint |
|||
| 511 | +39 |
-
+ ...) {
|
||
| 512 | -2x | +40 | +5x |
- cat("\n\nCoefficients: ")
+ assert_flag(conf.int) |
| 513 | -2x | +41 | +5x |
- n_singular_coefs <- sum(component(x, "beta_aliased"))+ assert_number(conf.level, lower = 0, upper = 1) |
| 514 | -2x | +42 | +5x |
- if (n_singular_coefs > 0) {
+ tbl <- tibble::as_tibble(summary(x)$coefficients, rownames = "term") |
| 515 | -1x | +43 | +5x |
- cat("(", n_singular_coefs, " not defined because of singularities)", sep = "")
+ colnames(tbl) <- c("term", "estimate", "std.error", "df", "statistic", "p.value")
+ |
+
| 44 | +5x | +
+ coefs <- coef(x)+ |
+ ||
| 45 | +5x | +
+ if (length(coefs) != nrow(tbl)) {
+ |
+ ||
| 46 | +! | +
+ coefs <- tibble::enframe(coefs, name = "term", value = "estimate")+ |
+ ||
| 47 | +! | +
+ tbl <- merge(coefs, tbl, by = c("term", "estimate"))
|
||
| 516 | +48 |
} |
||
| 517 | -2x | +49 | +5x |
- cat("\n")
+ if (conf.int) {
|
| 518 | -2x | +50 | +4x |
- print(coef(x, complete = TRUE))+ ci <- h_tbl_confint_terms(x, level = conf.level)+ |
+
| 51 | +4x | +
+ tbl <- tibble::as_tibble(merge(tbl, ci, by = "term")) |
||
| 519 | +52 |
-
+ } |
||
| 520 | -2x | +53 | +5x |
- cat("\nModel Inference Optimization:")
+ tbl |
| 521 | +54 |
-
+ } |
||
| 522 | -2x | +|||
| 55 | +
- cat(ifelse(component(x, "convergence") == 0, "\nConverged", "\nFailed to converge"))+ |
|||
| 523 | -2x | +|||
| 56 | +
- cat(+ #' @describeIn mmrm_tidiers derives `glance` `tibble` from an `mmrm` object. |
|||
| 524 | -2x | +|||
| 57 | +
- " with code", component(x, "convergence"),+ #' @exportS3Method |
|||
| 525 | -2x | +|||
| 58 | +
- "and message:",+ #' @examples |
|||
| 526 | -2x | +|||
| 59 | +
- if (is.null(component(x, "conv_message"))) "No message provided." else tolower(component(x, "conv_message"))+ #' # Applying glance method to return summary table of goodness of fit statistics. |
|||
| 527 | +60 |
- )+ #' fit |> glance() |
||
| 528 | -2x | +|||
| 61 | +
- cat("\n")
+ glance.mmrm <- function(x, ...) { # nolint
|
|||
| 529 | -2x | +62 | +1x |
- invisible(x)+ tibble::as_tibble(summary(x)$aic_list) |
| 530 | +63 |
} |
||
| 531 | +64 | |||
| 532 | +65 |
-
+ #' @describeIn mmrm_tidiers derives `augment` `tibble` from an `mmrm` object. |
||
| 533 | +66 |
- #' @describeIn mmrm_tmb_methods to obtain residuals - either unscaled ('response'), 'pearson' or 'normalized'.
+ #' @exportS3Method |
||
| 534 | +67 |
- #' @param type (`string`)\cr unscaled (`response`), `pearson` or `normalized`. Default is `response`,+ #' @examples |
||
| 535 | +68 |
- #' and this is the only type available for use with models with a spatial covariance structure.+ #' # Applying augment method to return merged `tibble` of model data, fitted and residuals. |
||
| 536 | +69 |
- #' @importFrom stats residuals+ #' fit |> augment() |
||
| 537 | +70 |
- #' @exportS3Method+ #' fit |> augment(interval = "confidence") |
||
| 538 | +71 |
- #' @examples+ #' fit |> augment(type.residuals = "pearson") |
||
| 539 | +72 |
- #' # residuals:+ augment.mmrm <- function(x, # nolint |
||
| 540 | +73 |
- #' residuals(object, type = "response")+ newdata = NULL, |
||
| 541 | +74 |
- #' residuals(object, type = "pearson")+ interval = c("none", "confidence", "prediction"),
|
||
| 542 | +75 |
- #' residuals(object, type = "normalized")+ se_fit = (interval != "none"), |
||
| 543 | +76 |
- #' @references+ type.residuals = c("response", "pearson", "normalized"), # nolint
|
||
| 544 | +77 |
- #' - \insertRef{galecki2013linear}{mmrm}
+ ...) {
|
||
| 545 | -+ | |||
| 78 | +9x |
- residuals.mmrm_tmb <- function(object, type = c("response", "pearson", "normalized"), ...) {
+ type.residuals <- match.arg(type.residuals) # nolint |
||
| 546 | -20x | +79 | +9x |
- type <- match.arg(type)+ resid_df <- NULL |
| 547 | -20x | +80 | +9x |
- switch(type,+ if (is.null(newdata)) {
|
| 548 | -8x | +81 | +4x |
- "response" = h_residuals_response(object),+ newdata <- stats::get_all_vars(x, data = stats::na.omit(x$data)) |
| 549 | -5x | +82 | +4x |
- "pearson" = h_residuals_pearson(object),+ resid_df <- data.frame( |
| 550 | -7x | +83 | +4x |
- "normalized" = h_residuals_normalized(object)+ .rownames = rownames(newdata), |
| 551 | -+ | |||
| 84 | +4x |
- )+ .resid = unname(residuals(x, type = type.residuals)) |
||
| 552 | +85 |
- }+ ) |
||
| 553 | +86 |
- #' Calculate Pearson Residuals+ } |
||
| 554 | -+ | |||
| 87 | +9x |
- #'+ interval <- match.arg(interval) |
||
| 555 | +88 |
- #' This is used by [residuals.mmrm_tmb()] to calculate Pearson residuals.+ |
||
| 556 | -+ | |||
| 89 | +9x |
- #'+ tbl <- h_newdata_add_pred( |
||
| 557 | -+ | |||
| 90 | +9x |
- #' @param object (`mmrm_tmb`)\cr the fitted MMRM.+ x, |
||
| 558 | -+ | |||
| 91 | +9x |
- #'+ newdata = newdata, |
||
| 559 | -+ | |||
| 92 | +9x |
- #' @return Vector of residuals.+ se_fit = se_fit, |
||
| 560 | -+ | |||
| 93 | +9x |
- #'+ interval = interval, |
||
| 561 | +94 |
- #' @keywords internal+ ... |
||
| 562 | +95 |
- h_residuals_pearson <- function(object) {
+ ) |
||
| 563 | -6x | +96 | +9x |
- assert_class(object, "mmrm_tmb")+ if (!is.null(resid_df)) {
|
| 564 | -6x | +97 | +4x |
- h_residuals_response(object) * object$tmb_object$report()$diag_cov_inv_sqrt+ tbl <- merge(tbl, resid_df, by = ".rownames") |
| 565 | -+ | |||
| 98 | +4x |
- }+ tbl$.rownames <- as.numeric(tbl$.rownames) |
||
| 566 | -+ | |||
| 99 | +4x |
-
+ tbl <- tbl[order(tbl$.rownames), , drop = FALSE] |
||
| 567 | +100 |
- #' Calculate normalized residuals+ } |
||
| 568 | -+ | |||
| 101 | +9x |
- #'+ tibble::as_tibble(tbl) |
||
| 569 | +102 |
- #' This is used by [residuals.mmrm_tmb()] to calculate normalized / scaled residuals.+ } |
||
| 570 | +103 |
- #'+ |
||
| 571 | +104 |
- #' @param object (`mmrm_tmb`)\cr the fitted MMRM.+ #' Extract `tibble` with Confidence Intervals and Term Names |
||
| 572 | +105 |
#' |
||
| 573 | +106 |
- #' @return Vector of residuals+ #' This is used in [tidy.mmrm()]. |
||
| 574 | +107 |
#' |
||
| 575 | +108 |
- #' @keywords internal+ #' @param x (`mmrm`)\cr fit object. |
||
| 576 | +109 |
- h_residuals_normalized <- function(object) {
- |
- ||
| 577 | -8x | -
- assert_class(object, "mmrm_tmb")- |
- ||
| 578 | -8x | -
- object$tmb_object$report()$epsilonTilde+ #' @param ... passed to [stats::confint()], hence not used at the moment. |
||
| 579 | +110 |
- }+ #' |
||
| 580 | +111 |
- #' Calculate response residuals.+ #' @return A `tibble` with `term`, `conf.low`, `conf.high` columns. |
||
| 581 | +112 |
#' |
||
| 582 | +113 |
- #' This is used by [residuals.mmrm_tmb()] to calculate response residuals.+ #' @keywords internal |
||
| 583 | +114 |
- #'+ h_tbl_confint_terms <- function(x, ...) {
|
||
| 584 | -+ | |||
| 115 | +8x |
- #' @param object (`mmrm_tmb`)\cr the fitted MMRM.+ df <- stats::confint(x, ...) |
||
| 585 | -+ | |||
| 116 | +8x |
- #'+ tbl <- tibble::as_tibble(df, rownames = "term", .name_repair = "minimal") |
||
| 586 | -+ | |||
| 117 | +8x |
- #' @return Vector of residuals+ names(tbl) <- c("term", "conf.low", "conf.high")
|
||
| 587 | -+ | |||
| 118 | +8x |
- #'+ tbl |
||
| 588 | +119 |
- #' @keywords internal+ } |
||
| 589 | +120 |
- h_residuals_response <- function(object) {
- |
- ||
| 590 | -15x | -
- assert_class(object, "mmrm_tmb")+ |
||
| 591 | -15x | +|||
| 121 | +
- component(object, "y_vector") - unname(fitted(object))+ #' Add Prediction Results to New Data |
|||
| 592 | +122 |
- }+ #' |
||
| 593 | +123 |
-
+ #' This is used in [augment.mmrm()]. |
||
| 594 | +124 |
- #' @describeIn mmrm_tmb_methods simulate responses from a fitted model according+ #' |
||
| 595 | +125 |
- #' to the simulation `method`, returning a `data.frame` of dimension `[n, m]`+ #' @param x (`mmrm`)\cr fit. |
||
| 596 | +126 |
- #' where n is the number of rows in `newdata`,+ #' @param newdata (`data.frame`)\cr data to predict. |
||
| 597 | +127 |
- #' and m is the number `nsim` of simulated responses.+ #' @param se_fit (`flag`)\cr whether to return standard error of prediction, |
||
| 598 | +128 |
- #'+ #' can only be used when `interval` is not "none". |
||
| 599 | +129 |
- #' @param seed unused argument from [stats::simulate()].+ #' @param interval (`string`)\cr type of interval. |
||
| 600 | +130 |
- #' @param method (`string`)\cr simulation method to use. If "conditional",+ #' @param ... passed to [predict.mmrm_tmb()]. |
||
| 601 | +131 |
- #' simulated values are sampled given the estimated covariance matrix of `object`.+ #' |
||
| 602 | +132 |
- #' If "marginal", the variance of the estimated covariance matrix is taken into account.+ #' @return The `newdata` as a `tibble` with additional columns `.fitted`, |
||
| 603 | +133 |
- #'+ #' `.lower`, `.upper` (if interval is not `none`) and `.se.fit` (if `se_fit` |
||
| 604 | +134 |
- #' @importFrom stats simulate+ #' requested). |
||
| 605 | +135 |
- #' @exportS3Method+ #' |
||
| 606 | +136 |
- simulate.mmrm_tmb <- function(object,+ #' @keywords internal |
||
| 607 | +137 |
- nsim = 1,+ h_newdata_add_pred <- function(x, |
||
| 608 | +138 |
- seed = NULL,+ newdata, |
||
| 609 | +139 |
- newdata,+ se_fit, |
||
| 610 | +140 |
- ...,+ interval, |
||
| 611 | +141 |
- method = c("conditional", "marginal")) {
+ ...) {
|
||
| 612 | -15x | +142 | +13x |
- assert_count(nsim, positive = TRUE)+ assert_class(x, "mmrm") |
| 613 | -15x | +143 | +13x |
- assert_null(seed)+ assert_data_frame(newdata) |
| 614 | -15x | +144 | +13x |
- if (missing(newdata)) {
+ assert_flag(se_fit) |
| 615 | -12x | -
- newdata <- object$data- |
- ||
| 616 | -+ | 145 | +13x |
- }+ assert_string(interval) |
| 617 | -15x | +146 | +13x |
- assert_data_frame(newdata)+ if (interval == "none") {
|
| 618 | -15x | +147 | +7x |
- method <- match.arg(method)+ assert_false(se_fit) |
| 619 | +148 |
-
+ } |
||
| 620 | +149 | |||
| 621 | -15x | +150 | +12x |
- tmb_data <- h_mmrm_tmb_data(+ tbl <- h_df_to_tibble(newdata) |
| 622 | -15x | +151 | +12x |
- object$formula_parts, newdata,+ pred_results <- predict( |
| 623 | -15x | +152 | +12x |
- weights = rep(1, nrow(newdata)),+ x, |
| 624 | -15x | +153 | +12x |
- reml = TRUE,+ newdata = newdata, |
| 625 | -15x | +154 | +12x |
- singular = "keep",+ na.action = stats::na.pass, |
| 626 | -15x | +155 | +12x |
- drop_visit_levels = FALSE,+ se.fit = se_fit, |
| 627 | -15x | +156 | +12x |
- allow_na_response = TRUE,+ interval = interval, |
| 628 | -15x | +|||
| 157 | +
- drop_levels = FALSE,+ ... |
|||
| 629 | -15x | +|||
| 158 | +
- xlev = component(object, "xlev"),+ ) |
|||
| 630 | -15x | +159 | +12x |
- contrasts = component(object, "contrasts")+ if (interval == "none") {
|
| 631 | -+ | |||
| 160 | +6x |
- )+ assert_numeric(pred_results) |
||
| 632 | -15x | +161 | +6x |
- ret <- if (method == "conditional") {
+ tbl$.fitted <- unname(pred_results) |
| 633 | -8x | +|||
| 162 | +
- predict_res <- h_get_prediction(tmb_data, object$theta_est, object$beta_est, object$beta_vcov)+ } else {
|
|||
| 634 | -8x | +163 | +6x |
- as.data.frame(h_get_sim_per_subj(predict_res, tmb_data$n_subjects, nsim))+ assert_matrix(pred_results) |
| 635 | -15x | +164 | +6x |
- } else if (method == "marginal") {
+ tbl$.fitted <- unname(pred_results[, "fit"]) |
| 636 | -7x | +165 | +6x |
- theta_chol <- t(chol(object$theta_vcov))+ tbl$.lower <- unname(pred_results[, "lwr"]) |
| 637 | -7x | +166 | +6x |
- n_theta <- length(object$theta_est)+ tbl$.upper <- unname(pred_results[, "upr"]) |
| 638 | -7x | +|||
| 167 | +
- as.data.frame(+ } |
|||
| 639 | -7x | +168 | +12x |
- sapply(seq_len(nsim), function(x) {
+ if (se_fit) {
|
| 640 | -503x | +169 | +5x |
- newtheta <- object$theta_est + theta_chol %*% matrix(stats::rnorm(n_theta), ncol = 1)+ tbl$.se.fit <- unname(pred_results[, "se"]) |
| 641 | +170 |
- # Recalculate betas with sampled thetas.+ } |
||
| 642 | -503x | +171 | +12x |
- hold <- object$tmb_object$report(newtheta)+ tbl |
| 643 | +172 |
- # Resample betas given new beta distribution.+ } |
||
| 644 | +173 |
- # We first solve L^\top w = D^{-1/2}z_{sample}:
+
|
||
| 645 | -503x | +|||
| 174 | +
- w_sample <- backsolve(+ #' Coerce a Data Frame to a `tibble` |
|||
| 646 | -503x | +|||
| 175 | +
- r = hold$XtWX_L,+ #' |
|||
| 647 | -503x | +|||
| 176 | +
- x = stats::rnorm(length(hold$beta)) / sqrt(hold$XtWX_D),+ #' This is used in [h_newdata_add_pred()]. |
|||
| 648 | -503x | +|||
| 177 | +
- upper.tri = FALSE,- |
- |||
| 649 | -503x | -
- transpose = TRUE- |
- ||
| 650 | -- |
- )- |
- ||
| 651 | -- |
- # Then we add the mean vector, the beta estimate.- |
- ||
| 652 | -503x | -
- beta_sample <- hold$beta + w_sample- |
- ||
| 653 | -503x | -
- predict_res <- h_get_prediction(tmb_data, newtheta, beta_sample, hold$beta_vcov)- |
- ||
| 654 | -503x | -
- h_get_sim_per_subj(predict_res, tmb_data$n_subjects, 1L)- |
- ||
| 655 | -- |
- })- |
- ||
| 656 | -- |
- )+ #' |
||
| 657 | +178 |
- }- |
- ||
| 658 | -15x | -
- orig_row_names <- row.names(newdata)- |
- ||
| 659 | -15x | -
- new_order <- match(orig_row_names, row.names(tmb_data$full_frame))- |
- ||
| 660 | -15x | -
- ret[new_order, , drop = FALSE]+ #' @details This is only a thin wrapper around [tibble::as_tibble()], except |
||
| 661 | +179 |
- }+ #' giving a useful error message and it checks for `rownames` and adds them |
||
| 662 | +180 |
-
+ #' as a new column `.rownames` if they are not just a numeric sequence as |
||
| 663 | +181 |
- #' Get simulated values by patient.+ #' per the [tibble::has_rownames()] decision. |
||
| 664 | +182 |
#' |
||
| 665 | +183 |
- #' @param predict_res (`list`)\cr from [h_get_prediction()].+ #' @param data (`data.frame`)\cr what to coerce. |
||
| 666 | +184 |
- #' @param nsub (`count`)\cr number of subjects.+ #' |
||
| 667 | +185 |
- #' @param nsim (`count`)\cr number of values to simulate.+ #' @return The `data` as a `tibble`, potentially with a `.rownames` column. |
||
| 668 | +186 |
#' |
||
| 669 | +187 |
#' @keywords internal |
||
| 670 | -- |
- h_get_sim_per_subj <- function(predict_res, nsub, nsim) {
- |
- ||
| 671 | -517x | -
- assert_list(predict_res)- |
- ||
| 672 | -517x | -
- assert_count(nsub, positive = TRUE)- |
- ||
| 673 | -516x | -
- assert_count(nsim, positive = TRUE)- |
- ||
| 674 | -- | - - | -||
| 675 | -515x | -
- ret <- matrix(- |
- ||
| 676 | -515x | -
- predict_res$prediction[, "fit"],- |
- ||
| 677 | -515x | -
- ncol = nsim,- |
- ||
| 678 | -515x | -
- nrow = nrow(predict_res$prediction)- |
- ||
| 679 | -- |
- )- |
- ||
| 680 | -515x | -
- for (i in seq_len(nsub)) {
- |
- ||
| 681 | -- |
- # Skip subjects which are not included in predict_res.- |
- ||
| 682 | -82699x | -
- if (length(predict_res$index[[i]]) > 0) {
- |
- ||
| 683 | -- |
- # Obtain indices of data.frame belonging to subject i- |
- ||
| 684 | +188 |
- # (increment by 1, since indices from cpp are 0-order).+ h_df_to_tibble <- function(data) {
|
||
| 685 | -66631x | +189 | +15x |
- inds <- predict_res$index[[i]] + 1+ tryCatch(tbl <- tibble::as_tibble(data), error = function(cnd) {
|
| 686 | -66631x | -
- obs <- length(inds)- |
- ||
| 687 | -- | - - | -||
| 688 | -+ | 190 | +1x |
- # Get relevant covariance matrix for subject i.+ stop("Could not coerce data to `tibble`. Try explicitly passing a",
|
| 689 | -66631x | +191 | +1x |
- covmat_i <- predict_res$covariance[[i]]+ "dataset to either the `data` or `newdata` argument.", |
| 690 | -66631x | +192 | +1x |
- theta_chol <- t(chol(covmat_i))+ call. = FALSE |
| 691 | +193 |
-
+ ) |
||
| 692 | +194 |
- # Simulate epsilon from covariance matrix.- |
- ||
| 693 | -66631x | -
- mus <- ret[inds, , drop = FALSE]+ }) |
||
| 694 | -66631x | +195 | +14x |
- epsilons <- theta_chol %*% matrix(stats::rnorm(nsim * obs), ncol = nsim)+ if (tibble::has_rownames(data)) {
|
| 695 | -66631x | -
- ret[inds, ] <- mus + epsilons- |
- ||
| 696 | -+ | 196 | +5x |
- }+ tbl <- tibble::add_column(tbl, .rownames = rownames(data), .before = TRUE) |
| 697 | +197 |
} |
||
| 698 | -- | - - | -||
| 699 | -515x | +198 | +14x |
- ret+ tbl |
| 700 | +199 |
}@@ -19913,14 +19377,14 @@ mmrm coverage - 97.08% |
| 1 |
- #' Processing the Formula for `TMB` Fit+ #' Dynamic Registration for Package Interoperability |
||
| 3 |
- #' @param formula (`formula`)\cr Original formula.+ #' @seealso See `vignette("xtending", package = "emmeans")` for background.
|
||
| 4 |
- #' @param covariance (`cov_struct`)\cr A covariance structure from which+ #' @keywords internal |
||
| 5 |
- #' additional formula parts should be added.+ #' @noRd |
||
| 6 |
- #'+ .onLoad <- function(libname, pkgname) { # nolint
|
||
| 7 | -+ | ! |
- #' @return List of class `mmrm_tmb_formula_parts` with elements:+ if (utils::packageVersion("TMB") < "1.9.15") {
|
| 8 | -+ | ! |
- #'+ warning("TMB version 1.9.15 or higher is required for reproducible model fits", call. = FALSE)
|
| 9 |
- #' - `formula`: the original input.+ } |
||
| 10 |
- #' - `model_formula`: `formula` with the covariance term is removed.+ |
||
| 11 | -+ | ! |
- #' - `model_formula`: `formula` with the covariance term removed.+ register_on_load( |
| 12 | -+ | ! |
- #' - `full_formula`: same as `model_formula` but includes the covariance+ "emmeans", c("1.6", NA),
|
| 13 | -+ | ! |
- #' structure's subject, visit and (optionally) group variables.+ callback = function() emmeans::.emm_register("mmrm", pkgname),
|
| 14 | -+ | ! |
- #' - `cov_type`: `string` with covariance term type (e.g. `"us"`).+ message = "mmrm() registered as emmeans extension" |
| 15 |
- #' - `is_spatial`: `flag` indicator of whether the covariance structure is+ ) |
||
| 16 |
- #' spatial+ |
||
| 17 | -+ | ! |
- #' - `visit_var`: `character` with the visit variable name.+ register_on_load( |
| 18 | -+ | ! |
- #' - `subject_var`: `string` with the subject variable name.+ "parsnip", c("1.1.0", NA),
|
| 19 | -+ | ! |
- #' - `group_var`: `string` with the group variable name. If no group specified,+ callback = parsnip_add_mmrm, |
| 20 | -+ | ! |
- #' this element is `NULL`.+ message = emit_tidymodels_register_msg |
| 21 |
- #' - `model_var`: `character` with the variables names of the formula, except `subject_var`.+ ) |
||
| 22 | -+ | ! |
- #'+ register_on_load( |
| 23 | -+ | ! |
- #' @keywords internal+ "car", c("3.1.2", NA),
|
| 24 | -+ | ! |
- h_mmrm_tmb_formula_parts <- function(+ callback = car_add_mmrm, |
| 25 | -+ | ! |
- formula,+ message = "mmrm() registered as car::Anova extension" |
| 26 |
- covariance = as.cov_struct(formula, warn_partial = FALSE)) {
+ ) |
||
| 27 | -269x | +
- assert_formula(formula)+ } |
|
| 28 | -269x | +
- assert_true(identical(length(formula), 3L))+ |
|
| 29 |
-
+ #' Helper Function for Registering Functionality With Suggests Packages |
||
| 30 | -269x | +
- model_formula <- h_drop_covariance_terms(formula)+ #' |
|
| 31 |
-
+ #' @inheritParams check_package_version |
||
| 32 | -269x | +
- structure(+ #' |
|
| 33 | -269x | +
- list(+ #' @param callback (`function(...) ANY`)\cr a callback to execute upon package |
|
| 34 | -269x | +
- formula = formula,+ #' load. Note that no arguments are passed to this function. Any necessary |
|
| 35 | -269x | +
- model_formula = model_formula,+ #' data must be provided upon construction. |
|
| 36 | -269x | +
- full_formula = h_add_covariance_terms(model_formula, covariance),+ #' |
|
| 37 | -269x | +
- cov_type = tmb_cov_type(covariance),+ #' @param message (`NULL` or `string`)\cr an optional message to print after |
|
| 38 | -269x | +
- is_spatial = covariance$type == "sp_exp",+ #' the callback is executed upon successful registration. |
|
| 39 | -269x | +
- visit_var = covariance$visits,+ #' |
|
| 40 | -269x | +
- subject_var = covariance$subject,+ #' @return A logical (invisibly) indicating whether registration was successful. |
|
| 41 | -269x | +
- group_var = if (length(covariance$group) < 1) NULL else covariance$group,+ #' If not, a onLoad hook was set for the next time the package is loaded. |
|
| 42 | -269x | +
- model_var = setdiff(all.vars(formula[[3]]), covariance$subject)+ #' |
|
| 43 |
- ),+ #' @keywords internal |
||
| 44 | -269x | +
- class = "mmrm_tmb_formula_parts"+ register_on_load <- function(pkg, |
|
| 45 |
- )+ ver = c(NA_character_, NA_character_), |
||
| 46 |
- }+ callback, |
||
| 47 |
-
+ message = NULL) {
|
||
| 48 | -+ | 4x |
- #' Data for `TMB` Fit+ if (isNamespaceLoaded(pkg) && check_package_version(pkg, ver)) {
|
| 49 | -+ | 3x |
- #'+ callback() |
| 50 | -+ | 2x |
- #' @param formula_parts (`mmrm_tmb_formula_parts`)\cr list with formula parts+ if (is.character(message)) packageStartupMessage(message) |
| 51 | -+ | 1x |
- #' from [h_mmrm_tmb_formula_parts()].+ if (is.function(message)) packageStartupMessage(message()) |
| 52 | -+ | 3x |
- #' @param data (`data.frame`)\cr which contains variables used in `formula_parts`.+ return(invisible(TRUE)) |
| 53 |
- #' @param weights (`vector`)\cr weights to be used in the fitting process.+ } |
||
| 54 |
- #' @param reml (`flag`)\cr whether restricted maximum likelihood (REML) estimation is used,+ |
||
| 55 | -+ | 1x |
- #' otherwise maximum likelihood (ML) is used.+ setHook( |
| 56 | -+ | 1x |
- #' @param singular (`string`)\cr choices of method deal with rank-deficient matrices. "error" to+ packageEvent(pkg, event = "onLoad"), |
| 57 | -+ | 1x |
- #' stop the function return the error, "drop" to drop these columns, and "keep" to keep all the columns.+ action = "append", |
| 58 | -+ | 1x |
- #' @param drop_visit_levels (`flag`)\cr whether to drop levels for visit variable, if visit variable is a factor.+ function(...) {
|
| 59 | -+ | ! |
- #' @param allow_na_response (`flag`)\cr whether NA in response is allowed.+ register_on_load( |
| 60 | -+ | ! |
- #' @param drop_levels (`flag`)\cr whether drop levels for covariates. If not dropped could lead to singular matrix.+ pkg = pkg, |
| 61 | -+ | ! |
- #'+ ver = ver, |
| 62 | -+ | ! |
- #' @return List of class `mmrm_tmb_data` with elements:+ callback = callback, |
| 63 | -+ | ! |
- #' - `full_frame`: `data.frame` with `n` rows containing all variables needed in the model.+ message = message |
| 64 |
- #' - `data`: `data.frame` of input dataset.+ ) |
||
| 65 |
- #' - `x_matrix`: `matrix` with `n` rows and `p` columns specifying the overall design matrix.+ } |
||
| 66 |
- #' - `x_cols_aliased`: `logical` with potentially more than `p` elements indicating which+ ) |
||
| 67 |
- #' columns in the original design matrix have been left out to obtain a full rank+ |
||
| 68 | -+ | 1x |
- #' `x_matrix`.+ invisible(FALSE) |
| 69 |
- #' - `y_vector`: length `n` `numeric` specifying the overall response vector.+ } |
||
| 70 |
- #' - `weights_vector`: length `n` `numeric` specifying the weights vector.+ |
||
| 71 |
- #' - `n_visits`: `int` with the number of visits, which is the dimension of the+ #' Check Suggested Dependency Against Version Requirements |
||
| 72 |
- #' covariance matrix.+ #' |
||
| 73 |
- #' - `n_subjects`: `int` with the number of subjects.+ #' @param pkg (`string`)\cr package name. |
||
| 74 |
- #' - `subject_zero_inds`: length `n_subjects` `integer` containing the zero-based start+ #' @param ver (`character`)\cr of length 2 whose elements can be provided to |
||
| 75 |
- #' indices for each subject.+ #' [numeric_version()], representing a minimum and maximum (inclusive) version |
||
| 76 |
- #' - `subject_n_visits`: length `n_subjects` `integer` containing the number of+ #' requirement for interoperability. When `NA`, no version requirement is |
||
| 77 |
- #' observed visits for each subjects. So the sum of this vector equals `n`.+ #' imposed. Defaults to no version requirement. |
||
| 78 |
- #' - `cov_type`: `string` value specifying the covariance type.+ #' |
||
| 79 |
- #' - `is_spatial_int`: `int` specifying whether the covariance structure is spatial(1) or not(0).+ #' @return A logical (invisibly) indicating whether the loaded package meets |
||
| 80 |
- #' - `reml`: `int` specifying whether REML estimation is used (1), otherwise ML (0).+ #' the version requirements. A warning is emitted otherwise. |
||
| 81 |
- #' - `subject_groups`: `factor` specifying the grouping for each subject.+ #' |
||
| 82 |
- #' - `n_groups`: `int` with the number of total groups+ #' @keywords internal |
||
| 83 |
- #'+ check_package_version <- function(pkg, ver = c(NA_character_, NA_character_)) {
|
||
| 84 | -+ | 7x |
- #' @details Note that the `subject_var` must not be factor but can also be character.+ assert_character(ver, len = 2L) |
| 85 | -+ | 6x |
- #' If it is character, then it will be converted to factor internally. Here+ pkg_ver <- utils::packageVersion(pkg) |
| 86 | -+ | 6x |
- #' the levels will be the unique values, sorted alphabetically and numerically if there+ ver <- numeric_version(ver, strict = FALSE) |
| 87 |
- #' is a common string prefix of numbers in the character elements. For full control+ |
||
| 88 | -+ | 6x |
- #' on the order please use a factor.+ warn_version <- function(pkg, pkg_ver, ver) {
|
| 89 | -+ | 2x |
- #'+ ver_na <- is.na(ver) |
| 90 | -+ | 2x |
- #' @keywords internal+ warning(sprintf( |
| 91 | -+ | 2x |
- h_mmrm_tmb_data <- function(formula_parts,+ "Cannot register mmrm for use with %s (v%s). Version %s required.", |
| 92 | -+ | 2x |
- data,+ pkg, pkg_ver, |
| 93 | -+ | 2x |
- weights,+ if (!any(ver_na)) {
|
| 94 | -+ | ! |
- reml,+ sprintf("%s to %s", ver[1], ver[2])
|
| 95 | -+ | 2x |
- singular = c("drop", "error", "keep"),
+ } else if (ver_na[2]) {
|
| 96 | -+ | 1x |
- drop_visit_levels,+ paste0(">= ", ver[1])
|
| 97 | -+ | 2x |
- allow_na_response = FALSE,+ } else if (ver_na[1]) {
|
| 98 | -+ | 1x |
- drop_levels = TRUE,+ paste0("<= ", ver[2])
|
| 99 |
- xlev = NULL,+ } |
||
| 100 |
- contrasts = NULL) {
+ )) |
||
| 101 | -311x | +
- assert_class(formula_parts, "mmrm_tmb_formula_parts")+ } |
|
| 102 | -311x | +
- assert_data_frame(data)+ |
|
| 103 | -311x | +6x |
- varname <- formula_parts[grepl("_var", names(formula_parts))]
+ if (identical(pkg_ver < ver[1], TRUE) || identical(pkg_ver > ver[2], TRUE)) {
|
| 104 | -311x | +2x |
- assert_names(+ warn_version(pkg, pkg_ver, ver) |
| 105 | -311x | +2x |
- names(data),+ return(invisible(FALSE)) |
| 106 | -311x | +
- must.include = unlist(varname, use.names = FALSE)+ } |
|
| 107 |
- )+ |
||
| 108 | -311x | +4x |
- assert_true(is.factor(data[[formula_parts$subject_var]]) || is.character(data[[formula_parts$subject_var]]))+ invisible(TRUE) |
| 109 | -311x | +
- assert_numeric(weights, len = nrow(data))+ } |
|
| 110 | -311x | +
- assert_flag(reml)+ |
|
| 111 | -311x | +
- singular <- match.arg(singular)+ #' Format a Message to Emit When Tidymodels is Loaded |
|
| 112 | -311x | +
- assert_flag(drop_visit_levels)+ #' |
|
| 113 |
-
+ #' @return A character message to emit. Either a ansi-formatted cli output if |
||
| 114 | -311x | +
- if (is.character(data[[formula_parts$subject_var]])) {
+ #' package 'cli' is available or a plain-text message otherwise. |
|
| 115 | -5x | +
- data[[formula_parts$subject_var]] <- factor(+ #' |
|
| 116 | -5x | +
- data[[formula_parts$subject_var]],+ #' @keywords internal |
|
| 117 | -5x | +
- levels = stringr::str_sort(unique(data[[formula_parts$subject_var]]), numeric = TRUE)+ emit_tidymodels_register_msg <- function() {
|
|
| 118 | -+ | 1x |
- )+ pkg <- utils::packageName() |
| 119 | -+ | 1x |
- }+ ver <- utils::packageVersion(pkg) |
| 120 | -311x | +
- data_order <- if (formula_parts$is_spatial) {
+
|
|
| 121 | -16x | +1x |
- order(data[[formula_parts$subject_var]])+ if (isTRUE(getOption("tidymodels.quiet"))) {
|
| 122 | -+ | ! |
- } else {
+ return() |
| 123 | -295x | +
- subject_visit_data <- data[, c(formula_parts$subject_var, formula_parts$visit_var)]+ } |
|
| 124 | -295x | +
- is_duplicated <- duplicated(subject_visit_data)+ |
|
| 125 | -295x | +
- if (any(is_duplicated)) {
+ # if tidymodels is attached, cli packages come as a dependency |
|
| 126 | 1x |
- stop(+ has_cli <- requireNamespace("cli", quietly = TRUE)
|
|
| 127 | 1x |
- "time points have to be unique for each subject, detected following duplicates in data:\n",+ if (has_cli) {
|
|
| 128 | -1x | +
- paste(utils::capture.output(print(subject_visit_data[is_duplicated, ])), collapse = "\n")+ # unfortunately, cli does not expose many formatting tools for emitting |
|
| 129 |
- )+ # messages (only via conditions to stderr) which can't be suppressed using |
||
| 130 |
- }+ # suppressPackageStartupMessages() so formatting must be done adhoc, |
||
| 131 | -294x | +
- order(data[[formula_parts$subject_var]], data[[formula_parts$visit_var]])+ # similar to how it's done in {tidymodels} R/attach.R
|
|
| 132 | -+ | 1x |
- }+ paste0( |
| 133 | -310x | +1x |
- if (identical(formula_parts$is_spatial, FALSE)) {
+ cli::rule( |
| 134 | -294x | +1x |
- h_confirm_large_levels(length(levels(data[[formula_parts$visit_var]])))+ left = cli::style_bold("Model Registration"),
|
| 135 | -+ | 1x |
- }+ right = paste(pkg, ver) |
| 136 | -309x | +
- data <- data[data_order, ]+ ), |
|
| 137 | -309x | +1x |
- weights <- weights[data_order]+ "\n", |
| 138 | -309x | +1x |
- data <- data.frame(data, weights)+ cli::col_green(cli::symbol$tick), " ", |
| 139 | -+ | 1x |
- # Weights is always the last column.+ cli::col_blue("mmrm"), "::", cli::col_green("mmrm()")
|
| 140 | -309x | +
- weights_name <- colnames(data)[ncol(data)]+ ) |
|
| 141 |
- # If `y` is allowed to be NA, then first replace y with 1:n, then replace it with original y.+ } else {
|
||
| 142 | -309x | +! |
- if (!allow_na_response) {
+ paste0(pkg, "::mmrm() registered for use with tidymodels") |
| 143 | -259x | +
- h_warn_na_action()+ } |
|
| 144 |
- }+ } |
||
| 145 | -309x | +
| 1 | +
- full_frame <- eval(+ #' Covariance Type Database |
|||
| 146 | -309x | +|||
| 2 | +
- bquote(stats::model.frame(+ #' |
|||
| 147 | -309x | +|||
| 3 | +
- formula_parts$full_formula,+ #' An internal constant for covariance type information. |
|||
| 148 | -309x | +|||
| 4 | +
- data = data,+ #' |
|||
| 149 | -309x | +|||
| 5 | +
- weights = .(as.symbol(weights_name)),+ #' @format A data frame with 5 variables and one record per covariance type: |
|||
| 150 | -309x | +|||
| 6 | +
- na.action = "na.pass",+ #' |
|||
| 151 | -309x | +|||
| 7 | +
- xlev = xlev+ #' \describe{
|
|||
| 152 | +8 |
- ))+ #' \item{name}{
|
||
| 153 | +9 |
- )+ #' The long-form name of the covariance structure type |
||
| 154 | -309x | +|||
| 10 | +
- if (drop_levels) {
+ #' } |
|||
| 155 | -261x | +|||
| 11 | +
- full_frame <- h_drop_levels(full_frame, formula_parts$subject_var, formula_parts$visit_var, names(xlev))+ #' \item{abbr}{
|
|||
| 156 | +12 |
- }+ #' The abbreviated name of the covariance structure type |
||
| 157 | -309x | +|||
| 13 | +
- has_response <- !identical(attr(attr(full_frame, "terms"), "response"), 0L)+ #' } |
|||
| 158 | -309x | +|||
| 14 | +
- keep_ind <- if (allow_na_response && has_response) {
+ #' \item{habbr}{
|
|||
| 159 | +15 |
- # Note that response is always the first column if there is response.+ #' The abbreviated name of the heterogeneous version of a covariance |
||
| 160 | -50x | +|||
| 16 | +
- stats::complete.cases(full_frame[, -1L, drop = FALSE])+ #' structure type (The abbreviated name (`abbr`) with a trailing `"h"` if |
|||
| 161 | +17 |
- } else {
+ #' the structure has a heterogeneous implementation or `NA` otherwise). |
||
| 162 | -259x | +|||
| 18 | +
- stats::complete.cases(full_frame)+ #' } |
|||
| 163 | +19 |
- }+ #' \item{heterogeneous}{
|
||
| 164 | -309x | +|||
| 20 | +
- full_frame <- full_frame[keep_ind, ]+ #' A logical value indicating whether the covariance structure has a |
|||
| 165 | -309x | +|||
| 21 | +
- if (drop_visit_levels && !formula_parts$is_spatial && h_extra_levels(full_frame[[formula_parts$visit_var]])) {
+ #' heterogeneous counterpart. |
|||
| 166 | -3x | +|||
| 22 | +
- visit_vec <- full_frame[[formula_parts$visit_var]]+ #' } |
|||
| 167 | -3x | +|||
| 23 | +
- old_levels <- levels(visit_vec)+ #' \item{spatial}{
|
|||
| 168 | -3x | +|||
| 24 | +
- full_frame[[formula_parts$visit_var]] <- droplevels(visit_vec)+ #' A logical value indicating whether the covariance structure is spatial. |
|||
| 169 | -3x | +|||
| 25 | +
- new_levels <- levels(full_frame[[formula_parts$visit_var]])+ #' } |
|||
| 170 | -3x | +|||
| 26 | +
- dropped <- setdiff(old_levels, new_levels)+ #' } |
|||
| 171 | -3x | +|||
| 27 | +
- message(+ #' |
|||
| 172 | -3x | +|||
| 28 | +
- "In ", formula_parts$visit_var, " there are dropped visits: ", toString(dropped),+ #' @keywords internal |
|||
| 173 | -3x | +|||
| 29 | +
- ".\n Additional attributes including contrasts are lost.\n",+ COV_TYPES <- local({ # nolint
|
|||
| 174 | -3x | +|||
| 30 | +
- "To avoid this behavior, make sure use `drop_visit_levels = FALSE`."+ type <- function(name, abbr, habbr, heterogeneous, spatial) {
|
|||
| 175 | +31 |
- )+ args <- as.list(match.call()[-1]) |
||
| 176 | +32 | ++ |
+ do.call(data.frame, args)+ |
+ |
| 33 |
} |
|||
| 177 | -309x | +|||
| 34 | +
- is_factor_col <- vapply(full_frame, is.factor, FUN.VALUE = TRUE)+ |
|||
| 178 | -309x | +|||
| 35 | +
- is_factor_col <- intersect(names(is_factor_col)[is_factor_col], all.vars(formula_parts$model_formula))+ as.data.frame( |
|||
| 179 | -309x | +|||
| 36 | +
- x_matrix <- stats::model.matrix(+ col.names = names(formals(type)), |
|||
| 180 | -309x | +|||
| 37 | +
- formula_parts$model_formula,+ rbind( |
|||
| 181 | -309x | +|||
| 38 | +
- data = full_frame,+ type("unstructured", "us", NA, FALSE, FALSE),
|
|||
| 182 | -309x | +|||
| 39 | +
- contrasts.arg = h_default_value(contrasts, lapply(full_frame[is_factor_col], contrasts))+ type("Toeplitz", "toep", "toeph", TRUE, FALSE),
|
|||
| 183 | +40 | ++ |
+ type("auto-regressive order one", "ar1", "ar1h", TRUE, FALSE),
+ |
+ |
| 41 | ++ |
+ type("ante-dependence", "ad", "adh", TRUE, FALSE),
+ |
+ ||
| 42 | ++ |
+ type("compound symmetry", "cs", "csh", TRUE, FALSE),
+ |
+ ||
| 43 | ++ |
+ type("spatial exponential", "sp_exp", NA, FALSE, TRUE)
+ |
+ ||
| 44 | ++ |
+ )+ |
+ ||
| 45 |
) |
|||
| 184 | -308x | +|||
| 46 | +
- x_cols_aliased <- stats::setNames(rep(FALSE, ncol(x_matrix)), nm = colnames(x_matrix))+ }) |
|||
| 185 | -308x | +|||
| 47 | +
- qr_x_mat <- qr(x_matrix)+ |
|||
| 186 | -308x | +|||
| 48 | +
- if (qr_x_mat$rank < ncol(x_matrix)) {
+ #' Covariance Types |
|||
| 187 | -23x | +|||
| 49 | +
- cols_to_drop <- utils::tail(qr_x_mat$pivot, ncol(x_matrix) - qr_x_mat$rank)+ #' |
|||
| 188 | -23x | +|||
| 50 | +
- if (identical(singular, "error")) {
+ #' @description `r lifecycle::badge("stable")`
|
|||
| 189 | -1x | +|||
| 51 | +
- stop(+ #' |
|||
| 190 | -1x | +|||
| 52 | +
- "design matrix only has rank ", qr_x_mat$rank, " and ", length(cols_to_drop),+ #' @param form (`character`)\cr covariance structure type name form. One or |
|||
| 191 | -1x | +|||
| 53 | +
- " columns (", toString(colnames(x_matrix)[cols_to_drop]), ") could be dropped",
+ #' more of `"name"`, `"abbr"` (abbreviation), or `"habbr"` (heterogeneous |
|||
| 192 | -1x | +|||
| 54 | +
- " to achieve full rank ", ncol(x_matrix), " by using `accept_singular = TRUE`"+ #' abbreviation). |
|||
| 193 | +55 |
- )+ #' @param filter (`character`)\cr covariance structure type filter. One or |
||
| 194 | -22x | +|||
| 56 | +
- } else if (identical(singular, "drop")) {
+ #' more of `"heterogeneous"` or `"spatial"`. |
|||
| 195 | -11x | +|||
| 57 | +
- assign_attr <- attr(x_matrix, "assign")+ #' |
|||
| 196 | -11x | +|||
| 58 | +
- contrasts_attr <- attr(x_matrix, "contrasts")+ #' @return A character vector of accepted covariance structure type names and |
|||
| 197 | -11x | +|||
| 59 | +
- x_matrix <- x_matrix[, -cols_to_drop, drop = FALSE]+ #' abbreviations. |
|||
| 198 | -11x | +|||
| 60 | +
- x_cols_aliased[cols_to_drop] <- TRUE+ #' |
|||
| 199 | -11x | +|||
| 61 | +
- attr(x_matrix, "assign") <- assign_attr[-cols_to_drop]+ #' @section Abbreviations for Covariance Structures: |
|||
| 200 | -11x | +|||
| 62 | +
- attr(x_matrix, "contrasts") <- contrasts_attr+ #' |
|||
| 201 | +63 |
- }+ #' ## Common Covariance Structures: |
||
| 202 | +64 |
- }+ #' |
||
| 203 | -307x | +|||
| 65 | +
- y_vector <- if (has_response) {
+ #' \tabular{clll}{
|
|||
| 204 | -307x | +|||
| 66 | +
- as.numeric(stats::model.response(full_frame))+ #' |
|||
| 205 | +67 |
- } else {
+ #' \strong{Structure}
|
||
| 206 | -! | +|||
| 68 | +
- rep(NA_real_, nrow(full_frame))+ #' \tab \strong{Description}
|
|||
| 207 | +69 |
- }+ #' \tab \strong{Parameters}
|
||
| 208 | -307x | +|||
| 70 | +
- weights_vector <- as.numeric(stats::model.weights(full_frame))+ #' \tab \strong{\eqn{(i, j)} element}
|
|||
| 209 | -307x | +|||
| 71 | +
- n_subjects <- length(unique(full_frame[[formula_parts$subject_var]]))+ #' \cr |
|||
| 210 | -307x | +|||
| 72 | +
- subject_zero_inds <- which(!duplicated(full_frame[[formula_parts$subject_var]])) - 1L+ #' |
|||
| 211 | -307x | +|||
| 73 | +
- subject_n_visits <- c(utils::tail(subject_zero_inds, -1L), nrow(full_frame)) - subject_zero_inds+ #' ad |
|||
| 212 | +74 |
- # It is possible that `subject_var` is factor with more levels (and this does not affect fit)+ #' \tab Ante-dependence |
||
| 213 | +75 |
- # so no check is needed for `subject_visits`.+ #' \tab \eqn{m}
|
||
| 214 | -307x | +|||
| 76 | +
- assert_true(all(subject_n_visits > 0))+ #' \tab \eqn{\sigma^{2}\prod_{k=i}^{j-1}\rho_{k}}
|
|||
| 215 | -307x | +|||
| 77 | +
- if (!is.null(formula_parts$group_var)) {
+ #' \cr |
|||
| 216 | -41x | +|||
| 78 | +
- assert_factor(data[[formula_parts$group_var]])+ #' |
|||
| 217 | -41x | +|||
| 79 | +
- subject_groups <- full_frame[[formula_parts$group_var]][subject_zero_inds + 1L]+ #' adh |
|||
| 218 | -41x | +|||
| 80 | +
- n_groups <- nlevels(subject_groups)+ #' \tab Heterogeneous ante-dependence |
|||
| 219 | +81 |
- } else {
+ #' \tab \eqn{2m-1}
|
||
| 220 | -266x | +|||
| 82 | +
- subject_groups <- factor(rep(0L, n_subjects))+ #' \tab \eqn{\sigma_{i}\sigma_{j}\prod_{k=i}^{j-1}\rho_{k}}
|
|||
| 221 | -266x | +|||
| 83 | +
- n_groups <- 1L+ #' \cr |
|||
| 222 | +84 |
- }+ #' |
||
| 223 | -307x | +|||
| 85 | +
- coordinates <- full_frame[, formula_parts$visit_var, drop = FALSE]+ #' ar1 |
|||
| 224 | -307x | +|||
| 86 | +
- if (formula_parts$is_spatial) {
+ #' \tab First-order auto-regressive |
|||
| 225 | -16x | +|||
| 87 | +
- lapply(coordinates, assert_numeric)+ #' \tab \eqn{2}
|
|||
| 226 | -16x | +|||
| 88 | +
- coordinates_matrix <- as.matrix(coordinates)+ #' \tab \eqn{\sigma^{2}\rho^{\left \vert {i-j} \right \vert}}
|
|||
| 227 | -16x | +|||
| 89 | +
- n_visits <- max(subject_n_visits)+ #' \cr |
|||
| 228 | +90 |
- } else {
+ #' |
||
| 229 | -291x | +|||
| 91 | +
- assert(identical(ncol(coordinates), 1L))+ #' ar1h |
|||
| 230 | -291x | +|||
| 92 | +
- assert_factor(coordinates[[1L]])+ #' \tab Heterogeneous first-order auto-regressive |
|||
| 231 | -291x | +|||
| 93 | +
- coordinates_matrix <- as.matrix(as.integer(coordinates[[1L]]) - 1, ncol = 1)+ #' \tab \eqn{m+1}
|
|||
| 232 | -291x | +|||
| 94 | +
- n_visits <- nlevels(coordinates[[1L]])+ #' \tab \eqn{\sigma_{i}\sigma_{j}\rho^{\left \vert {i-j} \right \vert}}
|
|||
| 233 | -291x | +|||
| 95 | +
- assert_true(all(subject_n_visits <= n_visits))+ #' \cr |
|||
| 234 | +96 |
- }+ #' |
||
| 235 | -307x | +|||
| 97 | +
- structure(+ #' cs |
|||
| 236 | -307x | +|||
| 98 | +
- list(+ #' \tab Compound symmetry |
|||
| 237 | -307x | +|||
| 99 | +
- full_frame = full_frame,+ #' \tab \eqn{2}
|
|||
| 238 | -307x | +|||
| 100 | +
- data = data,+ #' \tab \eqn{\sigma^{2}\left[ \rho I(i \neq j)+I(i=j) \right]}
|
|||
| 239 | -307x | +|||
| 101 | +
- x_matrix = x_matrix,+ #' \cr |
|||
| 240 | -307x | +|||
| 102 | +
- x_cols_aliased = x_cols_aliased,+ #' |
|||
| 241 | -307x | +|||
| 103 | +
- coordinates = coordinates_matrix,+ #' csh |
|||
| 242 | -307x | +|||
| 104 | +
- y_vector = y_vector,+ #' \tab Heterogeneous compound symmetry |
|||
| 243 | -307x | +|||
| 105 | +
- weights_vector = weights_vector,+ #' \tab \eqn{m+1}
|
|||
| 244 | -307x | +|||
| 106 | +
- n_visits = n_visits,+ #' \tab \eqn{\sigma_{i}\sigma_{j}\left[ \rho I(i \neq j)+I(i=j) \right]}
|
|||
| 245 | -307x | +|||
| 107 | +
- n_subjects = n_subjects,+ #' \cr |
|||
| 246 | -307x | +|||
| 108 | +
- subject_zero_inds = subject_zero_inds,+ #' |
|||
| 247 | -307x | +|||
| 109 | +
- subject_n_visits = subject_n_visits,+ #' toep |
|||
| 248 | -307x | +|||
| 110 | +
- cov_type = formula_parts$cov_type,+ #' \tab Toeplitz |
|||
| 249 | -307x | +|||
| 111 | +
- is_spatial_int = as.integer(formula_parts$is_spatial),+ #' \tab \eqn{m}
|
|||
| 250 | -307x | +|||
| 112 | +
- reml = as.integer(reml),+ #' \tab \eqn{\sigma_{\left \vert {i-j} \right \vert +1}}
|
|||
| 251 | -307x | +|||
| 113 | +
- subject_groups = subject_groups,+ #' \cr |
|||
| 252 | -307x | +|||
| 114 | +
- n_groups = n_groups+ #' |
|||
| 253 | +115 |
- ),+ #' toeph |
||
| 254 | -307x | +|||
| 116 | +
- class = "mmrm_tmb_data"+ #' \tab Heterogeneous Toeplitz+ |
+ |||
| 117 | ++ |
+ #' \tab \eqn{2m-1}
+ |
+ ||
| 118 | ++ |
+ #' \tab \eqn{\sigma_{i}\sigma_{j}\rho_{\left \vert {i-j} \right \vert}}
+ |
+ ||
| 119 | ++ |
+ #' \cr+ |
+ ||
| 120 | ++ |
+ #'+ |
+ ||
| 121 | ++ |
+ #' us+ |
+ ||
| 122 | ++ |
+ #' \tab Unstructured+ |
+ ||
| 123 | ++ |
+ #' \tab \eqn{m(m+1)/2}
+ |
+ ||
| 124 | ++ |
+ #' \tab \eqn{\sigma_{ij}}
+ |
+ ||
| 125 | ++ |
+ #'+ |
+ ||
| 126 | ++ |
+ #' }+ |
+ ||
| 127 | ++ |
+ #'+ |
+ ||
| 128 | ++ |
+ #' where \eqn{i} and \eqn{j} denote \eqn{i}-th and \eqn{j}-th time points,
+ |
+ ||
| 129 | ++ |
+ #' respectively, out of total \eqn{m} time points, \eqn{1 \leq i, j \leq m}.
+ |
+ ||
| 130 | ++ |
+ #'+ |
+ ||
| 131 | ++ |
+ #' @note The **ante-dependence** covariance structure in this package refers to+ |
+ ||
| 132 | ++ |
+ #' homogeneous ante-dependence, while the ante-dependence covariance structure+ |
+ ||
| 133 | ++ |
+ #' from SAS `PROC MIXED` refers to heterogeneous ante-dependence and the+ |
+ ||
| 134 | ++ |
+ #' homogeneous version is not available in SAS. |
||
| 255 | +135 |
- )+ #' |
||
| 256 | +136 |
- }+ #' @note For all non-spatial covariance structures, the time variable must |
||
| 257 | +137 |
-
+ #' be coded as a factor. |
||
| 258 | +138 |
- #' Start Parameters for `TMB` Fit+ #' |
||
| 259 | +139 |
- #'+ #' ## Spatial Covariance structures: |
||
| 260 | +140 |
- #' @param formula_parts (`mmrm_tmb_formula_parts`)\cr produced by+ #' |
||
| 261 | +141 |
- #' [h_mmrm_tmb_formula_parts()].+ #' \tabular{clll}{
|
||
| 262 | +142 |
- #' @param tmb_data (`mmrm_tmb_data`)\cr produced by [h_mmrm_tmb_data()].+ #' |
||
| 263 | +143 |
- #' @param start (`numeric` or `NULL`)\cr optional start values for variance+ #' \strong{Structure}
|
||
| 264 | +144 |
- #' parameters.+ #' \tab \strong{Description}
|
||
| 265 | +145 |
- #' @param n_groups (`int`)\cr number of groups.+ #' \tab \strong{Parameters}
|
||
| 266 | +146 |
- #' @return List with element `theta` containing the start values for the variance+ #' \tab \strong{\eqn{(i, j)} element}
|
||
| 267 | +147 |
- #' parameters.+ #' \cr |
||
| 268 | +148 |
#' |
||
| 269 | +149 |
- #' @keywords internal+ #' sp_exp |
||
| 270 | +150 |
- h_mmrm_tmb_parameters <- function(formula_parts,+ #' \tab spatial exponential |
||
| 271 | +151 |
- tmb_data,+ #' \tab \eqn{2}
|
||
| 272 | +152 |
- start,+ #' \tab \eqn{\sigma^{2}\rho^{-d_{ij}}}
|
||
| 273 | +153 |
- n_groups = 1L) {
+ #' |
||
| 274 | -264x | +|||
| 154 | +
- assert_class(formula_parts, "mmrm_tmb_formula_parts")+ #' } |
|||
| 275 | -264x | +|||
| 155 | +
- assert_class(tmb_data, "mmrm_tmb_data")+ #' |
|||
| 276 | +156 |
-
+ #' where \eqn{d_{ij}} denotes the Euclidean distance between time points
|
||
| 277 | -264x | +|||
| 157 | +
- m <- tmb_data$n_visits+ #' \eqn{i} and \eqn{j}.
|
|||
| 278 | -264x | +|||
| 158 | +
- start_value0 <- std_start(formula_parts$cov_type, m, n_groups)+ #' |
|||
| 279 | -264x | +|||
| 159 | +
- theta_dim <- length(start_value0)+ #' @family covariance types |
|||
| 280 | -264x | +|||
| 160 | +
- start_values <- if (is.null(start)) {
+ #' @name covariance_types |
|||
| 281 | -15x | +|||
| 161 | +
- start_value0+ #' @export |
|||
| 282 | -264x | +|||
| 162 | +
- } else if (test_function(start)) {
+ cov_types <- function( |
|||
| 283 | -232x | +|||
| 163 | +
- do.call(start, utils::modifyList(formula_parts, tmb_data))+ form = c("name", "abbr", "habbr"),
|
|||
| 284 | +164 |
- } else {
+ filter = c("heterogeneous", "spatial")) {
|
||
| 285 | -17x | +165 | +1660x |
- start+ form <- match.arg(form, several.ok = TRUE) |
| 286 | -+ | |||
| 166 | +1660x |
- }+ filter <- if (missing(filter)) c() else match.arg(filter, several.ok = TRUE) |
||
| 287 | -263x | +167 | +1660x |
- assert_numeric(start_values, len = theta_dim, any.missing = FALSE, finite = TRUE)+ df <- COV_TYPES[form][rowSums(!COV_TYPES[filter]) == 0, ] |
| 288 | -261x | +168 | +1660x |
- list(theta = start_values)+ Filter(Negate(is.na), unlist(t(df), use.names = FALSE)) |
| 289 | +169 |
} |
||
| 290 | +170 | |||
| 291 | +171 |
- #' Asserting Sane Start Values for `TMB` Fit+ #' Retrieve Associated Abbreviated Covariance Structure Type Name |
||
| 292 | +172 |
#' |
||
| 293 | +173 |
- #' @param tmb_object (`list`)\cr created with [TMB::MakeADFun()].+ #' @param type (`string`)\cr either a full name or abbreviate covariance |
||
| 294 | +174 |
- #'+ #' structure type name to collapse into an abbreviated type. |
||
| 295 | +175 |
- #' @return Nothing, only used for assertions.+ #' |
||
| 296 | +176 |
- #'+ #' @return The corresponding abbreviated covariance type name. |
||
| 297 | +177 |
- #' @keywords internal+ #' |
||
| 298 | +178 |
- h_mmrm_tmb_assert_start <- function(tmb_object) {
- |
- ||
| 299 | -248x | -
- assert_list(tmb_object)- |
- ||
| 300 | -248x | -
- assert_subset(c("fn", "gr", "par"), names(tmb_object))
+ #' @keywords internal |
||
| 301 | +179 |
-
+ cov_type_abbr <- function(type) {
|
||
| 302 | -248x | +180 | +298x |
- if (is.na(tmb_object$fn(tmb_object$par))) {
+ row <- which(COV_TYPES == type, arr.ind = TRUE)[, 1] |
| 303 | -1x | +181 | +298x |
- stop("negative log-likelihood is NaN at starting parameter values")
+ COV_TYPES$abbr[row] |
| 304 | +182 |
- }- |
- ||
| 305 | -247x | -
- if (any(is.na(tmb_object$gr(tmb_object$par)))) {
+ } |
||
| 306 | -1x | +|||
| 183 | +
- stop("some elements of gradient are NaN at starting parameter values")
+
|
|||
| 307 | +184 |
- }+ #' Retrieve Associated Full Covariance Structure Type Name |
||
| 308 | +185 |
- }+ #' |
||
| 309 | +186 |
-
+ #' @param type (`string`)\cr either a full name or abbreviate covariance |
||
| 310 | +187 |
- #' Checking the `TMB` Optimization Result+ #' structure type name to convert to a long-form type. |
||
| 311 | +188 |
#' |
||
| 312 | +189 |
- #' @param tmb_opt (`list`)\cr optimization result.+ #' @return The corresponding abbreviated covariance type name. |
||
| 313 | +190 |
- #' @param mmrm_tmb (`mmrm_tmb`)\cr result from [h_mmrm_tmb_fit()].+ #' |
||
| 314 | +191 |
- #'+ #' @keywords internal |
||
| 315 | +192 |
- #' @return Nothing, only used to generate warnings in case that the model+ cov_type_name <- function(type) {
|
||
| 316 | -+ | |||
| 193 | +6x |
- #' did not converge.+ row <- which(COV_TYPES == type, arr.ind = TRUE)[, 1] |
||
| 317 | -+ | |||
| 194 | +6x |
- #'+ COV_TYPES$name[row] |
||
| 318 | +195 |
- #' @keywords internal+ } |
||
| 319 | +196 |
- h_mmrm_tmb_check_conv <- function(tmb_opt, mmrm_tmb) {
+
|
||
| 320 | -244x | +|||
| 197 | +
- assert_list(tmb_opt)+ #' Produce A Covariance Identifier Passing to TMB |
|||
| 321 | -244x | +|||
| 198 | +
- assert_subset(c("par", "objective", "convergence", "message"), names(tmb_opt))
+ #' |
|||
| 322 | -244x | +|||
| 199 | +
- assert_class(mmrm_tmb, "mmrm_tmb")+ #' @param cov (`cov_struct`)\cr a covariance structure object. |
|||
| 323 | +200 |
-
+ #' |
||
| 324 | -244x | +|||
| 201 | +
- if (!is.null(tmb_opt$convergence) && tmb_opt$convergence != 0) {
+ #' @return A string used for method dispatch when passed to TMB. |
|||
| 325 | -3x | +|||
| 202 | +
- warning("Model convergence problem: ", tmb_opt$message, ".")
+ #' |
|||
| 326 | -3x | +|||
| 203 | +
- return()+ #' @keywords internal |
|||
| 327 | +204 |
- }+ tmb_cov_type <- function(cov) {
|
||
| 328 | -241x | +205 | +265x |
- theta_vcov <- mmrm_tmb$theta_vcov+ paste0(cov$type, if (cov$heterogeneous) "h") |
| 329 | -241x | +|||
| 206 | +
- if (is(theta_vcov, "try-error")) {
+ } |
|||
| 330 | -3x | +|||
| 207 | +
- warning("Model convergence problem: hessian is singular, theta_vcov not available.")
+
|
|||
| 331 | -3x | +|||
| 208 | +
- return()+ #' Define a Covariance Structure |
|||
| 332 | +209 |
- }+ #' |
||
| 333 | -238x | +|||
| 210 | +
- if (!all(is.finite(theta_vcov))) {
+ #' @description `r lifecycle::badge("stable")`
|
|||
| 334 | -3x | +|||
| 211 | +
- warning("Model convergence problem: theta_vcov contains non-finite values.")
+ #' |
|||
| 335 | -3x | +|||
| 212 | +
- return()+ #' @param type (`string`)\cr the name of the covariance structure type to use. |
|||
| 336 | +213 |
- }+ #' For available options, see `cov_types()`. If a type abbreviation is used |
||
| 337 | -235x | +|||
| 214 | +
- eigen_vals <- eigen(theta_vcov, only.values = TRUE)$values+ #' that implies heterogeneity (e.g. `cph`) and no value is provided to |
|||
| 338 | -235x | +|||
| 215 | +
- if (mode(eigen_vals) == "complex" || any(eigen_vals <= 0)) {
+ #' `heterogeneous`, then the heterogeneity is derived from the type name. |
|||
| 339 | +216 |
- # Note: complex eigen values signal that the matrix is not symmetric, therefore not positive definite.+ #' @param visits (`character`)\cr a vector of variable names to use for the |
||
| 340 | -3x | +|||
| 217 | +
- warning("Model convergence problem: theta_vcov is not positive definite.")
+ #' longitudinal terms of the covariance structure. Multiple terms are only |
|||
| 341 | -3x | +|||
| 218 | +
- return()+ #' permitted for the `"spatial"` covariance type. |
|||
| 342 | +219 |
- }+ #' @param subject (`string`)\cr the name of the variable that encodes a subject |
||
| 343 | -232x | +|||
| 220 | +
- qr_rank <- qr(theta_vcov)$rank+ #' identifier. |
|||
| 344 | -232x | +|||
| 221 | +
- if (qr_rank < ncol(theta_vcov)) {
+ #' @param group (`string`)\cr optionally, the name of the variable that encodes |
|||
| 345 | -1x | +|||
| 222 | +
- warning("Model convergence problem: theta_vcov is numerically singular.")
+ #' a grouping variable for subjects. |
|||
| 346 | +223 |
- }+ #' @param heterogeneous (`flag`)\cr |
||
| 347 | +224 |
- }+ #' |
||
| 348 | +225 |
-
+ #' @return A `cov_struct` object. |
||
| 349 | +226 |
- #' Extract covariance matrix from `TMB` report and input data+ #' |
||
| 350 | +227 |
- #'+ #' @examples |
||
| 351 | +228 |
- #' This helper does some simple post-processing to extract covariance matrix or named+ #' cov_struct("csh", "AVISITN", "USUBJID")
|
||
| 352 | +229 |
- #' list of covariance matrices if the fitting is using grouped covariance matrices.+ #' cov_struct("spatial", c("VISITA", "VISITB"), group = "GRP", subject = "SBJ")
|
||
| 353 | +230 |
#' |
||
| 354 | +231 |
- #' @param tmb_report (`list`)\cr report created with [TMB::MakeADFun()] report function.+ #' @family covariance types |
||
| 355 | +232 |
- #' @param tmb_data (`mmrm_tmb_data`)\cr produced by [h_mmrm_tmb_data()].+ #' @export |
||
| 356 | +233 |
- #' @param visit_var (`character`)\cr character vector of the visit variable+ cov_struct <- function( |
||
| 357 | +234 |
- #' @param is_spatial (`flag`)\cr indicator whether the covariance structure is spatial.+ type = cov_types(), visits, subject, group = character(), |
||
| 358 | +235 |
- #' @return Return a simple covariance matrix if there is no grouping, or a named+ heterogeneous = FALSE) {
|
||
| 359 | +236 |
- #' list of estimated grouped covariance matrices,+ # if heterogeneous isn't provided, derive from provided type |
||
| 360 | -+ | |||
| 237 | +295x |
- #' with its name equal to the group levels.+ if (missing(heterogeneous)) {
|
||
| 361 | -+ | |||
| 238 | +293x |
- #'+ heterogeneous <- switch(type, |
||
| 362 | -+ | |||
| 239 | +293x |
- #' @keywords internal+ toeph = , |
||
| 363 | -+ | |||
| 240 | +293x |
- h_mmrm_tmb_extract_cov <- function(tmb_report, tmb_data, visit_var, is_spatial) {
+ ar1h = , |
||
| 364 | -240x | +241 | +293x |
- d <- dim(tmb_report$covariance_lower_chol)+ adh = , |
| 365 | -240x | +242 | +293x |
- visit_names <- if (!is_spatial) {
+ csh = TRUE, |
| 366 | -227x | +243 | +293x |
- levels(tmb_data$full_frame[[visit_var]])+ heterogeneous |
| 367 | +244 |
- } else {
+ ) |
||
| 368 | -13x | +|||
| 245 | +
- c(0, 1)+ } |
|||
| 369 | +246 |
- }+ |
||
| 370 | -240x | +|||
| 247 | +
- cov <- lapply(+ # coerce all type options into abbreviated form |
|||
| 371 | -240x | +248 | +295x |
- seq_len(d[1] / d[2]),+ type <- match.arg(type) |
| 372 | -240x | +249 | +294x |
- function(i) {
+ type <- cov_type_abbr(type)+ |
+
| 250 | ++ | + | ||
| 373 | -277x | +251 | +294x |
- ret <- tcrossprod(tmb_report$covariance_lower_chol[seq(1 + (i - 1) * d[2], i * d[2]), ])+ x <- structure( |
| 374 | -277x | +252 | +294x |
- dimnames(ret) <- list(visit_names, visit_names)+ list( |
| 375 | -277x | +253 | +294x |
- return(ret)+ type = type, |
| 376 | -+ | |||
| 254 | +294x |
- }+ heterogeneous = heterogeneous, |
||
| 377 | -+ | |||
| 255 | +294x |
- )+ visits = visits, |
||
| 378 | -240x | +256 | +294x |
- if (identical(tmb_data$n_groups, 1L)) {
+ subject = subject, |
| 379 | -203x | +257 | +294x |
- cov <- cov[[1]]+ group = group |
| 380 | +258 |
- } else {
+ ), |
||
| 381 | -37x | +259 | +294x |
- names(cov) <- levels(tmb_data$subject_groups)+ class = c("cov_struct", "mmrm_cov_struct", "list")
|
| 382 | +260 |
- }+ )+ |
+ ||
| 261 | ++ | + | ||
| 383 | -240x | +262 | +294x |
- return(cov)+ validate_cov_struct(x) |
| 384 | +263 |
} |
||
| 385 | +264 | |||
| 386 | +265 |
- #' Build `TMB` Fit Result List+ #' Reconcile Possible Covariance Structure Inputs |
||
| 387 | +266 |
#' |
||
| 388 | +267 |
- #' This helper does some simple post-processing of the `TMB` object and+ #' @inheritParams mmrm |
||
| 389 | +268 |
- #' optimization results, including setting names, inverting matrices etc.+ #' |
||
| 390 | +269 |
- #'+ #' @return The value `covariance` if it's provided or a covariance structure |
||
| 391 | +270 |
- #' @param tmb_object (`list`)\cr created with [TMB::MakeADFun()].+ #' derived from the provided `formula` otherwise. An error is raised of both |
||
| 392 | +271 |
- #' @param tmb_opt (`list`)\cr optimization result.+ #' are provided. |
||
| 393 | +272 |
- #' @param formula_parts (`mmrm_tmb_formula_parts`)\cr produced by+ #' |
||
| 394 | +273 |
- #' [h_mmrm_tmb_formula_parts()].+ #' @keywords internal |
||
| 395 | +274 |
- #' @param tmb_data (`mmrm_tmb_data`)\cr produced by [h_mmrm_tmb_data()].+ h_reconcile_cov_struct <- function(formula = NULL, covariance = NULL) {
|
||
| 396 | -+ | |||
| 275 | +237x |
- #'+ assert_multi_class(covariance, c("formula", "cov_struct"), null.ok = TRUE)
|
||
| 397 | -+ | |||
| 276 | +237x |
- #' @return List of class `mmrm_tmb` with:+ assert_formula(formula, null.ok = FALSE) |
||
| 398 | -+ | |||
| 277 | +237x |
- #' - `cov`: estimated covariance matrix, or named list of estimated group specific covariance matrices.+ if (inherits(covariance, "formula")) {
|
||
| 399 | -+ | |||
| 278 | +4x |
- #' - `beta_est`: vector of coefficient estimates.+ covariance <- as.cov_struct(covariance) |
||
| 400 | +279 |
- #' - `beta_vcov`: Variance-covariance matrix for coefficient estimates.+ } |
||
| 401 | -+ | |||
| 280 | +237x |
- #' - `beta_vcov_inv_L`: Lower triangular matrix `L` of the inverse variance-covariance matrix decomposition.+ if (!is.null(covariance) && length(h_extract_covariance_terms(formula)) > 0) {
|
||
| 402 | -+ | |||
| 281 | +2x |
- #' - `beta_vcov_inv_D`: vector of diagonal matrix `D` of the inverse variance-covariance matrix decomposition.+ stop(paste0( |
||
| 403 | -+ | |||
| 282 | +2x |
- #' - `theta_est`: vector of variance parameter estimates.+ "Redundant covariance structure definition in `formula` and ", |
||
| 404 | -+ | |||
| 283 | +2x |
- #' - `theta_vcov`: variance-covariance matrix for variance parameter estimates.+ "`covariance` arguments" |
||
| 405 | +284 |
- #' - `neg_log_lik`: obtained negative log-likelihood.+ )) |
||
| 406 | +285 |
- #' - `formula_parts`: input.+ } |
||
| 407 | +286 |
- #' - `data`: input.+ |
||
| 408 | -+ | |||
| 287 | +235x |
- #' - `weights`: input.+ if (!is.null(covariance)) {
|
||
| 409 | -+ | |||
| 288 | +5x |
- #' - `reml`: input as a flag.+ return(covariance) |
||
| 410 | +289 |
- #' - `opt_details`: list with optimization details including convergence code.+ } |
||
| 411 | +290 |
- #' - `tmb_object`: original `TMB` object created with [TMB::MakeADFun()].+ + |
+ ||
| 291 | +230x | +
+ as.cov_struct(formula, warn_partial = FALSE) |
||
| 412 | +292 |
- #' - `tmb_data`: input.+ } |
||
| 413 | +293 |
- #'+ |
||
| 414 | +294 |
- #' @details Instead of inverting or decomposing `beta_vcov`, it can be more efficient to use its robust+ #' Validate Covariance Structure Data |
||
| 415 | +295 |
- #' Cholesky decomposition `LDL^T`, therefore we return the corresponding two components `L` and `D`+ #' |
||
| 416 | +296 |
- #' as well since they have been available on the `C++` side already.+ #' Run checks against relational integrity of covariance definition |
||
| 417 | +297 |
#' |
||
| 418 | +298 |
- #' @keywords internal+ #' @param x (`cov_struct`)\cr a covariance structure object. |
||
| 419 | +299 |
- h_mmrm_tmb_fit <- function(tmb_object,+ #' |
||
| 420 | +300 |
- tmb_opt,+ #' @return `x` if successful, or an error is thrown otherwise. |
||
| 421 | +301 |
- formula_parts,+ #' |
||
| 422 | +302 |
- tmb_data) {
+ #' @keywords internal |
||
| 423 | -238x | +|||
| 303 | +
- assert_list(tmb_object)+ validate_cov_struct <- function(x) {
|
|||
| 424 | -238x | +304 | +294x |
- assert_subset(c("fn", "gr", "par", "he"), names(tmb_object))
+ checks <- checkmate::makeAssertCollection() |
| 425 | -238x | +|||
| 305 | +
- assert_list(tmb_opt)+ |
|||
| 426 | -238x | +306 | +294x |
- assert_subset(c("par", "objective", "convergence", "message"), names(tmb_opt))
+ with(x, {
|
| 427 | -238x | +307 | +294x |
- assert_class(formula_parts, "mmrm_tmb_formula_parts")+ assert_character(subject, len = 1, add = checks) |
| 428 | -238x | +308 | +294x |
- assert_class(tmb_data, "mmrm_tmb_data")+ assert_logical(heterogeneous, len = 1, add = checks) |
| 429 | +309 | |||
| 430 | -238x | +310 | +294x |
- tmb_report <- tmb_object$report(par = tmb_opt$par)+ if (length(group) > 1 || length(visits) < 1) {
|
| 431 | -238x | +311 | +4x |
- x_matrix_cols <- colnames(tmb_data$x_matrix)+ checks$push( |
| 432 | -238x | +312 | +4x |
- cov <- h_mmrm_tmb_extract_cov(tmb_report, tmb_data, formula_parts$visit_var, formula_parts$is_spatial)+ "Covariance structure must be of the form `time | (group /) subject`" |
| 433 | -238x | +|||
| 313 | +
- beta_est <- tmb_report$beta+ ) |
|||
| 434 | -238x | +|||
| 314 | +
- names(beta_est) <- x_matrix_cols+ }+ |
+ |||
| 315 | ++ | + | ||
| 435 | -238x | +316 | +294x |
- beta_vcov <- tmb_report$beta_vcov+ if (!type %in% cov_types(filter = "spatial") && length(visits) > 1) {
|
| 436 | -238x | +317 | +2x |
- dimnames(beta_vcov) <- list(x_matrix_cols, x_matrix_cols)+ checks$push(paste( |
| 437 | -238x | +318 | +2x |
- beta_vcov_inv_L <- tmb_report$XtWX_L # nolint+ "Non-spatial covariance structures must have a single longitudinal", |
| 438 | -238x | +319 | +2x | +
+ "variable"+ |
+
| 320 | +
- beta_vcov_inv_D <- tmb_report$XtWX_D # nolint+ )) |
|||
| 439 | -238x | +|||
| 321 | +
- theta_est <- tmb_opt$par+ } |
|||
| 440 | -238x | +|||
| 322 | +
- names(theta_est) <- NULL+ }) |
|||
| 441 | -238x | +|||
| 323 | +
- theta_vcov <- try(solve(tmb_object$he(tmb_opt$par)), silent = TRUE)+ |
|||
| 442 | -238x | +324 | +294x |
- opt_details_names <- setdiff(+ reportAssertions(checks) |
| 443 | -238x | +325 | +288x |
- names(tmb_opt),+ x |
| 444 | -238x | +|||
| 326 | +
- c("par", "objective")
+ } |
|||
| 445 | +327 |
- )+ |
||
| 446 | -238x | +|||
| 328 | +
- structure(+ #' Format Covariance Structure Object |
|||
| 447 | -238x | +|||
| 329 | +
- list(+ #' |
|||
| 448 | -238x | +|||
| 330 | +
- cov = cov,+ #' @param x (`cov_struct`)\cr a covariance structure object. |
|||
| 449 | -238x | +|||
| 331 | +
- beta_est = beta_est,+ #' @param ... Additional arguments unused. |
|||
| 450 | -238x | +|||
| 332 | +
- beta_vcov = beta_vcov,+ #' |
|||
| 451 | -238x | +|||
| 333 | +
- beta_vcov_inv_L = beta_vcov_inv_L,+ #' @return A formatted string for `x`. |
|||
| 452 | -238x | +|||
| 334 | +
- beta_vcov_inv_D = beta_vcov_inv_D,+ #' |
|||
| 453 | -238x | +|||
| 335 | +
- theta_est = theta_est,+ #' @export |
|||
| 454 | -238x | +|||
| 336 | +
- theta_vcov = theta_vcov,+ format.cov_struct <- function(x, ...) {
|
|||
| 455 | -238x | +337 | +3x |
- neg_log_lik = tmb_opt$objective,+ sprintf( |
| 456 | -238x | +338 | +3x |
- formula_parts = formula_parts,+ "<covariance structure>\n%s%s:\n\n %s | %s%s\n", |
| 457 | -238x | +339 | +3x |
- data = tmb_data$data,+ if (x$heterogeneous) "heterogeneous " else "", |
| 458 | -238x | +340 | +3x |
- weights = tmb_data$weights_vector,+ cov_type_name(x$type), |
| 459 | -238x | +341 | +3x |
- reml = as.logical(tmb_data$reml),+ format_symbols(x$visits), |
| 460 | -238x | +342 | +3x |
- opt_details = tmb_opt[opt_details_names],+ if (length(x$group) > 0) paste0(format_symbols(x$group), " / ") else "", |
| 461 | -238x | +343 | +3x |
- tmb_object = tmb_object,+ format_symbols(x$subject) |
| 462 | -238x | +|||
| 344 | +
- tmb_data = tmb_data+ ) |
|||
| 463 | +345 |
- ),+ } |
||
| 464 | -238x | +|||
| 346 | +
- class = "mmrm_tmb"+ |
|||
| 465 | +347 |
- )+ #' Print a Covariance Structure Object |
||
| 466 | +348 |
- }+ #' |
||
| 467 | +349 |
-
+ #' @param x (`cov_struct`)\cr a covariance structure object. |
||
| 468 | +350 |
- #' Low-Level Fitting Function for MMRM+ #' @param ... Additional arguments unused. |
||
| 469 | +351 |
#' |
||
| 470 | +352 |
- #' @description `r lifecycle::badge("experimental")`
+ #' @return `x` invisibly. |
||
| 471 | +353 |
#' |
||
| 472 | +354 |
- #' This is the low-level function to fit an MMRM. Note that this does not+ #' @export |
||
| 473 | +355 |
- #' try different optimizers or adds Jacobian information etc. in contrast to+ print.cov_struct <- function(x, ...) {
|
||
| 474 | -+ | |||
| 356 | +3x |
- #' [mmrm()].+ cat(format(x, ...), "\n")+ |
+ ||
| 357 | +3x | +
+ invisible(x) |
||
| 475 | +358 |
- #'+ } |
||
| 476 | +359 |
- #' @param formula (`formula`)\cr model formula with exactly one special term+ |
||
| 477 | +360 |
- #' specifying the visits within subjects, see details.+ #' Coerce into a Covariance Structure Definition |
||
| 478 | +361 |
- #' @param data (`data.frame`)\cr input data containing the variables used in+ #' |
||
| 479 | +362 |
- #' `formula`.+ #' @description `r lifecycle::badge("stable")`
|
||
| 480 | +363 |
- #' @param weights (`vector`)\cr input vector containing the weights.+ #' |
||
| 481 | +364 |
- #' @inheritParams h_mmrm_tmb_data+ #' @details |
||
| 482 | +365 |
- #' @param covariance (`cov_struct`)\cr A covariance structure type definition,+ #' A covariance structure can be parsed from a model definition formula or call. |
||
| 483 | +366 |
- #' or value that can be coerced to a covariance structure using+ #' Generally, covariance structures defined using non-standard evaluation take |
||
| 484 | +367 |
- #' [as.cov_struct()]. If no value is provided, a structure is derived from+ #' the following form: |
||
| 485 | +368 |
- #' the provided formula.+ #' |
||
| 486 | +369 |
- #' @param control (`mmrm_control`)\cr list of control options produced by+ #' ``` |
||
| 487 | +370 |
- #' [mmrm_control()].+ #' type( (visit, )* visit | (group /)? subject ) |
||
| 488 | +371 |
- #' @inheritParams fit_single_optimizer+ #' ``` |
||
| 489 | +372 |
#' |
||
| 490 | +373 |
- #' @return List of class `mmrm_tmb`, see [h_mmrm_tmb_fit()] for details.+ #' For example, formulas may include terms such as |
||
| 491 | +374 |
- #' In addition, it contains elements `call` and `optimizer`.+ #' |
||
| 492 | +375 |
- #'+ #' ```r |
||
| 493 | +376 |
- #' @details+ #' us(time | subject) |
||
| 494 | +377 |
- #' The `formula` typically looks like:+ #' cp(time | group / subject) |
||
| 495 | +378 |
- #'+ #' sp_exp(coord1, coord2 | group / subject) |
||
| 496 | +379 |
- #' `FEV1 ~ RACE + SEX + ARMCD * AVISIT + us(AVISIT | USUBJID)`+ #' ``` |
||
| 497 | +380 |
#' |
||
| 498 | +381 |
- #' which specifies response and covariates as usual, and exactly one special term+ #' Note that only `sp_exp` (spatial) covariance structures may provide multiple |
||
| 499 | +382 |
- #' defines which covariance structure is used and what are the visit and+ #' coordinates, which identify the Euclidean distance between the time points. |
||
| 500 | +383 |
- #' subject variables.+ #' |
||
| 501 | +384 |
- #'+ #' @param x an object from which to derive a covariance structure. See object |
||
| 502 | +385 |
- #' Always use only the first optimizer if multiple optimizers are provided.+ #' specific sections for details. |
||
| 503 | +386 |
- #'+ #' @param warn_partial (`flag`)\cr whether to emit a warning when parts of the |
||
| 504 | +387 |
- #' @export+ #' formula are disregarded. |
||
| 505 | +388 |
- #'+ #' @param ... additional arguments unused. |
||
| 506 | +389 |
- #' @examples+ #' |
||
| 507 | +390 |
- #' formula <- FEV1 ~ RACE + SEX + ARMCD * AVISIT + us(AVISIT | USUBJID)+ #' @return A [cov_struct()] object. |
||
| 508 | +391 |
- #' data <- fev_data+ #' |
||
| 509 | +392 |
- #' system.time(result <- fit_mmrm(formula, data, rep(1, nrow(fev_data))))+ #' @examples |
||
| 510 | +393 |
- fit_mmrm <- function(formula,+ #' # provide a covariance structure as a right-sided formula |
||
| 511 | +394 |
- data,+ #' as.cov_struct(~ csh(visit | group / subject)) |
||
| 512 | +395 |
- weights,+ #' |
||
| 513 | +396 |
- reml = TRUE,+ #' # when part of a full formula, suppress warnings using `warn_partial = FALSE` |
||
| 514 | +397 |
- covariance = NULL,+ #' as.cov_struct(y ~ x + csh(visit | group / subject), warn_partial = FALSE) |
||
| 515 | +398 |
- tmb_data,+ #' |
||
| 516 | +399 |
- formula_parts,+ #' @family covariance types |
||
| 517 | +400 |
- control = mmrm_control()) {
+ #' @export |
||
| 518 | -251x | +|||
| 401 | +
- if (missing(formula_parts) || missing(tmb_data)) {
+ as.cov_struct <- function(x, ...) { # nolint
|
|||
| 519 | -67x | +402 | +277x |
- covariance <- h_reconcile_cov_struct(formula, covariance)+ UseMethod("as.cov_struct")
|
| 520 | -65x | +|||
| 403 | +
- formula_parts <- h_mmrm_tmb_formula_parts(formula, covariance)+ } |
|||
| 521 | +404 | |||
| 522 | -65x | +|||
| 405 | +
- if (!formula_parts$is_spatial && !is.factor(data[[formula_parts$visit_var]])) {
+ #' @export |
|||
| 523 | -1x | +|||
| 406 | +
- stop("Time variable must be a factor for non-spatial covariance structures")
+ as.cov_struct.cov_struct <- function(x, ...) {
|
|||
| 524 | -+ | |||
| 407 | +! |
- }+ x |
||
| 525 | +408 |
-
+ } |
||
| 526 | -64x | +|||
| 409 | +
- assert_class(control, "mmrm_control")+ |
|||
| 527 | -64x | +|||
| 410 | +
- assert_list(control$optimizers, min.len = 1)+ #' @describeIn as.cov_struct |
|||
| 528 | -64x | +|||
| 411 | +
- assert_numeric(weights, any.missing = FALSE)+ #' When provided a formula, any specialized functions are assumed to be |
|||
| 529 | -64x | +|||
| 412 | +
- assert_true(all(weights > 0))+ #' covariance structure definitions and must follow the form: |
|||
| 530 | -64x | +|||
| 413 | +
- tmb_data <- h_mmrm_tmb_data(+ #' |
|||
| 531 | -64x | +|||
| 414 | +
- formula_parts, data, weights, reml,+ #' ``` |
|||
| 532 | -64x | +|||
| 415 | +
- singular = if (control$accept_singular) "drop" else "error", drop_visit_levels = control$drop_visit_levels+ #' y ~ xs + type( (visit, )* visit | (group /)? subject ) |
|||
| 533 | +416 |
- )+ #' ``` |
||
| 534 | +417 |
- } else {
+ #' |
||
| 535 | -184x | +|||
| 418 | +
- assert_class(tmb_data, "mmrm_tmb_data")+ #' Any component on the right hand side of a formula is considered when |
|||
| 536 | -184x | +|||
| 419 | +
- assert_class(formula_parts, "mmrm_tmb_formula_parts")+ #' searching for a covariance definition. |
|||
| 537 | +420 |
- }+ #' |
||
| 538 | -248x | +|||
| 421 | +
- tmb_parameters <- h_mmrm_tmb_parameters(formula_parts, tmb_data, start = control$start, n_groups = tmb_data$n_groups)+ #' @export |
|||
| 539 | +422 |
-
+ as.cov_struct.formula <- function(x, warn_partial = TRUE, ...) {
|
||
| 540 | -245x | +423 | +277x |
- h_tmb_warn_optimization()+ x_calls <- h_extract_covariance_terms(x) |
| 541 | +424 | |||
| 542 | -245x | -
- tmb_object <- TMB::MakeADFun(- |
- ||
| 543 | -245x | +425 | +277x |
- data = tmb_data,+ if (length(x_calls) < 1) {
|
| 544 | -245x | +426 | +4x |
- parameters = tmb_parameters,+ stop( |
| 545 | -245x | +427 | +4x |
- hessian = TRUE,+ "Covariance structure must be specified in formula. ", |
| 546 | -245x | +428 | +4x |
- DLL = "mmrm",+ "Possible covariance structures include: ", |
| 547 | -245x | +429 | +4x |
- silent = TRUE+ paste0(cov_types(c("abbr", "habbr")), collapse = ", ")
|
| 548 | +430 |
- )+ ) |
||
| 549 | -245x | +|||
| 431 | +
- h_mmrm_tmb_assert_start(tmb_object)+ } |
|||
| 550 | -245x | +|||
| 432 | +
- used_optimizer <- control$optimizers[[1L]]+ |
|||
| 551 | -245x | +433 | +273x |
- used_optimizer_name <- names(control$optimizers)[1L]+ if (length(x_calls) > 1) {
|
| 552 | -245x | +434 | +1x |
- args <- with(+ cov_struct_types <- as.character(lapply(x_calls, `[[`, 1L)) |
| 553 | -245x | +435 | +1x |
- tmb_object,+ stop( |
| 554 | -245x | +436 | +1x |
- c(+ "Only one covariance structure can be specified. ", |
| 555 | -245x | +437 | +1x |
- list(par, fn, gr),+ "Currently specified covariance structures are: ", |
| 556 | -245x | +438 | +1x |
- attr(used_optimizer, "args")+ paste0(cov_struct_types, collapse = ", ") |
| 557 | +439 |
) |
||
| 558 | +440 |
- )- |
- ||
| 559 | -245x | -
- if (identical(attr(used_optimizer, "use_hessian"), TRUE)) {
+ } |
||
| 560 | -8x | +|||
| 441 | +
- args$hessian <- tmb_object$he+ |
|||
| 561 | +442 |
- }+ # flatten into list of infix operators, calls and names/atomics |
||
| 562 | -245x | +443 | +272x |
- tmb_opt <- do.call(+ x <- flatten_call(x_calls[[1]]) |
| 563 | -245x | +444 | +272x |
- what = used_optimizer,+ type <- as.character(x[[1]]) |
| 564 | -245x | +445 | +272x |
- args = args+ x <- drop_elements(x, 1) |
| 565 | +446 |
- )+ |
||
| 566 | +447 |
- # Ensure negative log likelihood is stored in `objective` element of list.+ # take visits until "|" |
||
| 567 | -236x | +448 | +272x |
- if ("value" %in% names(tmb_opt)) {
+ n <- position_symbol(x, "|", nomatch = 0) |
| 568 | -226x | +449 | +272x |
- tmb_opt$objective <- tmb_opt$value+ visits <- as.character(utils::head(x, max(n - 1, 0))) |
| 569 | -226x | +450 | +272x |
- tmb_opt$value <- NULL+ x <- drop_elements(x, n) |
| 570 | +451 |
- }+ |
||
| 571 | -236x | +|||
| 452 | +
- fit <- h_mmrm_tmb_fit(tmb_object, tmb_opt, formula_parts, tmb_data)+ # take group until "/" |
|||
| 572 | -236x | +453 | +272x |
- h_mmrm_tmb_check_conv(tmb_opt, fit)+ n <- position_symbol(x, "/", nomatch = 0) |
| 573 | -236x | +454 | +272x |
- fit$call <- match.call()+ group <- as.character(utils::head(x, max(n - 1, 0))) |
| 574 | -236x | +455 | +272x |
- fit$call$formula <- formula_parts$formula+ x <- drop_elements(x, n)+ |
+
| 456 | ++ | + + | +||
| 457 | ++ |
+ # remainder is subject |
||
| 575 | -236x | +458 | +272x |
- fit$optimizer <- used_optimizer_name+ subject <- as.character(x)+ |
+
| 459 | ++ | + | ||
| 576 | -236x | +460 | +272x |
- fit+ cov_struct(type = type, visits = visits, group = group, subject = subject) |
| 577 | +461 |
}@@ -23958,14 +23624,14 @@ mmrm coverage - 97.08% |
| 1 |
- #' Covariance Type Database+ #' Obtain Kenward-Roger Adjustment Components |
|||
| 3 |
- #' An internal constant for covariance type information.+ #' @description Obtains the components needed downstream for the computation of Kenward-Roger degrees of freedom. |
|||
| 4 |
- #'+ #' Used in [mmrm()] fitting if method is "Kenward-Roger". |
|||
| 5 |
- #' @format A data frame with 5 variables and one record per covariance type:+ #' |
|||
| 6 |
- #'+ #' @param tmb_data (`mmrm_tmb_data`)\cr produced by [h_mmrm_tmb_data()]. |
|||
| 7 |
- #' \describe{
+ #' @param theta (`numeric`)\cr theta estimate. |
|||
| 8 |
- #' \item{name}{
+ #' |
|||
| 9 |
- #' The long-form name of the covariance structure type+ #' @details the function returns a named list, \eqn{P}, \eqn{Q} and \eqn{R}, which corresponds to the
|
|||
| 10 |
- #' }+ #' paper in 1997. The matrices are stacked in columns so that \eqn{P}, \eqn{Q} and \eqn{R} has the same
|
|||
| 11 |
- #' \item{abbr}{
+ #' column number(number of beta parameters). The number of rows, is dependent on |
|||
| 12 |
- #' The abbreviated name of the covariance structure type+ #' the total number of theta and number of groups, if the fit is a grouped mmrm. |
|||
| 13 |
- #' }+ #' For \eqn{P} matrix, it is stacked sequentially. For \eqn{Q} and \eqn{R} matrix, it is stacked so
|
|||
| 14 |
- #' \item{habbr}{
+ #' that the \eqn{Q_{ij}} and \eqn{R_{ij}} is stacked from \eqn{j} then to \eqn{i}, i.e. \eqn{R_{i1}}, \eqn{R_{i2}}, etc.
|
|||
| 15 |
- #' The abbreviated name of the heterogeneous version of a covariance+ #' \eqn{Q} and \eqn{R} only contains intra-group results and inter-group results should be all zero matrices
|
|||
| 16 |
- #' structure type (The abbreviated name (`abbr`) with a trailing `"h"` if+ #' so they are not stacked in the result. |
|||
| 17 |
- #' the structure has a heterogeneous implementation or `NA` otherwise).+ #' |
|||
| 18 |
- #' }+ #' @return Named list with elements: |
|||
| 19 |
- #' \item{heterogeneous}{
+ #' - `P`: `matrix` of \eqn{P} component.
|
|||
| 20 |
- #' A logical value indicating whether the covariance structure has a+ #' - `Q`: `matrix` of \eqn{Q} component.
|
|||
| 21 |
- #' heterogeneous counterpart.+ #' - `R`: `matrix` of \eqn{R} component.
|
|||
| 22 |
- #' }+ #' |
|||
| 23 |
- #' \item{spatial}{
+ #' @keywords internal |
|||
| 24 |
- #' A logical value indicating whether the covariance structure is spatial.+ h_get_kr_comp <- function(tmb_data, theta) {
|
|||
| 25 | -+ | 47x |
- #' }+ assert_class(tmb_data, "mmrm_tmb_data") |
|
| 26 | -+ | 47x |
- #' }+ assert_class(theta, "numeric") |
|
| 27 | -+ | 47x |
- #'+ .Call(`_mmrm_get_pqr`, PACKAGE = "mmrm", tmb_data, theta) |
|
| 28 |
- #' @keywords internal+ } |
|||
| 29 |
- COV_TYPES <- local({ # nolint
+
|
|||
| 30 |
- type <- function(name, abbr, habbr, heterogeneous, spatial) {
+ #' Calculation of Kenward-Roger Degrees of Freedom for Multi-Dimensional Contrast |
|||
| 31 |
- args <- as.list(match.call()[-1])+ #' |
|||
| 32 |
- do.call(data.frame, args)+ #' @description Used in [df_md()] if method is "Kenward-Roger" or "Kenward-Roger-Linear". |
|||
| 33 |
- }+ #' |
|||
| 34 |
-
+ #' @inheritParams h_df_md_sat |
|||
| 35 |
- as.data.frame(+ #' @inherit h_df_md_sat return |
|||
| 36 |
- col.names = names(formals(type)),+ #' @keywords internal |
|||
| 37 |
- rbind(+ h_df_md_kr <- function(object, contrast) {
|
|||
| 38 | -+ | 6x |
- type("unstructured", "us", NA, FALSE, FALSE),
+ assert_class(object, "mmrm") |
|
| 39 | -+ | 6x |
- type("Toeplitz", "toep", "toeph", TRUE, FALSE),
+ assert_matrix(contrast, mode = "numeric", any.missing = FALSE, ncols = length(component(object, "beta_est"))) |
|
| 40 | -+ | 6x |
- type("auto-regressive order one", "ar1", "ar1h", TRUE, FALSE),
+ if (component(object, "reml") != 1) {
|
|
| 41 | -+ | ! |
- type("ante-dependence", "ad", "adh", TRUE, FALSE),
+ stop("Kenward-Roger is only for REML")
|
|
| 42 |
- type("compound symmetry", "cs", "csh", TRUE, FALSE),
+ } |
|||
| 43 | -+ | 6x |
- type("spatial exponential", "sp_exp", NA, FALSE, TRUE)
+ kr_comp <- object$kr_comp |
|
| 44 | -+ | 6x |
- )+ w <- component(object, "theta_vcov") |
|
| 45 | -+ | 6x |
- )+ v_adj <- object$beta_vcov_adj |
|
| 46 | -+ | 6x |
- })+ df <- h_kr_df(v0 = object$beta_vcov, l = contrast, w = w, p = kr_comp$P) |
|
| 48 | -+ | 6x |
- #' Covariance Types+ h_test_md(object, contrast, df = df$m, f_stat_factor = df$lambda) |
|
| 49 |
- #'+ } |
|||
| 50 |
- #' @description `r lifecycle::badge("maturing")`
+
|
|||
| 51 |
- #'+ #' Calculation of Kenward-Roger Degrees of Freedom for One-Dimensional Contrast |
|||
| 52 |
- #' @param form (`character`)\cr covariance structure type name form. One or+ #' |
|||
| 53 |
- #' more of `"name"`, `"abbr"` (abbreviation), or `"habbr"` (heterogeneous+ #' @description Used in [df_1d()] if method is |
|||
| 54 |
- #' abbreviation).+ #' "Kenward-Roger" or "Kenward-Roger-Linear". |
|||
| 55 |
- #' @param filter (`character`)\cr covariance structure type filter. One or+ #' |
|||
| 56 |
- #' more of `"heterogeneous"` or `"spatial"`.+ #' @inheritParams h_df_1d_sat |
|||
| 57 |
- #'+ #' @inherit h_df_1d_sat return |
|||
| 58 |
- #' @return A character vector of accepted covariance structure type names and+ #' @keywords internal |
|||
| 59 |
- #' abbreviations.+ h_df_1d_kr <- function(object, contrast) {
|
|||
| 60 | -+ | 21x |
- #'+ assert_class(object, "mmrm") |
|
| 61 | -+ | 21x |
- #' @section Abbreviations for Covariance Structures:+ assert_numeric(contrast, len = length(component(object, "beta_est"))) |
|
| 62 | -+ | 21x |
- #'+ if (component(object, "reml") != 1) {
|
|
| 63 | -+ | ! |
- #' ## Common Covariance Structures:+ stop("Kenward-Roger is only for REML!")
|
|
| 64 |
- #'+ } |
|||
| 65 |
- #' \tabular{clll}{
+
|
|||
| 66 | -+ | 21x |
- #'+ df <- h_kr_df( |
|
| 67 | -+ | 21x |
- #' \strong{Structure}
+ v0 = object$beta_vcov, |
|
| 68 | -+ | 21x |
- #' \tab \strong{Description}
+ l = matrix(contrast, nrow = 1), |
|
| 69 | -+ | 21x |
- #' \tab \strong{Parameters}
+ w = component(object, "theta_vcov"), |
|
| 70 | -+ | 21x |
- #' \tab \strong{\eqn{(i, j)} element}
+ p = object$kr_comp$P |
|
| 71 |
- #' \cr+ ) |
|||
| 72 |
- #'+ |
|||
| 73 | -+ | 21x |
- #' ad+ h_test_1d(object, contrast, df$m) |
|
| 74 |
- #' \tab Ante-dependence+ } |
|||
| 75 |
- #' \tab \eqn{m}
+
|
|||
| 76 |
- #' \tab \eqn{\sigma^{2}\prod_{k=i}^{j-1}\rho_{k}}
+ #' Obtain the Adjusted Kenward-Roger degrees of freedom |
|||
| 77 |
- #' \cr+ #' |
|||
| 78 |
- #'+ #' @description Obtains the adjusted Kenward-Roger degrees of freedom and F statistic scale parameter. |
|||
| 79 |
- #' adh+ #' Used in [h_df_md_kr()] or [h_df_1d_kr]. |
|||
| 80 |
- #' \tab Heterogeneous ante-dependence+ #' |
|||
| 81 |
- #' \tab \eqn{2m-1}
+ #' @param v0 (`matrix`)\cr unadjusted covariance matrix. |
|||
| 82 |
- #' \tab \eqn{\sigma_{i}\sigma_{j}\prod_{k=i}^{j-1}\rho_{k}}
+ #' @param l (`matrix`)\cr linear combination matrix. |
|||
| 83 |
- #' \cr+ #' @param w (`matrix`)\cr hessian matrix. |
|||
| 84 |
- #'+ #' @param p (`matrix`)\cr P matrix from [h_get_kr_comp()]. |
|||
| 85 |
- #' ar1+ #' |
|||
| 86 |
- #' \tab First-order auto-regressive+ #' @return Named list with elements: |
|||
| 87 |
- #' \tab \eqn{2}
+ #' - `m`: `numeric` degrees of freedom. |
|||
| 88 |
- #' \tab \eqn{\sigma^{2}\rho^{\left \vert {i-j} \right \vert}}
+ #' - `lambda`: `numeric` F statistic scale parameter. |
|||
| 89 |
- #' \cr+ #' |
|||
| 90 |
- #'+ #' @keywords internal |
|||
| 91 |
- #' ar1h+ h_kr_df <- function(v0, l, w, p) {
|
|||
| 92 | -+ | 28x |
- #' \tab Heterogeneous first-order auto-regressive+ n_beta <- ncol(v0) |
|
| 93 | -+ | 28x |
- #' \tab \eqn{m+1}
+ assert_matrix(v0, ncols = n_beta, nrows = n_beta) |
|
| 94 | -+ | 28x |
- #' \tab \eqn{\sigma_{i}\sigma_{j}\rho^{\left \vert {i-j} \right \vert}}
+ assert_matrix(l, ncols = n_beta) |
|
| 95 | -+ | 28x |
- #' \cr+ n_theta <- ncol(w) |
|
| 96 | -+ | 28x |
- #'+ assert_matrix(w, ncols = n_theta, nrows = n_theta) |
|
| 97 | -+ | 28x |
- #' cs+ n_visits <- ncol(p) |
|
| 98 | -+ | 28x |
- #' \tab Compound symmetry+ assert_matrix(p, nrows = n_visits * n_theta) |
|
| 99 |
- #' \tab \eqn{2}
+ # see vignettes/kenward.Rmd#279 |
|||
| 100 | -+ | 28x |
- #' \tab \eqn{\sigma^{2}\left[ \rho I(i \neq j)+I(i=j) \right]}
+ slvol <- solve(h_quad_form_mat(l, v0)) |
|
| 101 | -+ | 28x |
- #' \cr+ m <- h_quad_form_mat(t(l), slvol) |
|
| 102 | -+ | 28x |
- #'+ nl <- nrow(l) |
|
| 103 | -+ | 28x |
- #' csh+ mv0 <- m %*% v0 |
|
| 104 | -+ | 28x |
- #' \tab Heterogeneous compound symmetry+ pl <- lapply(seq_len(nrow(p) / ncol(p)), function(x) {
|
|
| 105 | -+ | 108x |
- #' \tab \eqn{m+1}
+ ii <- (x - 1) * ncol(p) + 1 |
|
| 106 | -+ | 108x |
- #' \tab \eqn{\sigma_{i}\sigma_{j}\left[ \rho I(i \neq j)+I(i=j) \right]}
+ jj <- x * ncol(p) |
|
| 107 | -+ | 108x |
- #' \cr+ p[ii:jj, ] |
|
| 108 |
- #'+ }) |
|||
| 109 | -+ | 28x |
- #' toep+ mv0pv0 <- lapply(pl, function(x) {
|
|
| 110 | -+ | 108x |
- #' \tab Toeplitz+ mv0 %*% x %*% v0 |
|
| 111 |
- #' \tab \eqn{m}
+ }) |
|||
| 112 | -+ | 28x |
- #' \tab \eqn{\sigma_{\left \vert {i-j} \right \vert +1}}
+ a1 <- 0 |
|
| 113 | -+ | 28x |
- #' \cr+ a2 <- 0 |
|
| 114 |
- #'+ # see vignettes/kenward.Rmd#283 |
|||
| 115 | -+ | 28x |
- #' toeph+ for (i in seq_len(length(pl))) {
|
|
| 116 | -+ | 108x |
- #' \tab Heterogeneous Toeplitz+ for (j in seq_len(length(pl))) {
|
|
| 117 | -+ | 592x |
- #' \tab \eqn{2m-1}
+ a1 <- a1 + w[i, j] * h_tr(mv0pv0[[i]]) * h_tr(mv0pv0[[j]]) |
|
| 118 | -+ | 592x |
- #' \tab \eqn{\sigma_{i}\sigma_{j}\rho_{\left \vert {i-j} \right \vert}}
+ a2 <- a2 + w[i, j] * h_tr(mv0pv0[[i]] %*% mv0pv0[[j]]) |
|
| 119 |
- #' \cr+ } |
|||
| 120 |
- #'+ } |
|||
| 121 | -+ | 28x |
- #' us+ b <- 1 / (2 * nl) * (a1 + 6 * a2) |
|
| 122 | -+ | 28x |
- #' \tab Unstructured+ e <- 1 + a2 / nl |
|
| 123 | -+ | 28x |
- #' \tab \eqn{m(m+1)/2}
+ e_star <- 1 / (1 - a2 / nl) |
|
| 124 | -+ | 28x |
- #' \tab \eqn{\sigma_{ij}}
+ g <- ((nl + 1) * a1 - (nl + 4) * a2) / ((nl + 2) * a2) |
|
| 125 | -+ | 28x |
- #'+ denom <- (3 * nl + 2 - 2 * g) |
|
| 126 | -+ | 28x |
- #' }+ c1 <- g / denom |
|
| 127 | -+ | 28x |
- #'+ c2 <- (nl - g) / denom |
|
| 128 | -+ | 28x |
- #' where \eqn{i} and \eqn{j} denote \eqn{i}-th and \eqn{j}-th time points,
+ c3 <- (nl + 2 - g) / denom |
|
| 129 | -+ | 28x |
- #' respectively, out of total \eqn{m} time points, \eqn{1 \leq i, j \leq m}.
+ v_star <- 2 / nl * (1 + c1 * b) / (1 - c2 * b)^2 / (1 - c3 * b) |
|
| 130 | -+ | 28x |
- #'+ rho <- v_star / (2 * e_star^2) |
|
| 131 | -+ | 28x |
- #' @note The **ante-dependence** covariance structure in this package refers to+ m <- 4 + (nl + 2) / (nl * rho - 1) |
|
| 132 | -+ | 28x |
- #' homogeneous ante-dependence, while the ante-dependence covariance structure+ lambda <- m / (e_star * (m - 2)) |
|
| 133 | -+ | 28x |
- #' from SAS `PROC MIXED` refers to heterogeneous ante-dependence and the+ list(m = m, lambda = lambda) |
|
| 134 |
- #' homogeneous version is not available in SAS.+ } |
|||
| 135 |
- #'+ |
|||
| 136 |
- #' @note For all non-spatial covariance structures, the time variable must+ #' Obtain the Adjusted Covariance Matrix |
|||
| 137 |
- #' be coded as a factor.+ #' |
|||
| 138 |
- #'+ #' @description Obtains the Kenward-Roger adjusted covariance matrix for the |
|||
| 139 |
- #' ## Spatial Covariance structures:+ #' coefficient estimates. |
|||
| 140 |
- #'+ #' Used in [mmrm()] fitting if method is "Kenward-Roger" or "Kenward-Roger-Linear". |
|||
| 141 |
- #' \tabular{clll}{
+ #' |
|||
| 142 |
- #'+ #' @param v (`matrix`)\cr unadjusted covariance matrix. |
|||
| 143 |
- #' \strong{Structure}
+ #' @param w (`matrix`)\cr hessian matrix. |
|||
| 144 |
- #' \tab \strong{Description}
+ #' @param p (`matrix`)\cr P matrix from [h_get_kr_comp()]. |
|||
| 145 |
- #' \tab \strong{Parameters}
+ #' @param q (`matrix`)\cr Q matrix from [h_get_kr_comp()]. |
|||
| 146 |
- #' \tab \strong{\eqn{(i, j)} element}
+ #' @param r (`matrix`)\cr R matrix from [h_get_kr_comp()]. |
|||
| 147 |
- #' \cr+ #' @param linear (`flag`)\cr whether to use linear Kenward-Roger approximation. |
|||
| 149 |
- #' sp_exp+ #' @return The matrix of adjusted covariance matrix. |
|||
| 150 |
- #' \tab spatial exponential+ #' |
|||
| 151 |
- #' \tab \eqn{2}
+ #' @keywords internal |
|||
| 152 |
- #' \tab \eqn{\sigma^{2}\rho^{-d_{ij}}}
+ h_var_adj <- function(v, w, p, q, r, linear = FALSE) {
|
|||
| 153 | -+ | 49x |
- #'+ assert_flag(linear) |
|
| 154 | -+ | 49x |
- #' }+ n_beta <- ncol(v) |
|
| 155 | -+ | 49x |
- #'+ assert_matrix(v, nrows = n_beta) |
|
| 156 | -+ | 49x |
- #' where \eqn{d_{ij}} denotes the Euclidean distance between time points
+ n_theta <- ncol(w) |
|
| 157 | -+ | 49x |
- #' \eqn{i} and \eqn{j}.
+ assert_matrix(w, nrows = n_theta) |
|
| 158 | -+ | 49x |
- #'+ n_visits <- ncol(p) |
|
| 159 | +49x | +
+ theta_per_group <- nrow(q) / nrow(p)+ |
+ ||
| 160 | +49x | +
+ n_groups <- n_theta / theta_per_group+ |
+ ||
| 161 | +49x | +
+ assert_matrix(p, nrows = n_theta * n_visits)+ |
+ ||
| 162 | +49x | +
+ assert_matrix(q, nrows = theta_per_group^2 * n_groups * n_visits, ncols = n_visits)+ |
+ ||
| 163 | +49x | +
+ assert_matrix(r, nrows = theta_per_group^2 * n_groups * n_visits, ncols = n_visits)+ |
+ ||
| 164 | +49x | +
+ if (linear) {
+ |
+ ||
| 165 | +13x | +
+ r <- matrix(0, nrow = nrow(r), ncol = ncol(r))+ |
+ ||
| 166 |
- #' @family covariance types+ } |
|||
| 160 | +167 |
- #' @name covariance_types+ |
||
| 161 | +168 |
- #' @export+ # see vignettes/kenward.Rmd#131+ |
+ ||
| 169 | +49x | +
+ ret <- v+ |
+ ||
| 170 | +49x | +
+ for (i in seq_len(n_theta)) {
+ |
+ ||
| 171 | +264x | +
+ for (j in seq_len(n_theta)) {
+ |
+ ||
| 172 | +2164x | +
+ gi <- ceiling(i / theta_per_group)+ |
+ ||
| 173 | +2164x | +
+ gj <- ceiling(j / theta_per_group)+ |
+ ||
| 174 | +2164x | +
+ iid <- (i - 1) * n_beta + 1+ |
+ ||
| 175 | +2164x | +
+ jid <- (j - 1) * n_beta + 1+ |
+ ||
| 176 | +2164x | +
+ ii <- i - (gi - 1) * theta_per_group+ |
+ ||
| 177 | +2164x | +
+ jj <- j - (gi - 1) * theta_per_group+ |
+ ||
| 178 | +2164x | +
+ ijid <- ((ii - 1) * theta_per_group + jj - 1) * n_beta + (gi - 1) * n_beta * theta_per_group^2 + 1+ |
+ ||
| 179 | +2164x | +
+ if (gi != gj) {
+ |
+ ||
| 180 | +592x | +
+ ret <- ret + 2 * w[i, j] * v %*% (-p[iid:(iid + n_beta - 1), ] %*% v %*% p[jid:(jid + n_beta - 1), ]) %*% v |
||
| 162 | +181 |
- cov_types <- function(+ } else {
+ |
+ ||
| 182 | +1572x | +
+ ret <- ret + 2 * w[i, j] * v %*% (+ |
+ ||
| 183 | +1572x | +
+ q[ijid:(ijid + n_beta - 1), ] -+ |
+ ||
| 184 | +1572x | +
+ p[iid:(iid + n_beta - 1), ] %*% v %*% p[jid:(jid + n_beta - 1), ] -+ |
+ ||
| 185 | +1572x | +
+ 1 / 4 * r[ijid:(ijid + n_beta - 1), ]+ |
+ ||
| 186 | +1572x | +
+ ) %*% v |
||
| 163 | +187 |
- form = c("name", "abbr", "habbr"),
+ } |
||
| 164 | +188 |
- filter = c("heterogeneous", "spatial")) {
- |
- ||
| 165 | -1660x | -
- form <- match.arg(form, several.ok = TRUE)- |
- ||
| 166 | -1660x | -
- filter <- if (missing(filter)) c() else match.arg(filter, several.ok = TRUE)+ } |
||
| 167 | -1660x | +|||
| 189 | +
- df <- COV_TYPES[form][rowSums(!COV_TYPES[filter]) == 0, ]+ } |
|||
| 168 | -1660x | +190 | +49x |
- Filter(Negate(is.na), unlist(t(df), use.names = FALSE))+ ret |
| 169 | +191 |
} |
| 170 | +1 |
-
+ #' Register `mmrm` For Use With `tidymodels` |
||
| 171 | +2 |
- #' Retrieve Associated Abbreviated Covariance Structure Type Name+ #' |
||
| 172 | +3 |
- #'+ #' @inheritParams base::requireNamespace |
||
| 173 | +4 |
- #' @param type (`string`)\cr either a full name or abbreviate covariance+ #' @return A logical value indicating whether registration was successful. |
||
| 174 | +5 |
- #' structure type name to collapse into an abbreviated type.+ #' |
||
| 175 | +6 |
- #'+ #' @details We can use `parsnip::show_model_info("linear_reg")` to check the
|
||
| 176 | +7 |
- #' @return The corresponding abbreviated covariance type name.+ #' registration with `parsnip` and thus the wider `tidymodels` ecosystem. |
||
| 177 | +8 |
#' |
||
| 178 | +9 |
#' @keywords internal |
||
| 179 | +10 |
- cov_type_abbr <- function(type) {
+ parsnip_add_mmrm <- function(quietly = FALSE) {
|
||
| 180 | -298x | +11 | +1x |
- row <- which(COV_TYPES == type, arr.ind = TRUE)[, 1]+ if (!requireNamespace("parsnip", quietly = quietly)) {
|
| 181 | -298x | +|||
| 12 | +! |
- COV_TYPES$abbr[row]+ return(FALSE) |
||
| 182 | +13 |
- }+ } |
||
| 183 | +14 | |||
| 184 | -+ | |||
| 15 | +1x |
- #' Retrieve Associated Full Covariance Structure Type Name+ parsnip::set_model_engine( |
||
| 185 | -+ | |||
| 16 | +1x |
- #'+ model = "linear_reg", |
||
| 186 | -+ | |||
| 17 | +1x |
- #' @param type (`string`)\cr either a full name or abbreviate covariance+ eng = "mmrm", |
||
| 187 | -+ | |||
| 18 | +1x |
- #' structure type name to convert to a long-form type.+ mode = "regression" |
||
| 188 | +19 |
- #'+ ) |
||
| 189 | +20 |
- #' @return The corresponding abbreviated covariance type name.+ |
||
| 190 | -+ | |||
| 21 | +1x |
- #'+ parsnip::set_dependency( |
||
| 191 | -+ | |||
| 22 | +1x |
- #' @keywords internal+ pkg = "mmrm", |
||
| 192 | -+ | |||
| 23 | +1x |
- cov_type_name <- function(type) {
+ model = "linear_reg", |
||
| 193 | -6x | +24 | +1x |
- row <- which(COV_TYPES == type, arr.ind = TRUE)[, 1]+ eng = "mmrm", |
| 194 | -6x | +25 | +1x |
- COV_TYPES$name[row]+ mode = "regression" |
| 195 | +26 |
- }+ ) |
||
| 196 | +27 | |||
| 197 | -+ | |||
| 28 | +1x |
- #' Produce A Covariance Identifier Passing to TMB+ parsnip::set_encoding( |
||
| 198 | -+ | |||
| 29 | +1x |
- #'+ model = "linear_reg", |
||
| 199 | -+ | |||
| 30 | +1x |
- #' @param cov (`cov_struct`)\cr a covariance structure object.+ eng = "mmrm", |
||
| 200 | -+ | |||
| 31 | +1x |
- #'+ mode = "regression", |
||
| 201 | -+ | |||
| 32 | +1x |
- #' @return A string used for method dispatch when passed to TMB.+ options = list( |
||
| 202 | -+ | |||
| 33 | +1x |
- #'+ predictor_indicators = "none", |
||
| 203 | -+ | |||
| 34 | +1x |
- #' @keywords internal+ compute_intercept = FALSE, |
||
| 204 | -+ | |||
| 35 | +1x |
- tmb_cov_type <- function(cov) {
+ remove_intercept = FALSE, |
||
| 205 | -265x | +36 | +1x |
- paste0(cov$type, if (cov$heterogeneous) "h")+ allow_sparse_x = TRUE |
| 206 | +37 |
- }+ ) |
||
| 207 | +38 |
-
+ ) |
||
| 208 | +39 |
- #' Define a Covariance Structure+ |
||
| 209 | -+ | |||
| 40 | +1x |
- #'+ parsnip::set_fit( |
||
| 210 | -+ | |||
| 41 | +1x |
- #' @description `r lifecycle::badge("maturing")`
+ model = "linear_reg", |
||
| 211 | -+ | |||
| 42 | +1x |
- #'+ eng = "mmrm", |
||
| 212 | -+ | |||
| 43 | +1x |
- #' @param type (`string`)\cr the name of the covariance structure type to use.+ mode = "regression", |
||
| 213 | -+ | |||
| 44 | +1x |
- #' For available options, see `cov_types()`. If a type abbreviation is used+ value = list( |
||
| 214 | -+ | |||
| 45 | +1x |
- #' that implies heterogeneity (e.g. `cph`) and no value is provided to+ interface = "formula", |
||
| 215 | -+ | |||
| 46 | +1x |
- #' `heterogeneous`, then the heterogeneity is derived from the type name.+ protect = c("formula", "data", "weights"),
|
||
| 216 | -+ | |||
| 47 | +1x |
- #' @param visits (`character`)\cr a vector of variable names to use for the+ data = c(formula = "formula", data = "data", weights = "weights"), |
||
| 217 | -+ | |||
| 48 | +1x |
- #' longitudinal terms of the covariance structure. Multiple terms are only+ func = c(pkg = "mmrm", fun = "mmrm"), |
||
| 218 | -+ | |||
| 49 | +1x |
- #' permitted for the `"spatial"` covariance type.+ defaults = list() |
||
| 219 | +50 |
- #' @param subject (`string`)\cr the name of the variable that encodes a subject+ ) |
||
| 220 | +51 |
- #' identifier.+ ) |
||
| 221 | +52 |
- #' @param group (`string`)\cr optionally, the name of the variable that encodes+ |
||
| 222 | -+ | |||
| 53 | +1x |
- #' a grouping variable for subjects.+ parsnip::set_pred( |
||
| 223 | -+ | |||
| 54 | +1x |
- #' @param heterogeneous (`flag`)\cr+ model = "linear_reg", |
||
| 224 | -+ | |||
| 55 | +1x |
- #'+ eng = "mmrm", |
||
| 225 | -+ | |||
| 56 | +1x |
- #' @return A `cov_struct` object.+ mode = "regression", |
||
| 226 | -+ | |||
| 57 | +1x |
- #'+ type = "numeric", |
||
| 227 | -+ | |||
| 58 | +1x |
- #' @examples+ value = parsnip::pred_value_template( |
||
| 228 | +59 |
- #' cov_struct("csh", "AVISITN", "USUBJID")
+ # This is boilerplate. |
||
| 229 | -+ | |||
| 60 | +1x |
- #' cov_struct("spatial", c("VISITA", "VISITB"), group = "GRP", subject = "SBJ")
+ func = c(fun = "predict"), |
||
| 230 | -+ | |||
| 61 | +1x |
- #'+ object = quote(object$fit), |
||
| 231 | -+ | |||
| 62 | +1x |
- #' @family covariance types+ newdata = quote(new_data) |
||
| 232 | +63 |
- #' @export+ ) |
||
| 233 | +64 |
- cov_struct <- function(+ ) |
||
| 234 | +65 |
- type = cov_types(), visits, subject, group = character(),+ |
||
| 235 | -+ | |||
| 66 | +1x |
- heterogeneous = FALSE) {
+ parsnip::set_pred( |
||
| 236 | -+ | |||
| 67 | +1x |
- # if heterogeneous isn't provided, derive from provided type+ model = "linear_reg", |
||
| 237 | -295x | +68 | +1x |
- if (missing(heterogeneous)) {
+ eng = "mmrm", |
| 238 | -293x | +69 | +1x |
- heterogeneous <- switch(type,+ mode = "regression",+ |
+
| 70 | ++ |
+ # This type allows to pass arguments via `opts` to `parsnip::predict.model_fit`. |
||
| 239 | -293x | +71 | +1x |
- toeph = ,+ type = "raw", |
| 240 | -293x | +72 | +1x |
- ar1h = ,+ value = parsnip::pred_value_template(+ |
+
| 73 | ++ |
+ # This is boilerplate. |
||
| 241 | -293x | +74 | +1x |
- adh = ,+ func = c(fun = "predict"), |
| 242 | -293x | +75 | +1x |
- csh = TRUE,+ object = quote(object$fit), |
| 243 | -293x | +76 | +1x |
- heterogeneous+ newdata = quote(new_data) |
| 244 | +77 |
- )+ # We don't specify additional argument defaults here since otherwise |
||
| 245 | +78 |
- }+ # the user is not able to change them (they will be fixed). |
||
| 246 | +79 |
-
+ ) |
||
| 247 | +80 |
- # coerce all type options into abbreviated form+ ) |
||
| 248 | -295x | +|||
| 81 | +
- type <- match.arg(type)+ |
|||
| 249 | -294x | +82 | +1x |
- type <- cov_type_abbr(type)+ TRUE |
| 250 | +83 |
-
+ } |
||
| 251 | -294x | +
| 1 | +
- x <- structure(+ #' Component Access for `mmrm_tmb` Objects |
|||
| 252 | -294x | +|||
| 2 | +
- list(+ #' |
|||
| 253 | -294x | +|||
| 3 | +
- type = type,+ #' @description `r lifecycle::badge("stable")`
|
|||
| 254 | -294x | +|||
| 4 | +
- heterogeneous = heterogeneous,+ #' |
|||
| 255 | -294x | +|||
| 5 | +
- visits = visits,+ #' @param object (`mmrm_tmb`)\cr the fitted MMRM. |
|||
| 256 | -294x | +|||
| 6 | +
- subject = subject,+ #' @param name (`character`)\cr the component(s) to be retrieved. |
|||
| 257 | -294x | +|||
| 7 | +
- group = group+ #' @return The corresponding component of the object, see details. |
|||
| 258 | +8 |
- ),+ #' |
||
| 259 | -294x | +|||
| 9 | +
- class = c("cov_struct", "mmrm_cov_struct", "list")
+ #' @details Available `component()` names are as follows: |
|||
| 260 | +10 |
- )+ #' - `call`: low-level function call which generated the model. |
||
| 261 | +11 |
-
+ #' - `formula`: model formula. |
||
| 262 | -294x | +|||
| 12 | +
- validate_cov_struct(x)+ #' - `dataset`: data set name. |
|||
| 263 | +13 |
- }+ #' - `cov_type`: covariance structure type. |
||
| 264 | +14 |
-
+ #' - `n_theta`: number of parameters. |
||
| 265 | +15 |
- #' Reconcile Possible Covariance Structure Inputs+ #' - `n_subjects`: number of subjects. |
||
| 266 | +16 |
- #'+ #' - `n_timepoints`: number of modeled time points. |
||
| 267 | +17 |
- #' @inheritParams mmrm+ #' - `n_obs`: total number of observations. |
||
| 268 | +18 |
- #'+ #' - `reml`: was REML used (ML was used if `FALSE`). |
||
| 269 | +19 |
- #' @return The value `covariance` if it's provided or a covariance structure+ #' - `neg_log_lik`: negative log likelihood. |
||
| 270 | +20 |
- #' derived from the provided `formula` otherwise. An error is raised of both+ #' - `convergence`: convergence code from optimizer. |
||
| 271 | +21 |
- #' are provided.+ #' - `conv_message`: message accompanying the convergence code. |
||
| 272 | +22 |
- #'+ #' - `evaluations`: number of function evaluations for optimization. |
||
| 273 | +23 |
- #' @keywords internal+ #' - `method`: Adjustment method which was used (for `mmrm` objects), |
||
| 274 | +24 |
- h_reconcile_cov_struct <- function(formula = NULL, covariance = NULL) {
+ #' otherwise `NULL` (for `mmrm_tmb` objects). |
||
| 275 | -237x | +|||
| 25 | +
- assert_multi_class(covariance, c("formula", "cov_struct"), null.ok = TRUE)
+ #' - `beta_vcov`: estimated variance-covariance matrix of coefficients |
|||
| 276 | -237x | +|||
| 26 | +
- assert_formula(formula, null.ok = FALSE)+ #' (excluding aliased coefficients). When Kenward-Roger/Empirical adjusted |
|||
| 277 | -237x | +|||
| 27 | +
- if (inherits(covariance, "formula")) {
+ #' coefficients covariance matrix is used, the adjusted covariance matrix is returned (to still obtain the |
|||
| 278 | -4x | +|||
| 28 | +
- covariance <- as.cov_struct(covariance)+ #' original asymptotic covariance matrix use `object$beta_vcov`). |
|||
| 279 | +29 |
- }+ #' - `beta_vcov_complete`: estimated variance-covariance matrix including |
||
| 280 | -237x | +|||
| 30 | +
- if (!is.null(covariance) && length(h_extract_covariance_terms(formula)) > 0) {
+ #' aliased coefficients with entries set to `NA`. |
|||
| 281 | -2x | +|||
| 31 | +
- stop(paste0(+ #' - `varcor`: estimated covariance matrix for residuals. If there are multiple |
|||
| 282 | -2x | +|||
| 32 | +
- "Redundant covariance structure definition in `formula` and ",+ #' groups, a named list of estimated covariance matrices for residuals will be |
|||
| 283 | -2x | +|||
| 33 | +
- "`covariance` arguments"+ #' returned. The names are the group levels. |
|||
| 284 | +34 |
- ))+ #' - `theta_est`: estimated variance parameters. |
||
| 285 | +35 |
- }+ #' - `beta_est`: estimated coefficients (excluding aliased coefficients). |
||
| 286 | +36 |
-
+ #' - `beta_est_complete`: estimated coefficients including aliased coefficients |
||
| 287 | -235x | +|||
| 37 | +
- if (!is.null(covariance)) {
+ #' set to `NA`. |
|||
| 288 | -5x | +|||
| 38 | +
- return(covariance)+ #' - `beta_aliased`: whether each coefficient was aliased (i.e. cannot be estimated) |
|||
| 289 | +39 |
- }+ #' or not. |
||
| 290 | +40 |
-
+ #' - `theta_vcov`: estimated variance-covariance matrix of variance parameters. |
||
| 291 | -230x | +|||
| 41 | +
- as.cov_struct(formula, warn_partial = FALSE)+ #' - `x_matrix`: design matrix used (excluding aliased columns). |
|||
| 292 | +42 |
- }+ #' - `xlev`: a named list of character vectors giving the full set of levels to be assumed for each factor. |
||
| 293 | +43 |
-
+ #' - `contrasts`: a list of contrasts used for each factor. |
||
| 294 | +44 |
- #' Validate Covariance Structure Data+ #' - `y_vector`: response vector used. |
||
| 295 | +45 |
- #'+ #' - `jac_list`: Jacobian, see [h_jac_list()] for details. |
||
| 296 | +46 |
- #' Run checks against relational integrity of covariance definition+ #' - `full_frame`: `data.frame` with `n` rows containing all variables needed in the model. |
||
| 297 | +47 |
#' |
||
| 298 | +48 |
- #' @param x (`cov_struct`)\cr a covariance structure object.+ #' @seealso In the `lme4` package there is a similar function `getME()`. |
||
| 299 | +49 |
#' |
||
| 300 | +50 |
- #' @return `x` if successful, or an error is thrown otherwise.+ #' @examples |
||
| 301 | +51 |
- #'+ #' fit <- mmrm( |
||
| 302 | +52 |
- #' @keywords internal+ #' formula = FEV1 ~ RACE + SEX + ARMCD * AVISIT + us(AVISIT | USUBJID), |
||
| 303 | +53 |
- validate_cov_struct <- function(x) {
+ #' data = fev_data |
||
| 304 | -294x | +|||
| 54 | +
- checks <- checkmate::makeAssertCollection()+ #' ) |
|||
| 305 | +55 |
-
+ #' # Get all available components. |
||
| 306 | -294x | +|||
| 56 | +
- with(x, {
+ #' component(fit) |
|||
| 307 | -294x | +|||
| 57 | +
- assert_character(subject, len = 1, add = checks)+ #' # Get convergence code and message. |
|||
| 308 | -294x | +|||
| 58 | +
- assert_logical(heterogeneous, len = 1, add = checks)+ #' component(fit, c("convergence", "conv_message"))
|
|||
| 309 | +59 |
-
+ #' # Get modeled formula as a string. |
||
| 310 | -294x | +|||
| 60 | +
- if (length(group) > 1 || length(visits) < 1) {
+ #' component(fit, c("formula"))
|
|||
| 311 | -4x | +|||
| 61 | +
- checks$push(+ #' |
|||
| 312 | -4x | +|||
| 62 | +
- "Covariance structure must be of the form `time | (group /) subject`"+ #' @export |
|||
| 313 | +63 |
- )+ component <- function(object, |
||
| 314 | +64 |
- }+ name = c( |
||
| 315 | +65 |
-
+ "cov_type", "subject_var", "n_theta", "n_subjects", "n_timepoints", |
||
| 316 | -294x | +|||
| 66 | +
- if (!type %in% cov_types(filter = "spatial") && length(visits) > 1) {
+ "n_obs", "beta_vcov", "beta_vcov_complete", |
|||
| 317 | -2x | +|||
| 67 | +
- checks$push(paste(+ "varcor", "formula", "dataset", "n_groups", |
|||
| 318 | -2x | +|||
| 68 | +
- "Non-spatial covariance structures must have a single longitudinal",+ "reml", "convergence", "evaluations", "method", "optimizer", |
|||
| 319 | -2x | +|||
| 69 | +
- "variable"+ "conv_message", "call", "theta_est", |
|||
| 320 | +70 |
- ))+ "beta_est", "beta_est_complete", "beta_aliased", |
||
| 321 | +71 |
- }+ "x_matrix", "y_vector", "neg_log_lik", "jac_list", "theta_vcov", |
||
| 322 | +72 |
- })+ "full_frame", "xlev", "contrasts" |
||
| 323 | +73 |
-
+ )) {
|
||
| 324 | -294x | +74 | +5115x |
- reportAssertions(checks)+ assert_class(object, "mmrm_tmb") |
| 325 | -288x | +75 | +5115x |
- x+ name <- match.arg(name, several.ok = TRUE) |
| 326 | +76 |
- }+ + |
+ ||
| 77 | +5115x | +
+ list_components <- sapply(+ |
+ ||
| 78 | +5115x | +
+ X = name,+ |
+ ||
| 79 | +5115x | +
+ FUN = switch,+ |
+ ||
| 80 | +5115x | +
+ "call" = object$call, |
||
| 327 | +81 |
-
+ # Strings.+ |
+ ||
| 82 | +5115x | +
+ "cov_type" = object$formula_parts$cov_type,+ |
+ ||
| 83 | +5115x | +
+ "subject_var" = object$formula_parts$subject_var, |
||
| 328 | -+ | |||
| 84 | +5115x |
- #' Format Covariance Structure Object+ "formula" = deparse(object$call$formula), |
||
| 329 | -+ | |||
| 85 | +5115x |
- #'+ "dataset" = object$call$data, |
||
| 330 | -+ | |||
| 86 | +5115x |
- #' @param x (`cov_struct`)\cr a covariance structure object.+ "reml" = object$reml, |
||
| 331 | -+ | |||
| 87 | +5115x |
- #' @param ... Additional arguments unused.+ "conv_message" = object$opt_details$message, |
||
| 332 | +88 |
- #'+ # Numeric of length 1. |
||
| 333 | -+ | |||
| 89 | +5115x |
- #' @return A formatted string for `x`.+ "convergence" = object$opt_details$convergence, |
||
| 334 | -+ | |||
| 90 | +5115x |
- #'+ "neg_log_lik" = object$neg_log_lik, |
||
| 335 | -+ | |||
| 91 | +5115x |
- #' @export+ "n_theta" = length(object$theta_est), |
||
| 336 | -+ | |||
| 92 | +5115x |
- format.cov_struct <- function(x, ...) {
+ "n_subjects" = object$tmb_data$n_subjects, |
||
| 337 | -3x | +93 | +5115x |
- sprintf(+ "n_timepoints" = object$tmb_data$n_visits, |
| 338 | -3x | +94 | +5115x |
- "<covariance structure>\n%s%s:\n\n %s | %s%s\n",+ "n_obs" = length(object$tmb_data$y_vector), |
| 339 | -3x | +95 | +5115x |
- if (x$heterogeneous) "heterogeneous " else "",+ "n_groups" = ifelse(is.list(object$cov), length(object$cov), 1L), |
| 340 | -3x | +|||
| 96 | +
- cov_type_name(x$type),+ # Numeric of length > 1. |
|||
| 341 | -3x | +97 | +5115x |
- format_symbols(x$visits),+ "evaluations" = unlist(ifelse(is.null(object$opt_details$evaluations), |
| 342 | -3x | +98 | +5115x |
- if (length(x$group) > 0) paste0(format_symbols(x$group), " / ") else "",+ list(object$opt_details$counts), |
| 343 | -3x | +99 | +5115x |
- format_symbols(x$subject)+ list(object$opt_details$evaluations) |
| 344 | +100 |
- )+ )), |
||
| 345 | -+ | |||
| 101 | +5115x |
- }+ "method" = object$method, |
||
| 346 | -+ | |||
| 102 | +5115x |
-
+ "optimizer" = object$optimizer, |
||
| 347 | -+ | |||
| 103 | +5115x |
- #' Print a Covariance Structure Object+ "beta_est" = object$beta_est, |
||
| 348 | -+ | |||
| 104 | +5115x |
- #'+ "beta_est_complete" = |
||
| 349 | -+ | |||
| 105 | +5115x |
- #' @param x (`cov_struct`)\cr a covariance structure object.+ if (any(object$tmb_data$x_cols_aliased)) {
|
||
| 350 | -+ | |||
| 106 | +8x |
- #' @param ... Additional arguments unused.+ stats::setNames( |
||
| 351 | -+ | |||
| 107 | +8x |
- #'+ object$beta_est[names(object$tmb_data$x_cols_aliased)], |
||
| 352 | -+ | |||
| 108 | +8x |
- #' @return `x` invisibly.+ names(object$tmb_data$x_cols_aliased) |
||
| 353 | +109 |
- #'+ ) |
||
| 354 | +110 |
- #' @export+ } else {
+ |
+ ||
| 111 | +54x | +
+ object$beta_est |
||
| 355 | +112 |
- print.cov_struct <- function(x, ...) {
+ }, |
||
| 356 | -3x | +113 | +5115x |
- cat(format(x, ...), "\n")+ "beta_aliased" = object$tmb_data$x_cols_aliased, |
| 357 | -3x | +114 | +5115x |
- invisible(x)+ "theta_est" = object$theta_est, |
| 358 | -+ | |||
| 115 | +5115x |
- }+ "y_vector" = object$tmb_data$y_vector, |
||
| 359 | -+ | |||
| 116 | +5115x |
-
+ "jac_list" = object$jac_list, |
||
| 360 | +117 |
- #' Coerce into a Covariance Structure Definition+ # Matrices. |
||
| 361 | -+ | |||
| 118 | +5115x |
- #'+ "beta_vcov" = |
||
| 362 | -+ | |||
| 119 | +5115x |
- #' @description `r lifecycle::badge("maturing")`
+ if (is.null(object$vcov) || identical(object$vcov, "Asymptotic")) {
|
||
| 363 | -+ | |||
| 120 | +985x |
- #'+ object$beta_vcov |
||
| 364 | +121 |
- #' @details+ } else {
|
||
| 365 | -+ | |||
| 122 | +66x |
- #' A covariance structure can be parsed from a model definition formula or call.+ object$beta_vcov_adj |
||
| 366 | +123 |
- #' Generally, covariance structures defined using non-standard evaluation take+ }, |
||
| 367 | -+ | |||
| 124 | +5115x |
- #' the following form:+ "beta_vcov_complete" = |
||
| 368 | -+ | |||
| 125 | +5115x |
- #'+ if (any(object$tmb_data$x_cols_aliased)) {
|
||
| 369 | -+ | |||
| 126 | +2x |
- #' ```+ stats::.vcov.aliased( |
||
| 370 | -+ | |||
| 127 | +2x |
- #' type( (visit, )* visit | (group /)? subject )+ aliased = object$tmb_data$x_cols_aliased, |
||
| 371 | -+ | |||
| 128 | +2x |
- #' ```+ vc = component(object, "beta_vcov"), |
||
| 372 | -+ | |||
| 129 | +2x |
- #'+ complete = TRUE |
||
| 373 | +130 |
- #' For example, formulas may include terms such as+ ) |
||
| 374 | +131 |
- #'+ } else {
|
||
| 375 | -+ | |||
| 132 | +4x |
- #' ```r+ object$beta_vcov |
||
| 376 | +133 |
- #' us(time | subject)+ }, |
||
| 377 | -+ | |||
| 134 | +5115x |
- #' cp(time | group / subject)+ "varcor" = object$cov, |
||
| 378 | -+ | |||
| 135 | +5115x |
- #' sp_exp(coord1, coord2 | group / subject)+ "x_matrix" = object$tmb_data$x_matrix, |
||
| 379 | -+ | |||
| 136 | +5115x |
- #' ```+ "xlev" = stats::.getXlevels(terms(object), object$tmb_data$full_frame), |
||
| 380 | -+ | |||
| 137 | +5115x |
- #'+ "contrasts" = attr(object$tmb_data$x_matrix, "contrasts"), |
||
| 381 | -+ | |||
| 138 | +5115x |
- #' Note that only `sp_exp` (spatial) covariance structures may provide multiple+ "theta_vcov" = object$theta_vcov, |
||
| 382 | -+ | |||
| 139 | +5115x |
- #' coordinates, which identify the Euclidean distance between the time points.+ "full_frame" = object$tmb_data$full_frame, |
||
| 383 | +140 |
- #'+ # If not found. |
||
| 384 | -+ | |||
| 141 | +5115x |
- #' @param x an object from which to derive a covariance structure. See object+ "..foo.." = |
||
| 385 | -+ | |||
| 142 | +5115x |
- #' specific sections for details.+ stop(sprintf( |
||
| 386 | -+ | |||
| 143 | +5115x |
- #' @param warn_partial (`flag`)\cr whether to emit a warning when parts of the+ "component '%s' is not available", |
||
| 387 | -+ | |||
| 144 | +5115x |
- #' formula are disregarded.+ name, paste0(class(object), collapse = ", ") |
||
| 388 | +145 |
- #' @param ... additional arguments unused.+ )), |
||
| 389 | -+ | |||
| 146 | +5115x |
- #'+ simplify = FALSE |
||
| 390 | +147 |
- #' @return A [cov_struct()] object.+ ) |
||
| 391 | +148 |
- #'+ |
||
| 392 | -+ | |||
| 149 | +23x |
- #' @examples+ if (length(name) == 1) list_components[[1]] else list_components |
||
| 393 | +150 |
- #' # provide a covariance structure as a right-sided formula+ } |
| 394 | +1 |
- #' as.cov_struct(~ csh(visit | group / subject))+ #' Methods for `mmrm` Objects |
||
| 395 | +2 |
#' |
||
| 396 | -- |
- #' # when part of a full formula, suppress warnings using `warn_partial = FALSE`- |
- ||
| 397 | +3 |
- #' as.cov_struct(y ~ x + csh(visit | group / subject), warn_partial = FALSE)+ #' @description `r lifecycle::badge("stable")`
|
||
| 398 | +4 |
#' |
||
| 399 | +5 |
- #' @family covariance types+ #' @param object (`mmrm`)\cr the fitted MMRM including Jacobian and call etc. |
||
| 400 | +6 |
- #' @export+ #' @param ... not used. |
||
| 401 | +7 |
- as.cov_struct <- function(x, ...) { # nolint
- |
- ||
| 402 | -277x | -
- UseMethod("as.cov_struct")
+ #' @return Depends on the method, see Details and Functions. |
||
| 403 | +8 |
- }+ #' |
||
| 404 | +9 |
-
+ #' @details |
||
| 405 | +10 |
- #' @export+ #' While printing the summary of (`mmrm`)\cr object, the following will be displayed: |
||
| 406 | +11 |
- as.cov_struct.cov_struct <- function(x, ...) {
+ #' 1. Formula. The formula used in the model. |
||
| 407 | -! | +|||
| 12 | +
- x+ #' 2. Data. The data used for analysis, including number of subjects, number of valid observations. |
|||
| 408 | +13 |
- }+ #' 3. Covariance. The covariance structure and number of variance parameters. |
||
| 409 | +14 |
-
+ #' 4. Method. Restricted maximum likelihood(REML) or maximum likelihood(ML). |
||
| 410 | +15 |
- #' @describeIn as.cov_struct+ #' 5. Model selection criteria. AIC, BIC, log likelihood and deviance. |
||
| 411 | +16 |
- #' When provided a formula, any specialized functions are assumed to be+ #' 6. Coefficients. Coefficients of the covariates. |
||
| 412 | +17 |
- #' covariance structure definitions and must follow the form:+ #' 7. Covariance estimate. The covariance estimate(for each group). |
||
| 413 | +18 |
- #'+ #' 1. If the covariance structure is non-spatial, the covariance matrix of all categorical time points available |
||
| 414 | +19 |
- #' ```+ #' in data will be displayed. |
||
| 415 | +20 |
- #' y ~ xs + type( (visit, )* visit | (group /)? subject )+ #' 2. If the covariance structure is spatial, the covariance matrix of two time points with unit distance |
||
| 416 | +21 |
- #' ```+ #' will be displayed. |
||
| 417 | +22 |
#' |
||
| 418 | +23 |
- #' Any component on the right hand side of a formula is considered when+ #' `confint` is used to obtain the confidence intervals for the coefficients. |
||
| 419 | +24 |
- #' searching for a covariance definition.+ #' Please note that this is different from the confidence interval of difference |
||
| 420 | +25 |
- #'+ #' of least square means from `emmeans`. |
||
| 421 | +26 |
- #' @export+ #' |
||
| 422 | +27 |
- as.cov_struct.formula <- function(x, warn_partial = TRUE, ...) {
- |
- ||
| 423 | -277x | -
- x_calls <- h_extract_covariance_terms(x)+ #' @name mmrm_methods |
||
| 424 | +28 |
-
+ #' |
||
| 425 | -277x | +|||
| 29 | +
- if (length(x_calls) < 1) {
+ #' @seealso [`mmrm_tmb_methods`], [`mmrm_tidiers`] for additional methods. |
|||
| 426 | -4x | +|||
| 30 | +
- stop(+ #' |
|||
| 427 | -4x | +|||
| 31 | +
- "Covariance structure must be specified in formula. ",+ #' @examples |
|||
| 428 | -4x | +|||
| 32 | +
- "Possible covariance structures include: ",+ #' formula <- FEV1 ~ RACE + SEX + ARMCD * AVISIT + us(AVISIT | USUBJID) |
|||
| 429 | -4x | +|||
| 33 | +
- paste0(cov_types(c("abbr", "habbr")), collapse = ", ")
+ #' object <- mmrm(formula, fev_data) |
|||
| 430 | +34 |
- )+ NULL |
||
| 431 | +35 |
- }+ |
||
| 432 | +36 |
-
+ #' Coefficients Table for MMRM Fit |
||
| 433 | -273x | +|||
| 37 | +
- if (length(x_calls) > 1) {
+ #' |
|||
| 434 | -1x | +|||
| 38 | +
- cov_struct_types <- as.character(lapply(x_calls, `[[`, 1L))+ #' This is used by [summary.mmrm()] to obtain the coefficients table. |
|||
| 435 | -1x | +|||
| 39 | +
- stop(+ #' |
|||
| 436 | -1x | +|||
| 40 | +
- "Only one covariance structure can be specified. ",+ #' @param object (`mmrm`)\cr model fit. |
|||
| 437 | -1x | +|||
| 41 | +
- "Currently specified covariance structures are: ",+ #' |
|||
| 438 | -1x | +|||
| 42 | +
- paste0(cov_struct_types, collapse = ", ")+ #' @return Matrix with one row per coefficient and columns |
|||
| 439 | +43 |
- )+ #' `Estimate`, `Std. Error`, `df`, `t value` and `Pr(>|t|)`. |
||
| 440 | +44 |
- }+ #' |
||
| 441 | +45 |
-
+ #' @keywords internal |
||
| 442 | +46 |
- # flatten into list of infix operators, calls and names/atomics+ h_coef_table <- function(object) {
|
||
| 443 | -272x | +47 | +40x |
- x <- flatten_call(x_calls[[1]])+ assert_class(object, "mmrm") |
| 444 | -272x | +|||
| 48 | +
- type <- as.character(x[[1]])+ |
|||
| 445 | -272x | +49 | +40x |
- x <- drop_elements(x, 1)+ coef_est <- component(object, "beta_est") |
| 446 | -+ | |||
| 50 | +40x |
-
+ coef_contrasts <- diag(x = rep(1, length(coef_est))) |
||
| 447 | -+ | |||
| 51 | +40x |
- # take visits until "|"+ rownames(coef_contrasts) <- names(coef_est) |
||
| 448 | -272x | +52 | +40x |
- n <- position_symbol(x, "|", nomatch = 0)+ coef_table <- t(apply( |
| 449 | -272x | +53 | +40x |
- visits <- as.character(utils::head(x, max(n - 1, 0)))+ coef_contrasts, |
| 450 | -272x | +54 | +40x |
- x <- drop_elements(x, n)+ MARGIN = 1L, |
| 451 | -+ | |||
| 55 | +40x |
-
+ FUN = function(contrast) unlist(df_1d(object, contrast)) |
||
| 452 | +56 |
- # take group until "/"+ )) |
||
| 453 | -272x | +57 | +40x |
- n <- position_symbol(x, "/", nomatch = 0)+ assert_names( |
| 454 | -272x | +58 | +40x |
- group <- as.character(utils::head(x, max(n - 1, 0)))+ colnames(coef_table), |
| 455 | -272x | -
- x <- drop_elements(x, n)- |
- ||
| 456 | -+ | 59 | +40x |
-
+ identical.to = c("est", "se", "df", "t_stat", "p_val")
|
| 457 | +60 |
- # remainder is subject+ ) |
||
| 458 | -272x | +61 | +40x |
- subject <- as.character(x)+ colnames(coef_table) <- c("Estimate", "Std. Error", "df", "t value", "Pr(>|t|)")
|
| 459 | +62 | |||
| 460 | -272x | +63 | +40x |
- cov_struct(type = type, visits = visits, group = group, subject = subject)+ coef_aliased <- component(object, "beta_aliased") |
| 461 | -+ | |||
| 64 | +40x |
- }+ if (any(coef_aliased)) {
|
| 1 | -+ | |||
| 65 | +2x |
- #' Obtain Kenward-Roger Adjustment Components+ names_coef_na <- names(which(coef_aliased)) |
||
| 2 | -+ | |||
| 66 | +2x |
- #'+ coef_na_table <- matrix( |
||
| 3 | -+ | |||
| 67 | +2x |
- #' @description Obtains the components needed downstream for the computation of Kenward-Roger degrees of freedom.+ data = NA, |
||
| 4 | -+ | |||
| 68 | +2x |
- #' Used in [mmrm()] fitting if method is "Kenward-Roger".+ nrow = length(names_coef_na), |
||
| 5 | -+ | |||
| 69 | +2x |
- #'+ ncol = ncol(coef_table), |
||
| 6 | -+ | |||
| 70 | +2x |
- #' @param tmb_data (`mmrm_tmb_data`)\cr produced by [h_mmrm_tmb_data()].+ dimnames = list(names_coef_na, colnames(coef_table)) |
||
| 7 | +71 |
- #' @param theta (`numeric`)\cr theta estimate.+ ) |
||
| 8 | -+ | |||
| 72 | +2x |
- #'+ coef_table <- rbind(coef_table, coef_na_table)[names(coef_aliased), ] |
||
| 9 | +73 |
- #' @details the function returns a named list, \eqn{P}, \eqn{Q} and \eqn{R}, which corresponds to the
+ } |
||
| 10 | +74 |
- #' paper in 1997. The matrices are stacked in columns so that \eqn{P}, \eqn{Q} and \eqn{R} has the same
+
|
||
| 11 | -+ | |||
| 75 | +40x |
- #' column number(number of beta parameters). The number of rows, is dependent on+ coef_table |
||
| 12 | +76 |
- #' the total number of theta and number of groups, if the fit is a grouped mmrm.+ } |
||
| 13 | +77 |
- #' For \eqn{P} matrix, it is stacked sequentially. For \eqn{Q} and \eqn{R} matrix, it is stacked so
+
|
||
| 14 | +78 |
- #' that the \eqn{Q_{ij}} and \eqn{R_{ij}} is stacked from \eqn{j} then to \eqn{i}, i.e. \eqn{R_{i1}}, \eqn{R_{i2}}, etc.
+ #' @describeIn mmrm_methods summarizes the MMRM fit results. |
||
| 15 | +79 |
- #' \eqn{Q} and \eqn{R} only contains intra-group results and inter-group results should be all zero matrices
+ #' @exportS3Method |
||
| 16 | +80 |
- #' so they are not stacked in the result.+ #' @examples |
||
| 17 | +81 |
- #'+ #' # Summary: |
||
| 18 | +82 |
- #' @return Named list with elements:+ #' summary(object) |
||
| 19 | +83 |
- #' - `P`: `matrix` of \eqn{P} component.
+ summary.mmrm <- function(object, ...) {
|
||
| 20 | -+ | |||
| 84 | +20x |
- #' - `Q`: `matrix` of \eqn{Q} component.
+ aic_list <- list( |
||
| 21 | -+ | |||
| 85 | +20x |
- #' - `R`: `matrix` of \eqn{R} component.
+ AIC = AIC(object), |
||
| 22 | -+ | |||
| 86 | +20x |
- #'+ BIC = BIC(object), |
||
| 23 | -+ | |||
| 87 | +20x |
- #' @keywords internal+ logLik = logLik(object),+ |
+ ||
| 88 | +20x | +
+ deviance = deviance(object) |
||
| 24 | +89 |
- h_get_kr_comp <- function(tmb_data, theta) {
+ ) |
||
| 25 | -47x | +90 | +20x |
- assert_class(tmb_data, "mmrm_tmb_data")+ coefficients <- h_coef_table(object) |
| 26 | -47x | +91 | +20x |
- assert_class(theta, "numeric")+ call <- stats::getCall(object) |
| 27 | -47x | +92 | +20x |
- .Call(`_mmrm_get_pqr`, PACKAGE = "mmrm", tmb_data, theta)+ components <- component(object, c( |
| 28 | -+ | |||
| 93 | +20x |
- }+ "cov_type", "reml", "n_groups", "n_theta", |
||
| 29 | -+ | |||
| 94 | +20x |
-
+ "n_subjects", "n_timepoints", "n_obs", |
||
| 30 | -+ | |||
| 95 | +20x |
- #' Calculation of Kenward-Roger Degrees of Freedom for Multi-Dimensional Contrast+ "beta_vcov", "varcor" |
||
| 31 | +96 |
- #'+ )) |
||
| 32 | -+ | |||
| 97 | +20x |
- #' @description Used in [df_md()] if method is "Kenward-Roger" or "Kenward-Roger-Linear".+ components$method <- object$method |
||
| 33 | -+ | |||
| 98 | +20x |
- #'+ components$vcov <- object$vcov |
||
| 34 | -+ | |||
| 99 | +20x |
- #' @inheritParams h_df_md_sat+ structure( |
||
| 35 | -+ | |||
| 100 | +20x |
- #' @inherit h_df_md_sat return+ c( |
||
| 36 | -+ | |||
| 101 | +20x |
- #' @keywords internal+ components, |
||
| 37 | -+ | |||
| 102 | +20x |
- h_df_md_kr <- function(object, contrast) {
+ list( |
||
| 38 | -6x | +103 | +20x |
- assert_class(object, "mmrm")+ coefficients = coefficients, |
| 39 | -6x | +104 | +20x |
- assert_matrix(contrast, mode = "numeric", any.missing = FALSE, ncols = length(component(object, "beta_est")))+ n_singular_coefs = sum(component(object, "beta_aliased")), |
| 40 | -6x | +105 | +20x |
- if (component(object, "reml") != 1) {
+ aic_list = aic_list, |
| 41 | -! | +|||
| 106 | +20x |
- stop("Kenward-Roger is only for REML")
+ call = call |
||
| 42 | +107 |
- }+ ) |
||
| 43 | -6x | +|||
| 108 | +
- kr_comp <- object$kr_comp+ ), |
|||
| 44 | -6x | +109 | +20x |
- w <- component(object, "theta_vcov")+ class = "summary.mmrm" |
| 45 | -6x | +|||
| 110 | +
- v_adj <- object$beta_vcov_adj+ ) |
|||
| 46 | -6x | +|||
| 111 | +
- df <- h_kr_df(v0 = object$beta_vcov, l = contrast, w = w, p = kr_comp$P)+ } |
|||
| 47 | +112 | |||
| 48 | -6x | -
- h_test_md(object, contrast, df = df$m, f_stat_factor = df$lambda)- |
- ||
| 49 | +113 |
- }+ #' Printing MMRM Function Call |
||
| 50 | +114 |
-
+ #' |
||
| 51 | +115 |
- #' Calculation of Kenward-Roger Degrees of Freedom for One-Dimensional Contrast+ #' This is used in [print.summary.mmrm()]. |
||
| 52 | +116 |
#' |
||
| 53 | +117 |
- #' @description Used in [df_1d()] if method is+ #' @param call (`call`)\cr original [mmrm()] function call. |
||
| 54 | +118 |
- #' "Kenward-Roger" or "Kenward-Roger-Linear".+ #' @param n_obs (`int`)\cr number of observations. |
||
| 55 | +119 |
- #'+ #' @param n_subjects (`int`)\cr number of subjects. |
||
| 56 | +120 |
- #' @inheritParams h_df_1d_sat+ #' @param n_timepoints (`int`)\cr number of timepoints. |
||
| 57 | +121 |
- #' @inherit h_df_1d_sat return+ #' |
||
| 58 | +122 |
#' @keywords internal |
||
| 59 | +123 |
- h_df_1d_kr <- function(object, contrast) {
+ h_print_call <- function(call, n_obs, n_subjects, n_timepoints) {
|
||
| 60 | -21x | +124 | +9x |
- assert_class(object, "mmrm")+ pass <- 0 |
| 61 | -21x | +125 | +9x |
- assert_numeric(contrast, len = length(component(object, "beta_est")))+ if (!is.null(tmp <- call$formula)) {
|
| 62 | -21x | +126 | +9x |
- if (component(object, "reml") != 1) {
+ cat("Formula: ", deparse(tmp), fill = TRUE)
|
| 63 | -! | +|||
| 127 | +9x |
- stop("Kenward-Roger is only for REML!")
+ rhs <- tmp[[2]] |
||
| 64 | -+ | |||
| 128 | +9x |
- }+ pass <- nchar(deparse(rhs)) |
||
| 65 | +129 |
-
+ } |
||
| 66 | -21x | +130 | +9x |
- df <- h_kr_df(+ if (!is.null(call$data)) {
|
| 67 | -21x | +131 | +9x |
- v0 = object$beta_vcov,+ cat( |
| 68 | -21x | +132 | +9x |
- l = matrix(contrast, nrow = 1),+ "Data: ", deparse(call$data), "(used", n_obs, "observations from", |
| 69 | -21x | +133 | +9x |
- w = component(object, "theta_vcov"),+ n_subjects, "subjects with maximum", n_timepoints, "timepoints)", |
| 70 | -21x | +134 | +9x |
- p = object$kr_comp$P+ fill = TRUE |
| 71 | +135 |
- )+ ) |
||
| 72 | +136 |
-
+ }+ |
+ ||
| 137 | ++ |
+ # Display the expression of weights |
||
| 73 | -21x | +138 | +9x |
- h_test_1d(object, contrast, df$m)+ if (!is.null(call$weights)) {
+ |
+
| 139 | +4x | +
+ cat("Weights: ", deparse(call$weights), fill = TRUE)
|
||
| 74 | +140 |
- }+ } |
||
| 75 | +141 |
-
+ } |
||
| 76 | +142 |
- #' Obtain the Adjusted Kenward-Roger degrees of freedom+ |
||
| 77 | +143 |
- #'+ #' Printing MMRM Covariance Type |
||
| 78 | +144 |
- #' @description Obtains the adjusted Kenward-Roger degrees of freedom and F statistic scale parameter.+ #' |
||
| 79 | +145 |
- #' Used in [h_df_md_kr()] or [h_df_1d_kr].+ #' This is used in [print.summary.mmrm()]. |
||
| 80 | +146 |
#' |
||
| 81 | +147 |
- #' @param v0 (`matrix`)\cr unadjusted covariance matrix.+ #' @param cov_type (`string`)\cr covariance structure abbreviation. |
||
| 82 | +148 |
- #' @param l (`matrix`)\cr linear combination matrix.+ #' @param n_theta (`count`)\cr number of variance parameters. |
||
| 83 | +149 |
- #' @param w (`matrix`)\cr hessian matrix.+ #' @param n_groups (`count`)\cr number of groups. |
||
| 84 | +150 |
- #' @param p (`matrix`)\cr P matrix from [h_get_kr_comp()].+ #' @keywords internal |
||
| 85 | +151 |
- #'+ h_print_cov <- function(cov_type, n_theta, n_groups) {
|
||
| 86 | -+ | |||
| 152 | +9x |
- #' @return Named list with elements:+ assert_string(cov_type) |
||
| 87 | -+ | |||
| 153 | +9x |
- #' - `m`: `numeric` degrees of freedom.+ assert_count(n_theta, positive = TRUE) |
||
| 88 | -+ | |||
| 154 | +9x |
- #' - `lambda`: `numeric` F statistic scale parameter.+ assert_count(n_groups, positive = TRUE) |
||
| 89 | -+ | |||
| 155 | +9x |
- #'+ cov_definition <- switch(cov_type, |
||
| 90 | -+ | |||
| 156 | +9x |
- #' @keywords internal+ us = "unstructured", |
||
| 91 | -+ | |||
| 157 | +9x |
- h_kr_df <- function(v0, l, w, p) {
+ toep = "Toeplitz", |
||
| 92 | -28x | +158 | +9x |
- n_beta <- ncol(v0)+ toeph = "heterogeneous Toeplitz", |
| 93 | -28x | +159 | +9x |
- assert_matrix(v0, ncols = n_beta, nrows = n_beta)+ ar1 = "auto-regressive order one", |
| 94 | -28x | +160 | +9x |
- assert_matrix(l, ncols = n_beta)+ ar1h = "heterogeneous auto-regressive order one", |
| 95 | -28x | +161 | +9x |
- n_theta <- ncol(w)+ ad = "ante-dependence", |
| 96 | -28x | +162 | +9x |
- assert_matrix(w, ncols = n_theta, nrows = n_theta)+ adh = "heterogeneous ante-dependence", |
| 97 | -28x | +163 | +9x |
- n_visits <- ncol(p)+ cs = "compound symmetry", |
| 98 | -28x | +164 | +9x |
- assert_matrix(p, nrows = n_visits * n_theta)+ csh = "heterogeneous compound symmetry",+ |
+
| 165 | +9x | +
+ sp_exp = "spatial exponential" |
||
| 99 | +166 |
- # see vignettes/kenward.Rmd#279+ ) |
||
| 100 | -28x | +|||
| 167 | +
- slvol <- solve(h_quad_form_mat(l, v0))+ |
|||
| 101 | -28x | +168 | +9x |
- m <- h_quad_form_mat(t(l), slvol)+ catstr <- sprintf( |
| 102 | -28x | +169 | +9x |
- nl <- nrow(l)+ "Covariance: %s (%d variance parameters%s)\n", |
| 103 | -28x | +170 | +9x |
- mv0 <- m %*% v0+ cov_definition, |
| 104 | -28x | +171 | +9x |
- pl <- lapply(seq_len(nrow(p) / ncol(p)), function(x) {
+ n_theta, |
| 105 | -108x | +172 | +9x |
- ii <- (x - 1) * ncol(p) + 1+ ifelse(n_groups == 1L, "", sprintf(" of %d groups", n_groups))
|
| 106 | -108x | +|||
| 173 | +
- jj <- x * ncol(p)+ ) |
|||
| 107 | -108x | +174 | +9x | +
+ cat(catstr)+ |
+
| 175 | ++ |
+ }+ |
+ ||
| 176 | ++ | + + | +||
| 177 | ++ |
+ #' Printing AIC and other Model Fit Criteria+ |
+ ||
| 178 | ++ |
+ #'+ |
+ ||
| 179 | ++ |
+ #' This is used in [print.summary.mmrm()].+ |
+ ||
| 180 | ++ |
+ #'+ |
+ ||
| 181 | ++ |
+ #' @param aic_list (`list`)\cr list as part of from [summary.mmrm()].+ |
+ ||
| 182 | +
- p[ii:jj, ]+ #' @param digits (`number`)\cr number of decimal places used with [round()]. |
|||
| 108 | +183 |
- })+ #' |
||
| 109 | -28x | +|||
| 184 | +
- mv0pv0 <- lapply(pl, function(x) {
+ #' @keywords internal |
|||
| 110 | -108x | +|||
| 185 | +
- mv0 %*% x %*% v0+ h_print_aic_list <- function(aic_list, |
|||
| 111 | +186 |
- })+ digits = 1) {
|
||
| 112 | -28x | +187 | +6x |
- a1 <- 0+ diag_vals <- round(unlist(aic_list), digits) |
| 113 | -28x | +188 | +6x |
- a2 <- 0+ diag_vals <- format(diag_vals)+ |
+
| 189 | +6x | +
+ print(diag_vals, quote = FALSE) |
||
| 114 | +190 |
- # see vignettes/kenward.Rmd#283+ } |
||
| 115 | -28x | +|||
| 191 | +
- for (i in seq_len(length(pl))) {
+
|
|||
| 116 | -108x | +|||
| 192 | +
- for (j in seq_len(length(pl))) {
+ #' @describeIn mmrm_methods prints the MMRM fit summary. |
|||
| 117 | -592x | +|||
| 193 | +
- a1 <- a1 + w[i, j] * h_tr(mv0pv0[[i]]) * h_tr(mv0pv0[[j]])+ #' @exportS3Method |
|||
| 118 | -592x | +|||
| 194 | +
- a2 <- a2 + w[i, j] * h_tr(mv0pv0[[i]] %*% mv0pv0[[j]])+ #' @keywords internal |
|||
| 119 | +195 |
- }+ print.summary.mmrm <- function(x, |
||
| 120 | +196 |
- }+ digits = max(3, getOption("digits") - 3),
|
||
| 121 | -28x | +|||
| 197 | +
- b <- 1 / (2 * nl) * (a1 + 6 * a2)+ signif.stars = getOption("show.signif.stars"), # nolint
|
|||
| 122 | -28x | +|||
| 198 | +
- e <- 1 + a2 / nl+ ...) {
|
|||
| 123 | -28x | +199 | +5x |
- e_star <- 1 / (1 - a2 / nl)+ cat("mmrm fit\n\n")
|
| 124 | -28x | +200 | +5x |
- g <- ((nl + 1) * a1 - (nl + 4) * a2) / ((nl + 2) * a2)+ h_print_call(x$call, x$n_obs, x$n_subjects, x$n_timepoints) |
| 125 | -28x | +201 | +5x |
- denom <- (3 * nl + 2 - 2 * g)+ h_print_cov(x$cov_type, x$n_theta, x$n_groups) |
| 126 | -28x | +202 | +5x |
- c1 <- g / denom+ cat("Method: ", x$method, "\n", sep = "")
|
| 127 | -28x | +203 | +5x |
- c2 <- (nl - g) / denom+ cat("Vcov Method: ", x$vcov, "\n", sep = "")
|
| 128 | -28x | +204 | +5x |
- c3 <- (nl + 2 - g) / denom+ cat("Inference: ")
|
| 129 | -28x | +205 | +5x |
- v_star <- 2 / nl * (1 + c1 * b) / (1 - c2 * b)^2 / (1 - c3 * b)+ cat(ifelse(x$reml, "REML", "ML")) |
| 130 | -28x | +206 | +5x |
- rho <- v_star / (2 * e_star^2)+ cat("\n\n")
|
| 131 | -28x | +207 | +5x |
- m <- 4 + (nl + 2) / (nl * rho - 1)+ cat("Model selection criteria:\n")
|
| 132 | -28x | +208 | +5x |
- lambda <- m / (e_star * (m - 2))+ h_print_aic_list(x$aic_list) |
| 133 | -28x | +209 | +5x |
- list(m = m, lambda = lambda)+ cat("\n")
|
| 134 | -+ | |||
| 210 | +5x |
- }+ cat("Coefficients: ")
|
||
| 135 | -+ | |||
| 211 | +5x |
-
+ if (x$n_singular_coefs > 0) {
|
||
| 136 | -+ | |||
| 212 | +1x |
- #' Obtain the Adjusted Covariance Matrix+ cat("(", x$n_singular_coefs, " not defined because of singularities)", sep = "")
|
||
| 137 | +213 |
- #'+ } |
||
| 138 | -+ | |||
| 214 | +5x |
- #' @description Obtains the Kenward-Roger adjusted covariance matrix for the+ cat("\n")
|
||
| 139 | -+ | |||
| 215 | +5x |
- #' coefficient estimates.+ stats::printCoefmat( |
||
| 140 | -+ | |||
| 216 | +5x |
- #' Used in [mmrm()] fitting if method is "Kenward-Roger" or "Kenward-Roger-Linear".+ x$coefficients, |
||
| 141 | -+ | |||
| 217 | +5x |
- #'+ zap.ind = 3, |
||
| 142 | -+ | |||
| 218 | +5x |
- #' @param v (`matrix`)\cr unadjusted covariance matrix.+ digits = digits, |
||
| 143 | -+ | |||
| 219 | +5x |
- #' @param w (`matrix`)\cr hessian matrix.+ signif.stars = signif.stars |
||
| 144 | +220 |
- #' @param p (`matrix`)\cr P matrix from [h_get_kr_comp()].+ ) |
||
| 145 | -+ | |||
| 221 | +5x |
- #' @param q (`matrix`)\cr Q matrix from [h_get_kr_comp()].+ cat("\n")
|
||
| 146 | -+ | |||
| 222 | +5x |
- #' @param r (`matrix`)\cr R matrix from [h_get_kr_comp()].+ cat("Covariance estimate:\n")
|
||
| 147 | -+ | |||
| 223 | +5x |
- #' @param linear (`flag`)\cr whether to use linear Kenward-Roger approximation.+ if (is.list(x$varcor)) {
|
||
| 148 | -+ | |||
| 224 | +1x |
- #'+ for (v in names(x$varcor)) {
|
||
| 149 | -+ | |||
| 225 | +2x |
- #' @return The matrix of adjusted covariance matrix.+ cat(sprintf("Group: %s\n", v))
|
||
| 150 | -+ | |||
| 226 | +2x |
- #'+ print(round(x$varcor[[v]], digits = digits)) |
||
| 151 | +227 |
- #' @keywords internal+ } |
||
| 152 | +228 |
- h_var_adj <- function(v, w, p, q, r, linear = FALSE) {
- |
- ||
| 153 | -49x | -
- assert_flag(linear)- |
- ||
| 154 | -49x | -
- n_beta <- ncol(v)- |
- ||
| 155 | -49x | -
- assert_matrix(v, nrows = n_beta)+ } else {
|
||
| 156 | -49x | +229 | +4x |
- n_theta <- ncol(w)+ print(round(x$varcor, digits = digits)) |
| 157 | -49x | +|||
| 230 | +
- assert_matrix(w, nrows = n_theta)+ } |
|||
| 158 | -49x | +231 | +5x |
- n_visits <- ncol(p)+ cat("\n")
|
| 159 | -49x | +232 | +5x |
- theta_per_group <- nrow(q) / nrow(p)+ invisible(x) |
| 160 | -49x | +|||
| 233 | +
- n_groups <- n_theta / theta_per_group+ } |
|||
| 161 | -49x | +|||
| 234 | +
- assert_matrix(p, nrows = n_theta * n_visits)+ |
|||
| 162 | -49x | +|||
| 235 | +
- assert_matrix(q, nrows = theta_per_group^2 * n_groups * n_visits, ncols = n_visits)+ |
|||
| 163 | -49x | +|||
| 236 | +
- assert_matrix(r, nrows = theta_per_group^2 * n_groups * n_visits, ncols = n_visits)+ #' @describeIn mmrm_methods obtain the confidence intervals for the coefficients. |
|||
| 164 | -49x | +|||
| 237 | +
- if (linear) {
+ #' @exportS3Method |
|||
| 165 | -13x | +|||
| 238 | +
- r <- matrix(0, nrow = nrow(r), ncol = ncol(r))+ #' @examples |
|||
| 166 | +239 |
- }+ #' # Confidence Interval: |
||
| 167 | +240 |
-
+ #' confint(object) |
||
| 168 | +241 |
- # see vignettes/kenward.Rmd#131+ confint.mmrm <- function(object, parm, level = 0.95, ...) {
|
||
| 169 | -49x | +242 | +20x |
- ret <- v+ cf <- coef(object) |
| 170 | -49x | +243 | +20x |
- for (i in seq_len(n_theta)) {
+ pnames <- names(cf) |
| 171 | -264x | +244 | +20x |
- for (j in seq_len(n_theta)) {
+ if (missing(parm)) {
|
| 172 | -2164x | +245 | +15x |
- gi <- ceiling(i / theta_per_group)+ parm <- pnames |
| 173 | -2164x | +|||
| 246 | +
- gj <- ceiling(j / theta_per_group)+ } |
|||
| 174 | -2164x | +247 | +20x |
- iid <- (i - 1) * n_beta + 1+ assert( |
| 175 | -2164x | +248 | +20x |
- jid <- (j - 1) * n_beta + 1+ check_subset(parm, pnames), |
| 176 | -2164x | +249 | +20x |
- ii <- i - (gi - 1) * theta_per_group+ check_integerish(parm, lower = 1L, upper = length(cf)) |
| 177 | -2164x | +|||
| 250 | +
- jj <- j - (gi - 1) * theta_per_group+ ) |
|||
| 178 | -2164x | +251 | +2x |
- ijid <- ((ii - 1) * theta_per_group + jj - 1) * n_beta + (gi - 1) * n_beta * theta_per_group^2 + 1+ if (is.numeric(parm)) parm <- pnames[parm] |
| 179 | -2164x | +252 | +18x |
- if (gi != gj) {
+ assert_number(level, lower = 0, upper = 1) |
| 180 | -592x | -
- ret <- ret + 2 * w[i, j] * v %*% (-p[iid:(iid + n_beta - 1), ] %*% v %*% p[jid:(jid + n_beta - 1), ]) %*% v- |
- ||
| 181 | -+ | 253 | +18x |
- } else {
+ a <- (1 - level) / 2 |
| 182 | -1572x | +254 | +18x |
- ret <- ret + 2 * w[i, j] * v %*% (+ pct <- paste(format(100 * c(a, 1 - a), trim = TRUE, scientific = FALSE, digits = 3), "%") |
| 183 | -1572x | +255 | +18x |
- q[ijid:(ijid + n_beta - 1), ] -+ coef_table <- h_coef_table(object) |
| 184 | -1572x | +256 | +18x |
- p[iid:(iid + n_beta - 1), ] %*% v %*% p[jid:(jid + n_beta - 1), ] -+ df <- coef_table[parm, "df"] |
| 185 | -1572x | +257 | +18x |
- 1 / 4 * r[ijid:(ijid + n_beta - 1), ]+ ses <- coef_table[parm, "Std. Error"] |
| 186 | -1572x | +258 | +18x |
- ) %*% v+ fac <- stats::qt(a, df = df) |
| 187 | -+ | |||
| 259 | +18x |
- }+ ci <- array(NA, dim = c(length(parm), 2L), dimnames = list(parm, pct)) |
||
| 188 | -+ | |||
| 260 | +18x |
- }+ sefac <- ses * fac |
||
| 189 | -+ | |||
| 261 | +18x |
- }+ ci[] <- cf[parm] + c(sefac, -sefac) |
||
| 190 | -49x | +262 | +18x |
- ret+ ci |
| 191 | +263 |
}@@ -28534,14 +28457,14 @@ mmrm coverage - 97.08% |
| 1 |
- #' Component Access for `mmrm_tmb` Objects+ #' Determine Within or Between for each Design Matrix Column |
|||
| 3 |
- #' @description `r lifecycle::badge("experimental")`
+ #' @description Used in [h_df_bw_calc()] to determine whether a variable |
|||
| 4 |
- #'+ #' differs only between subjects or also within subjects. |
|||
| 5 |
- #' @param object (`mmrm_tmb`)\cr the fitted MMRM.+ #' |
|||
| 6 |
- #' @param name (`character`)\cr the component(s) to be retrieved.+ #' @param x_matrix (`matrix`)\cr the design matrix with column names. |
|||
| 7 |
- #' @return The corresponding component of the object, see details.+ #' @param subject_ids (`factor`)\cr the subject IDs. |
|||
| 9 |
- #' @details Available `component()` names are as follows:+ #' @return Character vector with "intercept", "within" or "between" for each |
|||
| 10 |
- #' - `call`: low-level function call which generated the model.+ #' design matrix column identified via the names of the vector. |
|||
| 11 |
- #' - `formula`: model formula.+ #' |
|||
| 12 |
- #' - `dataset`: data set name.+ #' @keywords internal |
|||
| 13 |
- #' - `cov_type`: covariance structure type.+ h_within_or_between <- function(x_matrix, subject_ids) {
|
|||
| 14 | -+ | 19x |
- #' - `n_theta`: number of parameters.+ assert_matrix(x_matrix, col.names = "unique", min.cols = 1L) |
|
| 15 | -+ | 19x |
- #' - `n_subjects`: number of subjects.+ assert_factor(subject_ids, len = nrow(x_matrix)) |
|
| 16 |
- #' - `n_timepoints`: number of modeled time points.+ |
|||
| 17 | -+ | 19x |
- #' - `n_obs`: total number of observations.+ n_subjects <- length(unique(subject_ids)) |
|
| 18 | -+ | 19x |
- #' - `reml`: was REML used (ML was used if `FALSE`).+ vapply( |
|
| 19 | -+ | 19x |
- #' - `neg_log_lik`: negative log likelihood.+ colnames(x_matrix), |
|
| 20 | -+ | 19x |
- #' - `convergence`: convergence code from optimizer.+ function(x) {
|
|
| 21 | -+ | 112x |
- #' - `conv_message`: message accompanying the convergence code.+ if (x == "(Intercept)") {
|
|
| 22 | -+ | 19x |
- #' - `evaluations`: number of function evaluations for optimization.+ "intercept" |
|
| 23 |
- #' - `method`: Adjustment method which was used (for `mmrm` objects),+ } else {
|
|||
| 24 | -+ | 93x |
- #' otherwise `NULL` (for `mmrm_tmb` objects).+ n_unique <- nrow(unique(cbind(x_matrix[, x], subject_ids))) |
|
| 25 | -+ | 43x |
- #' - `beta_vcov`: estimated variance-covariance matrix of coefficients+ if (n_unique > n_subjects) "within" else "between" |
|
| 26 |
- #' (excluding aliased coefficients). When Kenward-Roger/Empirical adjusted+ } |
|||
| 27 |
- #' coefficients covariance matrix is used, the adjusted covariance matrix is returned (to still obtain the+ }, |
|||
| 28 | -+ | 19x |
- #' original asymptotic covariance matrix use `object$beta_vcov`).+ character(1L) |
|
| 29 |
- #' - `beta_vcov_complete`: estimated variance-covariance matrix including+ ) |
|||
| 30 |
- #' aliased coefficients with entries set to `NA`.+ } |
|||
| 31 |
- #' - `varcor`: estimated covariance matrix for residuals. If there are multiple+ |
|||
| 32 |
- #' groups, a named list of estimated covariance matrices for residuals will be+ #' Calculation of Between-Within Degrees of Freedom |
|||
| 33 |
- #' returned. The names are the group levels.+ #' |
|||
| 34 |
- #' - `theta_est`: estimated variance parameters.+ #' @description Used in [h_df_1d_bw()] and [h_df_md_bw()]. |
|||
| 35 |
- #' - `beta_est`: estimated coefficients (excluding aliased coefficients).+ #' |
|||
| 36 |
- #' - `beta_est_complete`: estimated coefficients including aliased coefficients+ #' @param object (`mmrm`)\cr the fitted MMRM. |
|||
| 37 |
- #' set to `NA`.+ #' |
|||
| 38 |
- #' - `beta_aliased`: whether each coefficient was aliased (i.e. cannot be estimated)+ #' @return List with: |
|||
| 39 |
- #' or not.+ #' - `coefs_between_within` calculated via [h_within_or_between()] |
|||
| 40 |
- #' - `theta_vcov`: estimated variance-covariance matrix of variance parameters.+ #' - `ddf_between` |
|||
| 41 |
- #' - `x_matrix`: design matrix used (excluding aliased columns).+ #' - `ddf_within` |
|||
| 42 |
- #' - `xlev`: a named list of character vectors giving the full set of levels to be assumed for each factor.+ #' |
|||
| 43 |
- #' - `contrasts`: a list of contrasts used for each factor.+ #' @keywords internal |
|||
| 44 |
- #' - `y_vector`: response vector used.+ h_df_bw_calc <- function(object) {
|
|||
| 45 | -+ | 18x |
- #' - `jac_list`: Jacobian, see [h_jac_list()] for details.+ assert_class(object, "mmrm") |
|
| 46 |
- #' - `full_frame`: `data.frame` with `n` rows containing all variables needed in the model.+ |
|||
| 47 | -+ | 18x |
- #'+ n_subjects <- component(object, "n_subjects") |
|
| 48 | -+ | 18x |
- #' @seealso In the `lme4` package there is a similar function `getME()`.+ n_obs <- component(object, "n_obs") |
|
| 49 | -+ | 18x |
- #'+ x_mat <- component(object, "x_matrix") |
|
| 50 |
- #' @examples+ |
|||
| 51 | -+ | 18x |
- #' fit <- mmrm(+ subject_var <- component(object, "subject_var") |
|
| 52 | -+ | 18x |
- #' formula = FEV1 ~ RACE + SEX + ARMCD * AVISIT + us(AVISIT | USUBJID),+ full_frame <- component(object, "full_frame") |
|
| 53 | -+ | 18x |
- #' data = fev_data+ subject_ids <- full_frame[[subject_var]] |
|
| 54 |
- #' )+ |
|||
| 55 | -+ | 18x |
- #' # Get all available components.+ coefs_between_within <- h_within_or_between(x_mat, subject_ids) |
|
| 56 | -+ | 18x |
- #' component(fit)+ n_coefs_between <- sum(coefs_between_within == "between") |
|
| 57 | -+ | 18x |
- #' # Get convergence code and message.+ n_intercept <- sum(coefs_between_within == "intercept") |
|
| 58 | -+ | 18x |
- #' component(fit, c("convergence", "conv_message"))
+ n_coefs_within <- sum(coefs_between_within == "within") |
|
| 59 | -+ | 18x |
- #' # Get modeled formula as a string.+ ddf_between <- n_subjects - n_coefs_between - n_intercept |
|
| 60 | -+ | 18x |
- #' component(fit, c("formula"))
+ ddf_within <- n_obs - n_subjects - n_coefs_within |
|
| 61 |
- #'+ |
|||
| 62 | -+ | 18x |
- #' @export+ list( |
|
| 63 | -+ | 18x |
- component <- function(object,+ coefs_between_within = coefs_between_within, |
|
| 64 | -+ | 18x |
- name = c(+ ddf_between = ddf_between, |
|
| 65 | -+ | 18x |
- "cov_type", "subject_var", "n_theta", "n_subjects", "n_timepoints",+ ddf_within = ddf_within |
|
| 66 |
- "n_obs", "beta_vcov", "beta_vcov_complete",+ ) |
|||
| 67 |
- "varcor", "formula", "dataset", "n_groups",+ } |
|||
| 68 |
- "reml", "convergence", "evaluations", "method", "optimizer",+ |
|||
| 69 |
- "conv_message", "call", "theta_est",+ #' Assign Minimum Degrees of Freedom Given Involved Coefficients |
|||
| 70 |
- "beta_est", "beta_est_complete", "beta_aliased",+ #' |
|||
| 71 |
- "x_matrix", "y_vector", "neg_log_lik", "jac_list", "theta_vcov",+ #' @description Used in [h_df_1d_bw()] and [h_df_md_bw()]. |
|||
| 72 |
- "full_frame", "xlev", "contrasts"+ #' |
|||
| 73 |
- )) {
+ #' @param bw_calc (`list`)\cr from [h_df_bw_calc()]. |
|||
| 74 | -5115x | +
- assert_class(object, "mmrm_tmb")+ #' @param is_coef_involved (`logical`)\cr whether each coefficient is involved |
||
| 75 | -5115x | +
- name <- match.arg(name, several.ok = TRUE)+ #' in the contrast. |
||
| 76 |
-
+ #' |
|||
| 77 | -5115x | +
- list_components <- sapply(+ #' @return The minimum of the degrees of freedom assigned to each involved |
||
| 78 | -5115x | +
- X = name,+ #' coefficient according to its between-within categorization. |
||
| 79 | -5115x | +
- FUN = switch,+ #' |
||
| 80 | -5115x | +
- "call" = object$call,+ #' @keywords internal |
||
| 81 |
- # Strings.+ h_df_min_bw <- function(bw_calc, is_coef_involved) {
|
|||
| 82 | -5115x | +17x |
- "cov_type" = object$formula_parts$cov_type,+ assert_list(bw_calc) |
|
| 83 | -5115x | +17x |
- "subject_var" = object$formula_parts$subject_var,+ assert_names(names(bw_calc), identical.to = c("coefs_between_within", "ddf_between", "ddf_within"))
|
|
| 84 | -5115x | +17x |
- "formula" = deparse(object$call$formula),+ assert_logical(is_coef_involved, len = length(bw_calc$coefs_between_within)) |
|
| 85 | -5115x | +17x |
- "dataset" = object$call$data,+ assert_true(sum(is_coef_involved) > 0) |
|
| 86 | -5115x | +
- "reml" = object$reml,+ |
||
| 87 | -5115x | +17x |
- "conv_message" = object$opt_details$message,+ coef_categories <- bw_calc$coefs_between_within[is_coef_involved] |
|
| 88 | -+ | 17x |
- # Numeric of length 1.+ coef_dfs <- vapply( |
|
| 89 | -5115x | +17x |
- "convergence" = object$opt_details$convergence,+ X = coef_categories, |
|
| 90 | -5115x | +17x |
- "neg_log_lik" = object$neg_log_lik,+ FUN = switch, |
|
| 91 | -5115x | +17x |
- "n_theta" = length(object$theta_est),+ intercept = bw_calc$ddf_within, |
|
| 92 | -5115x | +17x |
- "n_subjects" = object$tmb_data$n_subjects,+ between = bw_calc$ddf_between, |
|
| 93 | -5115x | -
- "n_timepoints" = object$tmb_data$n_visits,- |
- ||
| 94 | -5115x | -
- "n_obs" = length(object$tmb_data$y_vector),- |
- ||
| 95 | -5115x | -
- "n_groups" = ifelse(is.list(object$cov), length(object$cov), 1L),- |
- ||
| 96 | -- |
- # Numeric of length > 1.- |
- ||
| 97 | -5115x | -
- "evaluations" = unlist(ifelse(is.null(object$opt_details$evaluations),- |
- ||
| 98 | -5115x | -
- list(object$opt_details$counts),- |
- ||
| 99 | -5115x | -
- list(object$opt_details$evaluations)- |
- ||
| 100 | -- |
- )),- |
- ||
| 101 | -5115x | -
- "method" = object$method,- |
- ||
| 102 | -5115x | -
- "optimizer" = object$optimizer,- |
- ||
| 103 | -5115x | -
- "beta_est" = object$beta_est,- |
- ||
| 104 | -5115x | -
- "beta_est_complete" =- |
- ||
| 105 | -5115x | -
- if (any(object$tmb_data$x_cols_aliased)) {
- |
- ||
| 106 | -8x | -
- stats::setNames(- |
- ||
| 107 | -8x | -
- object$beta_est[names(object$tmb_data$x_cols_aliased)],- |
- ||
| 108 | -8x | -
- names(object$tmb_data$x_cols_aliased)- |
- ||
| 109 | -- |
- )- |
- ||
| 110 | -+ | 17x |
- } else {
+ within = bw_calc$ddf_within, |
|
| 111 | -54x | +94 | +17x |
- object$beta_est+ FUN.VALUE = integer(1) |
| 112 | +95 |
- },+ ) |
||
| 113 | -5115x | +96 | +17x |
- "beta_aliased" = object$tmb_data$x_cols_aliased,+ min(coef_dfs) |
| 114 | -5115x | +|||
| 97 | +
- "theta_est" = object$theta_est,+ } |
|||
| 115 | -5115x | +|||
| 98 | +
- "y_vector" = object$tmb_data$y_vector,+ |
|||
| 116 | -5115x | +|||
| 99 | +
- "jac_list" = object$jac_list,+ #' Calculation of Between-Within Degrees of Freedom for One-Dimensional Contrast |
|||
| 117 | +100 |
- # Matrices.+ #' |
||
| 118 | -5115x | +|||
| 101 | +
- "beta_vcov" =+ #' @description Used in [df_1d()] if method is "Between-Within". |
|||
| 119 | -5115x | +|||
| 102 | +
- if (is.null(object$vcov) || identical(object$vcov, "Asymptotic")) {
+ #' |
|||
| 120 | -985x | +|||
| 103 | +
- object$beta_vcov+ #' @inheritParams h_df_1d_sat |
|||
| 121 | +104 |
- } else {
+ #' @inherit h_df_1d_sat return |
||
| 122 | -66x | +|||
| 105 | +
- object$beta_vcov_adj+ #' @keywords internal |
|||
| 123 | +106 |
- },+ h_df_1d_bw <- function(object, contrast) {
|
||
| 124 | -5115x | +107 | +7x |
- "beta_vcov_complete" =+ assert_class(object, "mmrm") |
| 125 | -5115x | +108 | +7x |
- if (any(object$tmb_data$x_cols_aliased)) {
+ assert_numeric(contrast, len = length(component(object, "beta_est"))) |
| 126 | -2x | +|||
| 109 | +
- stats::.vcov.aliased(+ |
|||
| 127 | -2x | +110 | +7x |
- aliased = object$tmb_data$x_cols_aliased,+ bw_calc <- h_df_bw_calc(object) |
| 128 | -2x | +111 | +7x |
- vc = component(object, "beta_vcov"),+ is_coef_involved <- contrast != 0 |
| 129 | -2x | +112 | +7x |
- complete = TRUE+ df <- h_df_min_bw(bw_calc, is_coef_involved) |
| 130 | -+ | |||
| 113 | +7x |
- )+ h_test_1d(object, contrast, df) |
||
| 131 | +114 |
- } else {
- |
- ||
| 132 | -4x | -
- object$beta_vcov+ } |
||
| 133 | +115 |
- },- |
- ||
| 134 | -5115x | -
- "varcor" = object$cov,+ |
||
| 135 | -5115x | +|||
| 116 | +
- "x_matrix" = object$tmb_data$x_matrix,+ #' Calculation of Between-Within Degrees of Freedom for Multi-Dimensional Contrast |
|||
| 136 | -5115x | +|||
| 117 | +
- "xlev" = stats::.getXlevels(terms(object), object$tmb_data$full_frame),+ #' |
|||
| 137 | -5115x | +|||
| 118 | +
- "contrasts" = attr(object$tmb_data$x_matrix, "contrasts"),+ #' @description Used in [df_md()] if method is "Between-Within". |
|||
| 138 | -5115x | +|||
| 119 | +
- "theta_vcov" = object$theta_vcov,+ #' |
|||
| 139 | -5115x | +|||
| 120 | +
- "full_frame" = object$tmb_data$full_frame,+ #' @inheritParams h_df_md_sat |
|||
| 140 | +121 |
- # If not found.+ #' @inherit h_df_md_sat return |
||
| 141 | -5115x | +|||
| 122 | +
- "..foo.." =+ #' @keywords internal |
|||
| 142 | -5115x | +|||
| 123 | +
- stop(sprintf(+ h_df_md_bw <- function(object, contrast) {
|
|||
| 143 | -5115x | +124 | +7x |
- "component '%s' is not available",+ assert_class(object, "mmrm") |
| 144 | -5115x | +125 | +7x |
- name, paste0(class(object), collapse = ", ")+ assert_matrix(contrast, mode = "numeric", any.missing = FALSE, ncols = length(component(object, "beta_est"))) |
| 145 | +126 |
- )),+ |
||
| 146 | -5115x | +127 | +7x |
- simplify = FALSE+ bw_calc <- h_df_bw_calc(object) |
| 147 | -+ | |||
| 128 | +7x |
- )+ is_coef_involved <- apply(X = contrast != 0, MARGIN = 2L, FUN = any) |
||
| 148 | -+ | |||
| 129 | +7x |
-
+ df <- h_df_min_bw(bw_calc, is_coef_involved) |
||
| 149 | -23x | +130 | +7x |
- if (length(name) == 1) list_components[[1]] else list_components+ h_test_md(object, contrast, df) |
| 150 | +131 |
}@@ -29590,14 +29380,14 @@ mmrm coverage - 97.08% |
| 1 |
- #' Methods for `mmrm` Objects+ #' Obtain List of Jacobian Matrix Entries for Covariance Matrix |
||
| 3 |
- #' @description `r lifecycle::badge("experimental")`
+ #' @description Obtain the Jacobian matrices given the covariance function and variance parameters. |
||
| 5 |
- #' @param object (`mmrm`)\cr the fitted MMRM including Jacobian and call etc.+ #' @param tmb_data (`mmrm_tmb_data`)\cr produced by [h_mmrm_tmb_data()]. |
||
| 6 |
- #' @param ... not used.+ #' @param theta_est (`numeric`)\cr variance parameters point estimate. |
||
| 7 |
- #' @return Depends on the method, see Details and Functions.+ #' @param beta_vcov (`matrix`)\cr vairance covariance matrix of coefficients. |
||
| 9 |
- #' @details+ #' @return List with one element per variance parameter containing a matrix |
||
| 10 |
- #' While printing the summary of (`mmrm`)\cr object, the following will be displayed:+ #' of the same dimensions as the covariance matrix. The values are the derivatives |
||
| 11 |
- #' 1. Formula. The formula used in the model.+ #' with regards to this variance parameter. |
||
| 12 |
- #' 2. Data. The data used for analysis, including number of subjects, number of valid observations.+ #' |
||
| 13 |
- #' 3. Covariance. The covariance structure and number of variance parameters.+ #' @keywords internal |
||
| 14 |
- #' 4. Method. Restricted maximum likelihood(REML) or maximum likelihood(ML).+ h_jac_list <- function(tmb_data, |
||
| 15 |
- #' 5. Model selection criteria. AIC, BIC, log likelihood and deviance.+ theta_est, |
||
| 16 |
- #' 6. Coefficients. Coefficients of the covariates.+ beta_vcov) {
|
||
| 17 | -+ | 81x |
- #' 7. Covariance estimate. The covariance estimate(for each group).+ assert_class(tmb_data, "mmrm_tmb_data") |
| 18 | -+ | 81x |
- #' 1. If the covariance structure is non-spatial, the covariance matrix of all categorical time points available+ assert_numeric(theta_est) |
| 19 | -+ | 81x |
- #' in data will be displayed.+ assert_matrix(beta_vcov) |
| 20 | -+ | 81x |
- #' 2. If the covariance structure is spatial, the covariance matrix of two time points with unit distance+ .Call(`_mmrm_get_jacobian`, PACKAGE = "mmrm", tmb_data, theta_est, beta_vcov) |
| 21 |
- #' will be displayed.+ } |
||
| 22 |
- #'+ |
||
| 23 |
- #' `confint` is used to obtain the confidence intervals for the coefficients.+ #' Quadratic Form Calculations |
||
| 24 |
- #' Please note that this is different from the confidence interval of difference+ #' |
||
| 25 |
- #' of least square means from `emmeans`.+ #' @description These helpers are mainly for easier readability and slightly better efficiency |
||
| 26 |
- #'+ #' of the quadratic forms used in the Satterthwaite calculations. |
||
| 27 |
- #' @name mmrm_methods+ #' |
||
| 28 |
- #'+ #' @param center (`matrix`)\cr square numeric matrix with the same dimensions as |
||
| 29 |
- #' @seealso [`mmrm_tmb_methods`], [`mmrm_tidiers`] for additional methods.+ #' `x` as the center of the quadratic form. |
||
| 31 |
- #' @examples+ #' @name h_quad_form |
||
| 32 |
- #' formula <- FEV1 ~ RACE + SEX + ARMCD * AVISIT + us(AVISIT | USUBJID)+ NULL |
||
| 33 |
- #' object <- mmrm(formula, fev_data)+ |
||
| 34 |
- NULL+ #' @describeIn h_quad_form calculates the number `vec %*% center %*% t(vec)` |
||
| 35 |
-
+ #' as a numeric (not a matrix). |
||
| 36 |
- #' Coefficients Table for MMRM Fit+ #' |
||
| 37 |
- #'+ #' @param vec (`numeric`)\cr interpreted as a row vector. |
||
| 38 |
- #' This is used by [summary.mmrm()] to obtain the coefficients table.+ #' |
||
| 39 |
- #'+ #' @keywords internal |
||
| 40 |
- #' @param object (`mmrm`)\cr model fit.+ h_quad_form_vec <- function(vec, center) {
|
||
| 41 | -+ | 5607x |
- #'+ vec <- as.vector(vec) |
| 42 | -+ | 5607x |
- #' @return Matrix with one row per coefficient and columns+ assert_numeric(vec, any.missing = FALSE) |
| 43 | -+ | 5607x |
- #' `Estimate`, `Std. Error`, `df`, `t value` and `Pr(>|t|)`.+ assert_matrix( |
| 44 | -+ | 5607x |
- #'+ center, |
| 45 | -+ | 5607x |
- #' @keywords internal+ mode = "numeric", |
| 46 | -+ | 5607x |
- h_coef_table <- function(object) {
+ any.missing = FALSE, |
| 47 | -40x | +5607x |
- assert_class(object, "mmrm")+ nrows = length(vec), |
| 48 | -+ | 5607x |
-
+ ncols = length(vec) |
| 49 | -40x | +
- coef_est <- component(object, "beta_est")+ ) |
|
| 50 | -40x | +
- coef_contrasts <- diag(x = rep(1, length(coef_est)))+ |
|
| 51 | -40x | +5607x |
- rownames(coef_contrasts) <- names(coef_est)+ sum(vec * (center %*% vec)) |
| 52 | -40x | +
- coef_table <- t(apply(+ } |
|
| 53 | -40x | +
- coef_contrasts,+ |
|
| 54 | -40x | +
- MARGIN = 1L,+ #' @describeIn h_quad_form calculates the quadratic form `mat %*% center %*% t(mat)` |
|
| 55 | -40x | +
- FUN = function(contrast) unlist(df_1d(object, contrast))+ #' as a matrix, the result is square and has dimensions identical to the number |
|
| 56 |
- ))+ #' of rows in `mat`. |
||
| 57 | -40x | +
- assert_names(+ #' |
|
| 58 | -40x | +
- colnames(coef_table),+ #' @param mat (`matrix`)\cr numeric matrix to be multiplied left and right of |
|
| 59 | -40x | +
- identical.to = c("est", "se", "df", "t_stat", "p_val")
+ #' `center`, therefore needs to have as many columns as there are rows and columns |
|
| 60 |
- )+ #' in `center`. |
||
| 61 | -40x | +
- colnames(coef_table) <- c("Estimate", "Std. Error", "df", "t value", "Pr(>|t|)")
+ #' |
|
| 62 |
-
+ #' @keywords internal |
||
| 63 | -40x | +
- coef_aliased <- component(object, "beta_aliased")+ h_quad_form_mat <- function(mat, center) {
|
|
| 64 | -40x | +119x |
- if (any(coef_aliased)) {
+ assert_matrix(mat, mode = "numeric", any.missing = FALSE, min.cols = 1L) |
| 65 | -2x | +119x |
- names_coef_na <- names(which(coef_aliased))+ assert_matrix( |
| 66 | -2x | +119x |
- coef_na_table <- matrix(+ center, |
| 67 | -2x | +119x |
- data = NA,+ mode = "numeric", |
| 68 | -2x | +119x |
- nrow = length(names_coef_na),+ any.missing = FALSE, |
| 69 | -2x | +119x |
- ncol = ncol(coef_table),+ nrows = ncol(center), |
| 70 | -2x | +119x |
- dimnames = list(names_coef_na, colnames(coef_table))+ ncols = ncol(center) |
| 71 |
- )+ ) |
||
| 72 | -2x | +119x |
- coef_table <- rbind(coef_table, coef_na_table)[names(coef_aliased), ]+ mat %*% tcrossprod(center, mat) |
| 73 |
- }+ } |
||
| 75 | -40x | +
- coef_table+ #' Computation of a Gradient Given Jacobian and Contrast Vector |
|
| 76 |
- }+ #' |
||
| 77 |
-
+ #' @description Computes the gradient of a linear combination of `beta` given the Jacobian matrix and |
||
| 78 |
- #' @describeIn mmrm_methods summarizes the MMRM fit results.+ #' variance parameters. |
||
| 79 |
- #' @exportS3Method+ #' |
||
| 80 |
- #' @examples+ #' @param jac_list (`list`)\cr Jacobian list produced e.g. by [h_jac_list()]. |
||
| 81 |
- #' # Summary:+ #' @param contrast (`numeric`)\cr contrast vector, which needs to have the |
||
| 82 |
- #' summary(object)+ #' same number of elements as there are rows and columns in each element of |
||
| 83 |
- summary.mmrm <- function(object, ...) {
+ #' `jac_list`. |
||
| 84 | -20x | +
- aic_list <- list(+ #' |
|
| 85 | -20x | +
- AIC = AIC(object),+ #' @return Numeric vector which contains the quadratic forms of each element of |
|
| 86 | -20x | +
- BIC = BIC(object),+ #' `jac_list` with the `contrast` vector. |
|
| 87 | -20x | +
- logLik = logLik(object),+ #' |
|
| 88 | -20x | +
- deviance = deviance(object)+ #' @keywords internal |
|
| 89 |
- )+ h_gradient <- function(jac_list, contrast) {
|
||
| 90 | -20x | +491x |
- coefficients <- h_coef_table(object)+ assert_list(jac_list) |
| 91 | -20x | +491x |
- call <- stats::getCall(object)+ assert_numeric(contrast) |
| 92 | -20x | +
- components <- component(object, c(+ |
|
| 93 | -20x | +491x |
- "cov_type", "reml", "n_groups", "n_theta",+ vapply( |
| 94 | -20x | +491x |
- "n_subjects", "n_timepoints", "n_obs",+ jac_list, |
| 95 | -20x | +491x |
- "beta_vcov", "varcor"+ h_quad_form_vec, |
| 96 | -+ | 491x |
- ))+ vec = contrast, |
| 97 | -20x | +491x |
- components$method <- object$method+ numeric(1L) |
| 98 | -20x | +
- components$vcov <- object$vcov+ ) |
|
| 99 | -20x | +
- structure(+ } |
|
| 100 | -20x | +
- c(+ |
|
| 101 | -20x | +
- components,+ #' Calculation of Satterthwaite Degrees of Freedom for One-Dimensional Contrast |
|
| 102 | -20x | +
- list(+ #' |
|
| 103 | -20x | +
- coefficients = coefficients,+ #' @description Used in [df_1d()] if method is |
|
| 104 | -20x | +
- n_singular_coefs = sum(component(object, "beta_aliased")),+ #' "Satterthwaite". |
|
| 105 | -20x | +
- aic_list = aic_list,+ #' |
|
| 106 | -20x | +
- call = call+ #' @param object (`mmrm`)\cr the MMRM fit. |
|
| 107 |
- )+ #' @param contrast (`numeric`)\cr contrast vector. Note that this should not include |
||
| 108 |
- ),+ #' elements for singular coefficient estimates, i.e. only refer to the |
||
| 109 | -20x | +
- class = "summary.mmrm"+ #' actually estimated coefficients. |
|
| 110 |
- )+ #' |
||
| 111 |
- }+ #' @return List with `est`, `se`, `df`, `t_stat` and `p_val`. |
||
| 112 |
-
+ #' @keywords internal |
||
| 113 |
- #' Printing MMRM Function Call+ h_df_1d_sat <- function(object, contrast) {
|
||
| 114 | -+ | 456x |
- #'+ assert_class(object, "mmrm") |
| 115 | -+ | 456x |
- #' This is used in [print.summary.mmrm()].+ contrast <- as.numeric(contrast) |
| 116 | -+ | 456x |
- #'+ assert_numeric(contrast, len = length(component(object, "beta_est"))) |
| 117 |
- #' @param call (`call`)\cr original [mmrm()] function call.+ |
||
| 118 | -+ | 456x |
- #' @param n_obs (`int`)\cr number of observations.+ df <- if (identical(object$vcov, "Asymptotic")) {
|
| 119 | -+ | 444x |
- #' @param n_subjects (`int`)\cr number of subjects.+ grad <- h_gradient(component(object, "jac_list"), contrast) |
| 120 | -+ | 444x |
- #' @param n_timepoints (`int`)\cr number of timepoints.+ v_num <- 2 * h_quad_form_vec(contrast, component(object, "beta_vcov"))^2 |
| 121 | -+ | 444x |
- #'+ v_denom <- h_quad_form_vec(grad, component(object, "theta_vcov")) |
| 122 | -+ | 444x |
- #' @keywords internal+ v_num / v_denom |
| 123 | -+ | 456x |
- h_print_call <- function(call, n_obs, n_subjects, n_timepoints) {
+ } else if (object$vcov %in% c("Empirical", "Empirical-Jackknife", "Empirical-Bias-Reduced")) {
|
| 124 | -9x | +12x |
- pass <- 0+ contrast_matrix <- Matrix::.bdiag(rep(list(matrix(contrast, nrow = 1)), component(object, "n_subjects"))) |
| 125 | -9x | +12x |
- if (!is.null(tmp <- call$formula)) {
+ contrast_matrix <- as.matrix(contrast_matrix) |
| 126 | -9x | +12x |
- cat("Formula: ", deparse(tmp), fill = TRUE)
+ g_matrix <- h_quad_form_mat(contrast_matrix, object$empirical_df_mat) |
| 127 | -9x | +12x |
- rhs <- tmp[[2]]+ h_tr(g_matrix)^2 / sum(g_matrix^2) |
| 128 | -9x | +
- pass <- nchar(deparse(rhs))+ } |
|
| 129 |
- }+ |
||
| 130 | -9x | +456x |
- if (!is.null(call$data)) {
+ h_test_1d(object, contrast, df) |
| 131 | -9x | +
- cat(+ } |
|
| 132 | -9x | +
- "Data: ", deparse(call$data), "(used", n_obs, "observations from",+ |
|
| 133 | -9x | +
- n_subjects, "subjects with maximum", n_timepoints, "timepoints)",+ #' Calculating Denominator Degrees of Freedom for the Multi-Dimensional Case |
|
| 134 | -9x | +
- fill = TRUE+ #' |
|
| 135 |
- )+ #' @description Calculates the degrees of freedom for multi-dimensional contrast. |
||
| 136 |
- }+ #' |
||
| 137 |
- # Display the expression of weights+ #' @param t_stat_df (`numeric`)\cr `n` t-statistic derived degrees of freedom. |
||
| 138 | -9x | +
- if (!is.null(call$weights)) {
+ #' |
|
| 139 | -4x | +
- cat("Weights: ", deparse(call$weights), fill = TRUE)
+ #' @return Usually the calculation is returning `2 * E / (E - n)` where |
|
| 140 |
- }+ #' `E` is the sum of `t / (t - 2)` over all `t_stat_df` values `t`. |
||
| 141 |
- }+ #' |
||
| 142 |
-
+ #' @note If the input values are two similar to each other then just the average |
||
| 143 |
- #' Printing MMRM Covariance Type+ #' of them is returned. If any of the inputs is not larger than 2 then 2 is |
||
| 144 |
- #'+ #' returned. |
||
| 145 |
- #' This is used in [print.summary.mmrm()].+ #' |
||
| 146 |
- #'+ #' @keywords internal |
||
| 147 |
- #' @param cov_type (`string`)\cr covariance structure abbreviation.+ h_md_denom_df <- function(t_stat_df) {
|
||
| 148 | -+ | 24x |
- #' @param n_theta (`count`)\cr number of variance parameters.+ assert_numeric(t_stat_df, min.len = 1L, lower = .Machine$double.xmin, any.missing = FALSE) |
| 149 |
- #' @param n_groups (`count`)\cr number of groups.+ |
||
| 150 | -+ | 24x |
- #' @keywords internal+ if (test_scalar(t_stat_df)) {
|
| 151 | -+ | 1x |
- h_print_cov <- function(cov_type, n_theta, n_groups) {
+ t_stat_df |
| 152 | -9x | +23x |
- assert_string(cov_type)+ } else if (all(abs(diff(t_stat_df)) < sqrt(.Machine$double.eps))) {
|
| 153 | -9x | +1x |
- assert_count(n_theta, positive = TRUE)+ mean(t_stat_df) |
| 154 | -9x | +22x |
- assert_count(n_groups, positive = TRUE)+ } else if (any(t_stat_df <= 2)) {
|
| 155 | -9x | +2x |
- cov_definition <- switch(cov_type,+ 2 |
| 156 | -9x | +
- us = "unstructured",+ } else {
|
|
| 157 | -9x | +20x |
- toep = "Toeplitz",+ e <- sum(t_stat_df / (t_stat_df - 2)) |
| 158 | -9x | +20x |
- toeph = "heterogeneous Toeplitz",+ 2 * e / (e - (length(t_stat_df))) |
| 159 | -9x | +
- ar1 = "auto-regressive order one",+ } |
|
| 160 | -9x | +
- ar1h = "heterogeneous auto-regressive order one",+ } |
|
| 161 | -9x | +
- ad = "ante-dependence",+ |
|
| 162 | -9x | +
- adh = "heterogeneous ante-dependence",+ #' Creating F-Statistic Results from One-Dimensional Contrast |
|
| 163 | -9x | +
- cs = "compound symmetry",+ #' |
|
| 164 | -9x | +
- csh = "heterogeneous compound symmetry",+ #' @description Creates multi-dimensional result from one-dimensional contrast from [df_1d()]. |
|
| 165 | -9x | +
- sp_exp = "spatial exponential"+ #' |
|
| 166 |
- )+ #' @param object (`mmrm`)\cr model fit. |
||
| 167 |
-
+ #' @param contrast (`numeric`)\cr one-dimensional contrast. |
||
| 168 | -9x | +
- catstr <- sprintf(+ #' |
|
| 169 | -9x | +
- "Covariance: %s (%d variance parameters%s)\n",+ #' @return The one-dimensional degrees of freedom are calculated and then |
|
| 170 | -9x | +
- cov_definition,+ #' based on that the p-value is calculated. |
|
| 171 | -9x | +
- n_theta,+ #' |
|
| 172 | -9x | +
- ifelse(n_groups == 1L, "", sprintf(" of %d groups", n_groups))
+ #' @keywords internal |
|
| 173 |
- )+ h_df_md_from_1d <- function(object, contrast) {
|
||
| 174 | -9x | +134x |
- cat(catstr)+ res_1d <- h_df_1d_sat(object, contrast) |
| 175 | -+ | 134x |
- }+ list( |
| 176 | -+ | 134x |
-
+ num_df = 1, |
| 177 | -+ | 134x |
- #' Printing AIC and other Model Fit Criteria+ denom_df = res_1d$df, |
| 178 | -+ | 134x |
- #'+ f_stat = res_1d$t_stat^2, |
| 179 | -+ | 134x |
- #' This is used in [print.summary.mmrm()].+ p_val = stats::pf(q = res_1d$t_stat^2, df1 = 1, df2 = res_1d$df, lower.tail = FALSE) |
| 180 |
- #'+ ) |
||
| 181 |
- #' @param aic_list (`list`)\cr list as part of from [summary.mmrm()].+ } |
||
| 182 |
- #' @param digits (`number`)\cr number of decimal places used with [round()].+ |
||
| 183 |
- #'+ #' Calculation of Satterthwaite Degrees of Freedom for Multi-Dimensional Contrast |
||
| 184 |
- #' @keywords internal+ #' |
||
| 185 |
- h_print_aic_list <- function(aic_list,+ #' @description Used in [df_md()] if method is "Satterthwaite". |
||
| 186 |
- digits = 1) {
+ #' |
||
| 187 | -6x | +
- diag_vals <- round(unlist(aic_list), digits)+ #' @param object (`mmrm`)\cr the MMRM fit. |
|
| 188 | -6x | +
- diag_vals <- format(diag_vals)+ #' @param contrast (`matrix`)\cr numeric contrast matrix, if given a `numeric` |
|
| 189 | -6x | +
- print(diag_vals, quote = FALSE)+ #' then this is coerced to a row vector. Note that this should not include |
|
| 190 |
- }+ #' elements for singular coefficient estimates, i.e. only refer to the |
||
| 191 |
-
+ #' actually estimated coefficients. |
||
| 192 |
- #' @describeIn mmrm_methods prints the MMRM fit summary.+ #' |
||
| 193 |
- #' @exportS3Method+ #' @return List with `num_df`, `denom_df`, `f_stat` and `p_val` (2-sided p-value). |
||
| 195 |
- print.summary.mmrm <- function(x,+ h_df_md_sat <- function(object, contrast) {
|
||
| 196 | -+ | 151x |
- digits = max(3, getOption("digits") - 3),
+ assert_class(object, "mmrm") |
| 197 | -+ | 151x |
- signif.stars = getOption("show.signif.stars"), # nolint
+ assert_matrix(contrast, mode = "numeric", any.missing = FALSE, ncols = length(component(object, "beta_est"))) |
| 198 |
- ...) {
+ # Early return if we are in the one-dimensional case. |
||
| 199 | -5x | +151x |
- cat("mmrm fit\n\n")
+ if (identical(nrow(contrast), 1L)) {
|
| 200 | -5x | +132x |
- h_print_call(x$call, x$n_obs, x$n_subjects, x$n_timepoints)+ return(h_df_md_from_1d(object, contrast)) |
| 201 | -5x | +
- h_print_cov(x$cov_type, x$n_theta, x$n_groups)+ } |
|
| 202 | -5x | +
- cat("Method: ", x$method, "\n", sep = "")
+
|
|
| 203 | -5x | +19x |
- cat("Vcov Method: ", x$vcov, "\n", sep = "")
+ contrast_cov <- h_quad_form_mat(contrast, component(object, "beta_vcov")) |
| 204 | -5x | +19x |
- cat("Inference: ")
+ eigen_cont_cov <- eigen(contrast_cov) |
| 205 | -5x | +19x |
- cat(ifelse(x$reml, "REML", "ML"))+ eigen_cont_cov_vctrs <- eigen_cont_cov$vectors |
| 206 | -5x | +19x |
- cat("\n\n")
+ eigen_cont_cov_vals <- eigen_cont_cov$values |
| 207 | -5x | +
- cat("Model selection criteria:\n")
+
|
|
| 208 | -5x | +19x |
- h_print_aic_list(x$aic_list)+ eps <- sqrt(.Machine$double.eps) |
| 209 | -5x | +19x |
- cat("\n")
+ tol <- max(eps * eigen_cont_cov_vals[1], 0) |
| 210 | -5x | +19x |
- cat("Coefficients: ")
+ rank_cont_cov <- sum(eigen_cont_cov_vals > tol) |
| 211 | -5x | +19x |
- if (x$n_singular_coefs > 0) {
+ assert_number(rank_cont_cov, lower = .Machine$double.xmin) |
| 212 | -1x | +19x |
- cat("(", x$n_singular_coefs, " not defined because of singularities)", sep = "")
+ rank_seq <- seq_len(rank_cont_cov) |
| 213 | -+ | 19x |
- }+ vctrs_cont_prod <- crossprod(eigen_cont_cov_vctrs, contrast)[rank_seq, , drop = FALSE] |
| 214 | -5x | +
- cat("\n")
+
|
|
| 215 | -5x | +
- stats::printCoefmat(+ # Early return if rank 1. |
|
| 216 | -5x | +19x |
- x$coefficients,+ if (identical(rank_cont_cov, 1L)) {
|
| 217 | -5x | +1x |
- zap.ind = 3,+ return(h_df_md_from_1d(object, vctrs_cont_prod)) |
| 218 | -5x | +
- digits = digits,+ } |
|
| 219 | -5x | +
- signif.stars = signif.stars+ |
|
| 220 | -+ | 18x |
- )+ t_squared_nums <- drop(vctrs_cont_prod %*% object$beta_est)^2 |
| 221 | -5x | +18x |
- cat("\n")
+ t_squared_denoms <- eigen_cont_cov_vals[rank_seq] |
| 222 | -5x | +18x |
- cat("Covariance estimate:\n")
+ t_squared <- t_squared_nums / t_squared_denoms |
| 223 | -5x | +18x |
- if (is.list(x$varcor)) {
+ f_stat <- sum(t_squared) / rank_cont_cov |
| 224 | -1x | +18x |
- for (v in names(x$varcor)) {
+ t_stat_df_nums <- 2 * eigen_cont_cov_vals^2 |
| 225 | -2x | +18x |
- cat(sprintf("Group: %s\n", v))
+ t_stat_df <- if (identical(object$vcov, "Asymptotic")) {
|
| 226 | -2x | +18x |
- print(round(x$varcor[[v]], digits = digits))+ grads_vctrs_cont_prod <- lapply( |
| 227 | -+ | 18x |
- }+ rank_seq, |
| 228 | -+ | 18x |
- } else {
+ function(m) h_gradient(component(object, "jac_list"), contrast = vctrs_cont_prod[m, ]) |
| 229 | -4x | +
- print(round(x$varcor, digits = digits))+ ) |
|
| 230 | -+ | 18x |
- }+ t_stat_df_denoms <- vapply( |
| 231 | -5x | +18x |
- cat("\n")
+ grads_vctrs_cont_prod, |
| 232 | -5x | +18x |
- invisible(x)+ h_quad_form_vec, |
| 233 | -+ | 18x |
- }+ center = component(object, "theta_vcov"), |
| 234 | -+ | 18x |
-
+ numeric(1) |
| 235 |
-
+ ) |
||
| 236 | -+ | 18x |
- #' @describeIn mmrm_methods obtain the confidence intervals for the coefficients.+ t_stat_df_nums / t_stat_df_denoms |
| 237 |
- #' @exportS3Method+ } else {
|
||
| 238 | -+ | ! |
- #' @examples+ vapply( |
| 239 | -+ | ! |
- #' # Confidence Interval:+ rank_seq, |
| 240 | -+ | ! |
- #' confint(object)+ function(m) {
|
| 241 | -+ | ! |
- confint.mmrm <- function(object, parm, level = 0.95, ...) {
+ contrast_matrix <- Matrix::.bdiag( |
| 242 | -20x | +! |
- cf <- coef(object)+ rep(list(vctrs_cont_prod[m, , drop = FALSE]), component(object, "n_subjects")) |
| 243 | -20x | +
- pnames <- names(cf)+ ) |
|
| 244 | -20x | +! |
- if (missing(parm)) {
+ contrast_matrix <- as.matrix(contrast_matrix) |
| 245 | -15x | +! |
- parm <- pnames+ g_matrix <- h_quad_form_mat(contrast_matrix, object$empirical_df_mat) |
| 246 | -+ | ! |
- }+ h_tr(g_matrix)^2 / sum(g_matrix^2) |
| 247 | -20x | +
- assert(+ }, |
|
| 248 | -20x | +! |
- check_subset(parm, pnames),+ FUN.VALUE = 0 |
| 249 | -20x | +
- check_integerish(parm, lower = 1L, upper = length(cf))+ ) |
|
| 250 |
- )+ } |
||
| 251 | -2x | +18x |
- if (is.numeric(parm)) parm <- pnames[parm]+ denom_df <- h_md_denom_df(t_stat_df) |
| 252 | -18x | +
- assert_number(level, lower = 0, upper = 1)+ |
|
| 253 | 18x |
- a <- (1 - level) / 2+ list( |
|
| 254 | 18x |
- pct <- paste(format(100 * c(a, 1 - a), trim = TRUE, scientific = FALSE, digits = 3), "%")+ num_df = rank_cont_cov, |
|
| 255 | 18x |
- coef_table <- h_coef_table(object)+ denom_df = denom_df, |
|
| 256 | 18x |
- df <- coef_table[parm, "df"]+ f_stat = f_stat, |
|
| 257 | 18x |
- ses <- coef_table[parm, "Std. Error"]+ p_val = stats::pf(q = f_stat, df1 = rank_cont_cov, df2 = denom_df, lower.tail = FALSE) |
|
| 258 | -18x | -
- fac <- stats::qt(a, df = df)- |
- |
| 259 | -18x | -
- ci <- array(NA, dim = c(length(parm), 2L), dimnames = list(parm, pct))- |
- |
| 260 | -18x | -
- sefac <- ses * fac- |
- |
| 261 | -18x | -
- ci[] <- cf[parm] + c(sefac, -sefac)- |
- |
| 262 | -18x | +
- ci+ ) |
|
| 263 | +259 |
}@@ -31437,14 +31199,14 @@ mmrm coverage - 97.08% |
| 1 |
- #' Determine Within or Between for each Design Matrix Column+ #' Extract Formula Terms used for Covariance Structure Definition |
|||
| 3 |
- #' @description Used in [h_df_bw_calc()] to determine whether a variable+ #' @param f (`formula`)\cr a formula from which covariance terms should be |
|||
| 4 |
- #' differs only between subjects or also within subjects.+ #' extracted. |
|||
| 6 |
- #' @param x_matrix (`matrix`)\cr the design matrix with column names.+ #' @return A list of covariance structure expressions found in `f`. |
|||
| 7 |
- #' @param subject_ids (`factor`)\cr the subject IDs.+ #' |
|||
| 8 |
- #'+ #' @importFrom stats terms |
|||
| 9 |
- #' @return Character vector with "intercept", "within" or "between" for each+ #' @keywords internal |
|||
| 10 |
- #' design matrix column identified via the names of the vector.+ h_extract_covariance_terms <- function(f) {
|
|||
| 11 | +290x | +
+ specials <- cov_types(c("abbr", "habbr"))
+ |
+ ||
| 12 | +290x | +
+ terms <- stats::terms(formula_rhs(f), specials = specials)+ |
+ ||
| 13 | +290x | +
+ covariance_terms <- Filter(length, attr(terms, "specials"))+ |
+ ||
| 14 | +290x | +
+ variables <- attr(terms, "variables")+ |
+ ||
| 15 | +290x | +
+ lapply(covariance_terms, function(i) variables[[i + 1]])+ |
+ ||
| 16 | ++ |
+ }+ |
+ ||
| 17 | ++ | + + | +||
| 18 | ++ |
+ #' Drop Formula Terms used for Covariance Structure Definition+ |
+ ||
| 19 | ++ |
+ #'+ |
+ ||
| 20 | ++ |
+ #' @param f (`formula`)\cr a formula from which covariance terms should be+ |
+ ||
| 21 | ++ |
+ #' dropped.+ |
+ ||
| 22 | ++ |
+ #'+ |
+ ||
| 23 | ++ |
+ #' @return The formula without accepted covariance terms.+ |
+ ||
| 24 |
#' |
|||
| 12 | -+ | |||
| 25 | ++ |
+ #' @details `terms` is used and it will preserve the environment attribute.+ |
+ ||
| 26 | ++ |
+ #' This ensures the returned formula and the input formula have the same environment.+ |
+ ||
| 27 | ++ |
+ #' @importFrom stats terms drop.terms+ |
+ ||
| 28 | ++ |
+ #' @keywords internal+ |
+ ||
| 29 | ++ |
+ h_drop_covariance_terms <- function(f) {
+ |
+ ||
| 30 | +273x | +
+ specials <- cov_types(c("abbr", "habbr"))
+ |
+ ||
| 31 | ++ | + + | +||
| 32 | +273x | +
+ terms <- stats::terms(f, specials = specials)+ |
+ ||
| 33 | +273x | +
+ covariance_terms <- Filter(Negate(is.null), attr(terms, "specials"))+ |
+ ||
| 34 | ++ | + + | +||
| 35 | ++ |
+ # if no covariance terms were found, return original formula+ |
+ ||
| 36 | +273x | +
+ if (length(covariance_terms) == 0) {
+ |
+ ||
| 37 | +6x |
- #' @keywords internal+ return(f) |
||
| 13 | +38 |
- h_within_or_between <- function(x_matrix, subject_ids) {
+ } |
||
| 14 | -19x | +39 | +267x |
- assert_matrix(x_matrix, col.names = "unique", min.cols = 1L)+ if (length(f) != 3) {
|
| 15 | -19x | +40 | +1x |
- assert_factor(subject_ids, len = nrow(x_matrix))+ update_str <- "~ . -" |
| 16 | +41 |
-
+ } else {
|
||
| 17 | -19x | +42 | +266x |
- n_subjects <- length(unique(subject_ids))+ update_str <- ". ~ . -" |
| 18 | -19x | +|||
| 43 | +
- vapply(+ } |
|||
| 19 | -19x | +44 | +267x |
- colnames(x_matrix),+ stats::update( |
| 20 | -19x | +45 | +267x |
- function(x) {
+ f, |
| 21 | -112x | +46 | +267x |
- if (x == "(Intercept)") {
+ stats::as.formula(paste(update_str, deparse(attr(terms, "variables")[[covariance_terms[[1]] + 1]]))) |
| 22 | -19x | +|||
| 47 | +
- "intercept"+ ) |
|||
| 23 | +48 |
- } else {
+ } |
||
| 24 | -93x | +|||
| 49 | +
- n_unique <- nrow(unique(cbind(x_matrix[, x], subject_ids)))+ |
|||
| 25 | -43x | +|||
| 50 | +
- if (n_unique > n_subjects) "within" else "between"+ #' Add Individual Covariance Variables As Terms to Formula |
|||
| 26 | +51 |
- }+ #' |
||
| 27 | +52 |
- },+ #' @param f (`formula`)\cr a formula to which covariance structure terms should |
||
| 28 | -19x | +|||
| 53 | +
- character(1L)+ #' be added. |
|||
| 29 | +54 |
- )+ #' @param covariance (`cov_struct`)\cr a covariance structure object from which |
||
| 30 | +55 |
- }+ #' additional variables should be sourced. |
||
| 31 | +56 |
-
+ #' |
||
| 32 | +57 |
- #' Calculation of Between-Within Degrees of Freedom+ #' @return A new formula with included covariance terms. |
||
| 33 | +58 |
#' |
||
| 34 | +59 |
- #' @description Used in [h_df_1d_bw()] and [h_df_md_bw()].+ #' @details [stats::update()] is used to append the covariance structure and the environment |
||
| 35 | +60 |
- #'+ #' attribute will not be changed. This ensures the returned formula and the input formula |
||
| 36 | +61 |
- #' @param object (`mmrm`)\cr the fitted MMRM.+ #' have the same environment. |
||
| 37 | +62 |
#' |
||
| 38 | +63 |
- #' @return List with:+ #' @keywords internal |
||
| 39 | +64 |
- #' - `coefs_between_within` calculated via [h_within_or_between()]+ h_add_covariance_terms <- function(f, covariance) {
+ |
+ ||
| 65 | +271x | +
+ cov_terms <- with(covariance, c(subject, visits, group))+ |
+ ||
| 66 | +265x | +
+ cov_terms <- paste(cov_terms, collapse = " + ")+ |
+ ||
| 67 | +265x | +
+ stats::update(f, stats::as.formula(paste(". ~ . + ", cov_terms)))
|
||
| 40 | +68 |
- #' - `ddf_between`+ } |
||
| 41 | +69 |
- #' - `ddf_within`+ |
||
| 42 | +70 |
- #'+ #' Add Formula Terms with Character |
||
| 43 | +71 |
- #' @keywords internal+ #' |
||
| 44 | +72 |
- h_df_bw_calc <- function(object) {
+ #' Add formula terms from the original formula with character representation. |
||
| 45 | -18x | +|||
| 73 | +
- assert_class(object, "mmrm")+ #' |
|||
| 46 | +74 |
-
+ #' @param f (`formula`)\cr a formula to be updated. |
||
| 47 | -18x | +|||
| 75 | +
- n_subjects <- component(object, "n_subjects")+ #' @param adds (`character`)\cr representation of elements to be added. |
|||
| 48 | -18x | +|||
| 76 | +
- n_obs <- component(object, "n_obs")+ #' @param drop_response (`flag`)\cr whether response should be dropped. |
|||
| 49 | -18x | +|||
| 77 | +
- x_mat <- component(object, "x_matrix")+ #' |
|||
| 50 | +78 |
-
+ #' @details Elements in `adds` will be added from the formula, while the environment |
||
| 51 | -18x | +|||
| 79 | +
- subject_var <- component(object, "subject_var")+ #' of the formula is unchanged. If `adds` is `NULL` or `character(0)`, the formula is |
|||
| 52 | -18x | +|||
| 80 | +
- full_frame <- component(object, "full_frame")+ #' unchanged. |
|||
| 53 | -18x | +|||
| 81 | +
- subject_ids <- full_frame[[subject_var]]+ #' @return A new formula with elements in `drops` removed. |
|||
| 54 | +82 |
-
+ #' |
||
| 55 | -18x | +|||
| 83 | +
- coefs_between_within <- h_within_or_between(x_mat, subject_ids)+ #' @keywords internal |
|||
| 56 | -18x | +|||
| 84 | +
- n_coefs_between <- sum(coefs_between_within == "between")+ h_add_terms <- function(f, adds, drop_response = FALSE) {
|
|||
| 57 | -18x | +85 | +599x |
- n_intercept <- sum(coefs_between_within == "intercept")+ assert_character(adds, null.ok = TRUE) |
| 58 | -18x | +86 | +599x |
- n_coefs_within <- sum(coefs_between_within == "within")+ if (length(adds) > 0L) {
|
| 59 | -18x | +87 | +321x |
- ddf_between <- n_subjects - n_coefs_between - n_intercept+ add_terms <- stats::as.formula(sprintf(". ~ . + %s", paste(adds, collapse = "+")))
|
| 60 | -18x | +88 | +321x |
- ddf_within <- n_obs - n_subjects - n_coefs_within+ f <- stats::update(f, add_terms) |
| 61 | +89 |
-
+ } |
||
| 62 | -18x | +90 | +599x |
- list(+ if (drop_response && length(f) == 3L) {
|
| 63 | -18x | +91 | +35x |
- coefs_between_within = coefs_between_within,+ f[[2]] <- NULL |
| 64 | -18x | +|||
| 92 | +
- ddf_between = ddf_between,+ } |
|||
| 65 | -18x | +93 | +599x |
- ddf_within = ddf_within+ f |
| 66 | +94 |
- )+ } |
| 67 | +1 |
- }+ #' Support for `emmeans` |
||
| 68 | +2 |
-
+ #' |
||
| 69 | +3 |
- #' Assign Minimum Degrees of Freedom Given Involved Coefficients+ #' @description `r lifecycle::badge("stable")`
|
||
| 70 | +4 |
#' |
||
| 71 | +5 |
- #' @description Used in [h_df_1d_bw()] and [h_df_md_bw()].+ #' This package includes methods that allow `mmrm` objects to be used |
||
| 72 | +6 |
- #'+ #' with the `emmeans` package. `emmeans` computes estimated marginal means |
||
| 73 | +7 |
- #' @param bw_calc (`list`)\cr from [h_df_bw_calc()].+ #' (also called least-square means) for the coefficients of the MMRM. |
||
| 74 | +8 |
- #' @param is_coef_involved (`logical`)\cr whether each coefficient is involved+ #' We can also e.g. obtain differences between groups by applying |
||
| 75 | +9 |
- #' in the contrast.+ #' [`pairs()`][emmeans::pairs.emmGrid()] on the object returned |
||
| 76 | +10 |
- #'+ #' by [emmeans::emmeans()]. |
||
| 77 | +11 |
- #' @return The minimum of the degrees of freedom assigned to each involved+ #' |
||
| 78 | +12 |
- #' coefficient according to its between-within categorization.+ #' @examples |
||
| 79 | +13 |
- #'+ #' fit <- mmrm( |
||
| 80 | +14 |
- #' @keywords internal+ #' formula = FEV1 ~ RACE + SEX + ARMCD * AVISIT + us(AVISIT | USUBJID), |
||
| 81 | +15 |
- h_df_min_bw <- function(bw_calc, is_coef_involved) {
+ #' data = fev_data |
||
| 82 | -17x | +|||
| 16 | +
- assert_list(bw_calc)+ #' ) |
|||
| 83 | -17x | +|||
| 17 | +
- assert_names(names(bw_calc), identical.to = c("coefs_between_within", "ddf_between", "ddf_within"))
+ #' if (require(emmeans)) {
|
|||
| 84 | -17x | +|||
| 18 | +
- assert_logical(is_coef_involved, len = length(bw_calc$coefs_between_within))+ #' emmeans(fit, ~ ARMCD | AVISIT) |
|||
| 85 | -17x | +|||
| 19 | +
- assert_true(sum(is_coef_involved) > 0)+ #' pairs(emmeans(fit, ~ ARMCD | AVISIT), reverse = TRUE) |
|||
| 86 | +20 |
-
+ #' } |
||
| 87 | -17x | +|||
| 21 | +
- coef_categories <- bw_calc$coefs_between_within[is_coef_involved]+ #' @name emmeans_support |
|||
| 88 | -17x | +|||
| 22 | +
- coef_dfs <- vapply(+ NULL |
|||
| 89 | -17x | +|||
| 23 | +
- X = coef_categories,+ |
|||
| 90 | -17x | +|||
| 24 | +
- FUN = switch,+ #' Returns a `data.frame` for `emmeans` Purposes |
|||
| 91 | -17x | +|||
| 25 | +
- intercept = bw_calc$ddf_within,+ #' |
|||
| 92 | -17x | +|||
| 26 | +
- between = bw_calc$ddf_between,+ #' @seealso See [emmeans::recover_data()] for background. |
|||
| 93 | -17x | +|||
| 27 | +
- within = bw_calc$ddf_within,+ #' @keywords internal |
|||
| 94 | -17x | +|||
| 28 | +
- FUN.VALUE = integer(1)+ #' @noRd |
|||
| 95 | +29 |
- )+ recover_data.mmrm <- function(object, ...) { # nolint
|
||
| 96 | -17x | +30 | +13x |
- min(coef_dfs)+ fun_call <- stats::getCall(object) |
| 97 | +31 |
- }+ # subject_var is excluded because it should not contain fixed effect. |
||
| 98 | +32 |
-
+ # visit_var is not excluded because emmeans can provide marginal mean |
||
| 99 | +33 |
- #' Calculation of Between-Within Degrees of Freedom for One-Dimensional Contrast+ # by each visit if visit_var is not spatial. |
||
| 100 | -+ | |||
| 34 | +13x |
- #'+ model_frame <- stats::model.frame( |
||
| 101 | -+ | |||
| 35 | +13x |
- #' @description Used in [df_1d()] if method is "Between-Within".+ object, |
||
| 102 | -+ | |||
| 36 | +13x |
- #'+ include = c( |
||
| 103 | -+ | |||
| 37 | +13x |
- #' @inheritParams h_df_1d_sat+ if (!object$formula_parts$is_spatial) "visit_var" else NULL, |
||
| 104 | -+ | |||
| 38 | +13x |
- #' @inherit h_df_1d_sat return+ "response_var", "group_var" |
||
| 105 | +39 |
- #' @keywords internal+ ) |
||
| 106 | +40 |
- h_df_1d_bw <- function(object, contrast) {
+ ) |
||
| 107 | -7x | +41 | +13x |
- assert_class(object, "mmrm")+ model_terms <- stats::delete.response(stats::terms(model_frame)) |
| 108 | -7x | -
- assert_numeric(contrast, len = length(component(object, "beta_est")))- |
- ||
| 109 | -+ | 42 | +13x |
-
+ emmeans::recover_data( |
| 110 | -7x | +43 | +13x |
- bw_calc <- h_df_bw_calc(object)+ fun_call, |
| 111 | -7x | +44 | +13x |
- is_coef_involved <- contrast != 0+ trms = model_terms, |
| 112 | -7x | +45 | +13x |
- df <- h_df_min_bw(bw_calc, is_coef_involved)+ na.action = "na.omit", |
| 113 | -7x | +46 | +13x |
- h_test_1d(object, contrast, df)+ frame = model_frame, |
| 114 | +47 |
- }+ ... |
||
| 115 | +48 |
-
+ ) |
||
| 116 | +49 |
- #' Calculation of Between-Within Degrees of Freedom for Multi-Dimensional Contrast+ } |
||
| 117 | +50 |
- #'+ |
||
| 118 | +51 |
- #' @description Used in [df_md()] if method is "Between-Within".+ #' Returns a List of Model Details for `emmeans` Purposes |
||
| 119 | +52 |
#' |
||
| 120 | +53 |
- #' @inheritParams h_df_md_sat+ #' @seealso See [emmeans::emm_basis()] for background. |
||
| 121 | +54 |
- #' @inherit h_df_md_sat return+ #' @keywords internal |
||
| 122 | +55 |
- #' @keywords internal+ #' @noRd |
||
| 123 | +56 |
- h_df_md_bw <- function(object, contrast) {
+ emm_basis.mmrm <- function(object, # nolint |
||
| 124 | -7x | +|||
| 57 | +
- assert_class(object, "mmrm")+ trms, |
|||
| 125 | -7x | +|||
| 58 | +
- assert_matrix(contrast, mode = "numeric", any.missing = FALSE, ncols = length(component(object, "beta_est")))+ xlev, |
|||
| 126 | +59 |
-
+ grid, |
||
| 127 | -7x | +|||
| 60 | +
- bw_calc <- h_df_bw_calc(object)+ ...) {
|
|||
| 128 | -7x | +61 | +13x |
- is_coef_involved <- apply(X = contrast != 0, MARGIN = 2L, FUN = any)+ model_frame <- stats::model.frame(trms, grid, na.action = stats::na.pass, xlev = xlev) |
| 129 | -7x | +62 | +13x |
- df <- h_df_min_bw(bw_calc, is_coef_involved)+ contrasts <- component(object, "contrasts") |
| 130 | -7x | +63 | +13x |
- h_test_md(object, contrast, df)+ model_mat <- stats::model.matrix(trms, model_frame, contrasts.arg = contrasts) |
| 131 | -+ | |||
| 64 | +13x |
- }+ beta_hat <- component(object, "beta_est") |
| 1 | -+ | |||
| 65 | +13x |
- # Internal functions used for skipping tests or examples.+ nbasis <- if (length(beta_hat) < ncol(model_mat)) {
|
||
| 2 | -+ | |||
| 66 | +6x |
-
+ kept <- match(names(beta_hat), colnames(model_mat)) |
||
| 3 | -+ | |||
| 67 | +6x |
- # Predicate whether currently running R version is under development.+ beta_hat <- NA * model_mat[1L, ] |
||
| 4 | -+ | |||
| 68 | +6x |
- is_r_devel <- function() {
+ beta_hat[kept] <- component(object, "beta_est") |
||
| 5 | -21x | +69 | +6x |
- grepl("devel", R.version$status)
+ orig_model_mat <- stats::model.matrix( |
| 6 | -+ | |||
| 70 | +6x |
- }+ trms, |
||
| 7 | -+ | |||
| 71 | +6x |
-
+ stats::model.frame( |
||
| 8 | -+ | |||
| 72 | +6x |
- # Predicate whether currently running on a Linux operating system.+ object, |
||
| 9 | -+ | |||
| 73 | +6x |
- is_linux <- function() {
+ include = c( |
||
| 10 | -1x | +74 | +6x |
- tolower(Sys.info()[["sysname"]]) == "linux"+ if (!object$formula_parts$is_spatial) "visit_var" else NULL, |
| 11 | -+ | |||
| 75 | +6x |
- }+ "response_var", "group_var" |
||
| 12 | +76 |
-
+ ) |
||
| 13 | +77 |
- # Get the compiler information. Workaround for older R versions+ ), |
||
| 14 | -+ | |||
| 78 | +6x |
- # where R_compiled_by() is not available.+ contrasts.arg = contrasts |
||
| 15 | +79 |
- get_compiler <- function() {
+ ) |
||
| 16 | -3x | +80 | +6x |
- r_cmd <- file.path(R.home("bin"), "R")
+ estimability::nonest.basis(orig_model_mat) |
| 17 | -3x | +|||
| 81 | +
- system2(r_cmd, args = "CMD config CC", stdout = TRUE)+ } else {
|
|||
| 18 | -+ | |||
| 82 | +7x |
- }+ estimability::all.estble |
||
| 19 | +83 |
-
+ } |
||
| 20 | -+ | |||
| 84 | +13x |
- # Predicate whether currently using a clang compiler.+ dfargs <- list(object = object) |
||
| 21 | -+ | |||
| 85 | +13x |
- is_using_clang <- function() {
+ dffun <- function(k, dfargs) {
|
||
| 22 | -2x | +86 | +113x |
- grepl("clang", get_compiler())
+ mmrm::df_md(dfargs$object, contrast = k)$denom_df |
| 23 | +87 |
- }+ } |
||
| 24 | -+ | |||
| 88 | +13x |
-
+ list( |
||
| 25 | -+ | |||
| 89 | +13x |
- # Predicate whether an R-devel version is running on Linux Fedora or+ X = model_mat, |
||
| 26 | -+ | |||
| 90 | +13x |
- # Debian with a clang compiler.+ bhat = beta_hat, |
||
| 27 | -+ | |||
| 91 | +13x |
- is_r_devel_linux_clang <- function() {
+ nbasis = nbasis, |
||
| 28 | -20x | +92 | +13x |
- is_r_devel() &&+ V = component(object, "beta_vcov"), |
| 29 | -20x | +93 | +13x |
- is_linux() &&+ dffun = dffun, |
| 30 | -20x | +94 | +13x |
- is_using_clang()+ dfargs = dfargs |
| 31 | +95 | ++ |
+ )+ |
+ |
| 96 |
}@@ -33708,14 +33666,14 @@ mmrm coverage - 97.08% |
| 1 |
- #' Register `mmrm` For Use With `tidymodels`+ #' Calculation of Degrees of Freedom for One-Dimensional Contrast |
||
| 3 |
- #' @inheritParams base::requireNamespace+ #' @description `r lifecycle::badge("stable")`
|
||
| 4 |
- #' @return A logical value indicating whether registration was successful.+ #' Calculates the estimate, adjusted standard error, degrees of freedom, |
||
| 5 |
- #'+ #' t statistic and p-value for one-dimensional contrast. |
||
| 6 |
- #' @details We can use `parsnip::show_model_info("linear_reg")` to check the
+ #' |
||
| 7 |
- #' registration with `parsnip` and thus the wider `tidymodels` ecosystem.+ #' @param object (`mmrm`)\cr the MMRM fit. |
||
| 8 |
- #'+ #' @param contrast (`numeric`)\cr contrast vector. Note that this should not include |
||
| 9 |
- #' @keywords internal+ #' elements for singular coefficient estimates, i.e. only refer to the |
||
| 10 |
- parsnip_add_mmrm <- function(quietly = FALSE) {
+ #' actually estimated coefficients. |
||
| 11 | -1x | +
- if (!requireNamespace("parsnip", quietly = quietly)) {
+ #' @return List with `est`, `se`, `df`, `t_stat` and `p_val`. |
|
| 12 | -! | +
- return(FALSE)+ #' @export |
|
| 13 |
- }+ #' |
||
| 14 |
-
+ #' @examples |
||
| 15 | -1x | +
- parsnip::set_model_engine(+ #' object <- mmrm( |
|
| 16 | -1x | +
- model = "linear_reg",+ #' formula = FEV1 ~ RACE + SEX + ARMCD * AVISIT + us(AVISIT | USUBJID), |
|
| 17 | -1x | +
- eng = "mmrm",+ #' data = fev_data |
|
| 18 | -1x | +
- mode = "regression"+ #' ) |
|
| 19 |
- )+ #' contrast <- numeric(length(object$beta_est)) |
||
| 20 |
-
+ #' contrast[3] <- 1 |
||
| 21 | -1x | +
- parsnip::set_dependency(+ #' df_1d(object, contrast) |
|
| 22 | -1x | +
- pkg = "mmrm",+ df_1d <- function(object, contrast) {
|
|
| 23 | -1x | +338x |
- model = "linear_reg",+ assert_class(object, "mmrm") |
| 24 | -1x | +338x |
- eng = "mmrm",+ assert_numeric(contrast, len = length(component(object, "beta_est")), any.missing = FALSE) |
| 25 | -1x | +338x |
- mode = "regression"+ contrast <- as.vector(contrast) |
| 26 | -+ | 338x |
- )+ switch(object$method, |
| 27 | -+ | 318x |
-
+ "Satterthwaite" = h_df_1d_sat(object, contrast), |
| 28 | -1x | +19x |
- parsnip::set_encoding(+ "Kenward-Roger" = h_df_1d_kr(object, contrast), |
| 29 | -1x | +! |
- model = "linear_reg",+ "Residual" = h_df_1d_res(object, contrast), |
| 30 | 1x |
- eng = "mmrm",+ "Between-Within" = h_df_1d_bw(object, contrast), |
|
| 31 | -1x | +! |
- mode = "regression",+ stop("Unrecognized degrees of freedom method: ", object$method)
|
| 32 | -1x | +
- options = list(+ ) |
|
| 33 | -1x | +
- predictor_indicators = "none",+ } |
|
| 34 | -1x | +
- compute_intercept = FALSE,+ |
|
| 35 | -1x | +
- remove_intercept = FALSE,+ |
|
| 36 | -1x | +
- allow_sparse_x = TRUE+ #' Calculation of Degrees of Freedom for Multi-Dimensional Contrast |
|
| 37 |
- )+ #' |
||
| 38 |
- )+ #' @description `r lifecycle::badge("stable")`
|
||
| 39 |
-
+ #' Calculates the estimate, standard error, degrees of freedom, |
||
| 40 | -1x | +
- parsnip::set_fit(+ #' t statistic and p-value for one-dimensional contrast, depending on the method |
|
| 41 | -1x | +
- model = "linear_reg",+ #' used in [mmrm()]. |
|
| 42 | -1x | +
- eng = "mmrm",+ #' |
|
| 43 | -1x | +
- mode = "regression",+ #' @param object (`mmrm`)\cr the MMRM fit. |
|
| 44 | -1x | +
- value = list(+ #' @param contrast (`matrix`)\cr numeric contrast matrix, if given a `numeric` |
|
| 45 | -1x | +
- interface = "formula",+ #' then this is coerced to a row vector. Note that this should not include |
|
| 46 | -1x | +
- protect = c("formula", "data", "weights"),
+ #' elements for singular coefficient estimates, i.e. only refer to the |
|
| 47 | -1x | +
- data = c(formula = "formula", data = "data", weights = "weights"),+ #' actually estimated coefficients. |
|
| 48 | -1x | +
- func = c(pkg = "mmrm", fun = "mmrm"),+ #' |
|
| 49 | -1x | +
- defaults = list()+ #' @return List with `num_df`, `denom_df`, `f_stat` and `p_val` (2-sided p-value). |
|
| 50 |
- )+ #' @export |
||
| 51 |
- )+ #' |
||
| 52 |
-
+ #' @examples |
||
| 53 | -1x | +
- parsnip::set_pred(+ #' object <- mmrm( |
|
| 54 | -1x | +
- model = "linear_reg",+ #' formula = FEV1 ~ RACE + SEX + ARMCD * AVISIT + us(AVISIT | USUBJID), |
|
| 55 | -1x | +
- eng = "mmrm",+ #' data = fev_data |
|
| 56 | -1x | +
- mode = "regression",+ #' ) |
|
| 57 | -1x | +
- type = "numeric",+ #' contrast <- matrix(data = 0, nrow = 2, ncol = length(object$beta_est)) |
|
| 58 | -1x | +
- value = parsnip::pred_value_template(+ #' contrast[1, 2] <- contrast[2, 3] <- 1 |
|
| 59 |
- # This is boilerplate.+ #' df_md(object, contrast) |
||
| 60 | -1x | +
- func = c(fun = "predict"),+ df_md <- function(object, contrast) {
|
|
| 61 | -1x | +150x |
- object = quote(object$fit),+ assert_class(object, "mmrm") |
| 62 | -1x | +150x |
- newdata = quote(new_data)+ assert_numeric(contrast, any.missing = FALSE) |
| 63 | -+ | 150x |
- )+ if (!is.matrix(contrast)) {
|
| 64 | -+ | 113x |
- )+ contrast <- matrix(contrast, ncol = length(contrast)) |
| 65 |
-
+ } |
||
| 66 | -1x | +150x |
- parsnip::set_pred(+ assert_matrix(contrast, ncols = length(component(object, "beta_est"))) |
| 67 | -1x | +150x |
- model = "linear_reg",+ if (nrow(contrast) == 0) {
|
| 68 | 1x |
- eng = "mmrm",+ return( |
|
| 69 | 1x |
- mode = "regression",+ list( |
|
| 70 | -+ | 1x |
- # This type allows to pass arguments via `opts` to `parsnip::predict.model_fit`.+ num_df = 0, |
| 71 | 1x |
- type = "raw",+ denom_df = NA_real_, |
|
| 72 | 1x |
- value = parsnip::pred_value_template(+ f_stat = NA_real_, |
|
| 73 | -+ | 1x |
- # This is boilerplate.+ p_val = NA_real_ |
| 74 | -1x | +
- func = c(fun = "predict"),+ ) |
|
| 75 | -1x | +
- object = quote(object$fit),+ ) |
|
| 76 | -1x | +
- newdata = quote(new_data)+ } |
|
| 77 | -+ | 149x |
- # We don't specify additional argument defaults here since otherwise+ switch(object$method, |
| 78 | -+ | 145x |
- # the user is not able to change them (they will be fixed).+ "Satterthwaite" = h_df_md_sat(object, contrast), |
| 79 | -+ | 3x |
- )+ "Kenward-Roger" = h_df_md_kr(object, contrast), |
| 80 | -+ | ! |
- )+ "Residual" = h_df_md_res(object, contrast), |
| 81 | -+ | 1x |
-
+ "Between-Within" = h_df_md_bw(object, contrast), |
| 82 | -1x | +! |
- TRUE+ stop("Unrecognized degrees of freedom method: ", object$method)
|
| 83 |
- }+ ) |
| 1 | +84 |
- #' Support for `emmeans`+ } |
||
| 2 | +85 |
- #'+ |
||
| 3 | +86 |
- #' @description `r lifecycle::badge("experimental")`
+ #' Creating T-Statistic Test Results For One-Dimensional Contrast |
||
| 4 | +87 |
#' |
||
| 5 | -- |
- #' This package includes methods that allow `mmrm` objects to be used- |
- ||
| 6 | -- |
- #' with the `emmeans` package. `emmeans` computes estimated marginal means- |
- ||
| 7 | -- |
- #' (also called least-square means) for the coefficients of the MMRM.- |
- ||
| 8 | -- |
- #' We can also e.g. obtain differences between groups by applying- |
- ||
| 9 | +88 |
- #' [`pairs()`][emmeans::pairs.emmGrid()] on the object returned+ #' @description Creates a list of results for one-dimensional contrasts using |
||
| 10 | +89 |
- #' by [emmeans::emmeans()].+ #' a t-test statistic and the given degrees of freedom. |
||
| 11 | +90 |
#' |
||
| 12 | -- |
- #' @examples- |
- ||
| 13 | -- |
- #' fit <- mmrm(- |
- ||
| 14 | -- |
- #' formula = FEV1 ~ RACE + SEX + ARMCD * AVISIT + us(AVISIT | USUBJID),- |
- ||
| 15 | -- |
- #' data = fev_data- |
- ||
| 16 | -- |
- #' )- |
- ||
| 17 | -- |
- #' if (require(emmeans)) {
- |
- ||
| 18 | -- |
- #' emmeans(fit, ~ ARMCD | AVISIT)- |
- ||
| 19 | -- |
- #' pairs(emmeans(fit, ~ ARMCD | AVISIT), reverse = TRUE)- |
- ||
| 20 | -- |
- #' }- |
- ||
| 21 | +91 |
- #' @name emmeans_support+ #' @inheritParams df_1d |
||
| 22 | +92 |
- NULL+ #' @param df (`number`)\cr degrees of freedom for the one-dimensional contrast. |
||
| 23 | +93 |
-
+ #' |
||
| 24 | +94 |
- #' Returns a `data.frame` for `emmeans` Purposes+ #' @return List with `est`, `se`, `df`, `t_stat` and `p_val` (2-sided p-value). |
||
| 25 | +95 |
#' |
||
| 26 | +96 |
- #' @seealso See [emmeans::recover_data()] for background.+ #' @keywords internal |
||
| 27 | +97 |
- #' @keywords internal+ h_test_1d <- function(object, |
||
| 28 | +98 |
- #' @noRd+ contrast, |
||
| 29 | +99 |
- recover_data.mmrm <- function(object, ...) { # nolint
+ df) {
|
||
| 30 | -13x | +100 | +486x |
- fun_call <- stats::getCall(object)+ assert_class(object, "mmrm") |
| 31 | -+ | |||
| 101 | +486x |
- # subject_var is excluded because it should not contain fixed effect.+ assert_numeric(contrast, len = length(component(object, "beta_est"))) |
||
| 32 | -+ | |||
| 102 | +486x |
- # visit_var is not excluded because emmeans can provide marginal mean+ assert_number(df, lower = .Machine$double.xmin) |
||
| 33 | +103 |
- # by each visit if visit_var is not spatial.+ |
||
| 34 | -13x | +104 | +486x |
- model_frame <- stats::model.frame(+ est <- sum(contrast * component(object, "beta_est")) |
| 35 | -13x | +105 | +486x |
- object,+ var <- h_quad_form_vec(contrast, component(object, "beta_vcov")) |
| 36 | -13x | +106 | +486x |
- include = c(+ se <- sqrt(var) |
| 37 | -13x | +107 | +486x |
- if (!object$formula_parts$is_spatial) "visit_var" else NULL,+ t_stat <- est / se |
| 38 | -13x | -
- "response_var", "group_var"- |
- ||
| 39 | -+ | 108 | +486x |
- )+ p_val <- 2 * stats::pt(q = abs(t_stat), df = df, lower.tail = FALSE) |
| 40 | +109 |
- )- |
- ||
| 41 | -13x | -
- model_terms <- stats::delete.response(stats::terms(model_frame))+ |
||
| 42 | -13x | +110 | +486x |
- emmeans::recover_data(+ list( |
| 43 | -13x | +111 | +486x |
- fun_call,+ est = est, |
| 44 | -13x | +112 | +486x |
- trms = model_terms,+ se = se, |
| 45 | -13x | +113 | +486x |
- na.action = "na.omit",+ df = df, |
| 46 | -13x | +114 | +486x |
- frame = model_frame,+ t_stat = t_stat, |
| 47 | -+ | |||
| 115 | +486x |
- ...+ p_val = p_val |
||
| 48 | +116 |
) |
||
| 49 | +117 |
} |
||
| 50 | +118 | |||
| 51 | +119 |
- #' Returns a List of Model Details for `emmeans` Purposes+ #' Creating F-Statistic Test Results For Multi-Dimensional Contrast |
||
| 52 | +120 |
#' |
||
| 53 | +121 |
- #' @seealso See [emmeans::emm_basis()] for background.+ #' @description Creates a list of results for multi-dimensional contrasts using |
||
| 54 | +122 |
- #' @keywords internal+ #' an F-test statistic and the given degrees of freedom. |
||
| 55 | +123 |
- #' @noRd+ #' |
||
| 56 | +124 |
- emm_basis.mmrm <- function(object, # nolint+ #' @inheritParams df_md |
||
| 57 | +125 |
- trms,+ #' @param contrast (`matrix`)\cr numeric contrast matrix. |
||
| 58 | +126 |
- xlev,+ #' @param df (`number`)\cr denominator degrees of freedom for the multi-dimensional contrast. |
||
| 59 | +127 |
- grid,+ #' @param f_stat_factor (`number`)\cr optional scaling factor on top of the standard F-statistic. |
||
| 60 | +128 |
- ...) {
- |
- ||
| 61 | -13x | -
- model_frame <- stats::model.frame(trms, grid, na.action = stats::na.pass, xlev = xlev)- |
- ||
| 62 | -13x | -
- contrasts <- component(object, "contrasts")- |
- ||
| 63 | -13x | -
- model_mat <- stats::model.matrix(trms, model_frame, contrasts.arg = contrasts)+ #' |
||
| 64 | -13x | +|||
| 129 | +
- beta_hat <- component(object, "beta_est")+ #' @return List with `num_df`, `denom_df`, `f_stat` and `p_val` (2-sided p-value). |
|||
| 65 | -13x | +|||
| 130 | +
- nbasis <- if (length(beta_hat) < ncol(model_mat)) {
+ #' |
|||
| 66 | -6x | +|||
| 131 | +
- kept <- match(names(beta_hat), colnames(model_mat))+ #' @keywords internal |
|||
| 67 | -6x | +|||
| 132 | +
- beta_hat <- NA * model_mat[1L, ]+ h_test_md <- function(object, |
|||
| 68 | -6x | +|||
| 133 | +
- beta_hat[kept] <- component(object, "beta_est")+ contrast, |
|||
| 69 | -6x | +|||
| 134 | +
- orig_model_mat <- stats::model.matrix(+ df, |
|||
| 70 | -6x | +|||
| 135 | +
- trms,+ f_stat_factor = 1) {
|
|||
| 71 | -6x | +136 | +15x |
- stats::model.frame(+ assert_class(object, "mmrm") |
| 72 | -6x | +137 | +15x |
- object,+ assert_matrix(contrast, ncols = length(component(object, "beta_est"))) |
| 73 | -6x | +138 | +15x |
- include = c(+ num_df <- nrow(contrast) |
| 74 | -6x | +139 | +15x |
- if (!object$formula_parts$is_spatial) "visit_var" else NULL,+ assert_number(df, lower = .Machine$double.xmin) |
| 75 | -6x | -
- "response_var", "group_var"- |
- ||
| 76 | -+ | 140 | +15x |
- )+ assert_number(f_stat_factor, lower = .Machine$double.xmin) |
| 77 | +141 |
- ),+ |
||
| 78 | -6x | -
- contrasts.arg = contrasts- |
- ||
| 79 | -+ | 142 | +15x |
- )+ prec_contrast <- solve(h_quad_form_mat(contrast, component(object, "beta_vcov"))) |
| 80 | -6x | +143 | +15x |
- estimability::nonest.basis(orig_model_mat)+ contrast_est <- component(object, "beta_est") %*% t(contrast) |
| 81 | -+ | |||
| 144 | +15x |
- } else {
+ f_statistic <- as.numeric(f_stat_factor / num_df * h_quad_form_mat(contrast_est, prec_contrast)) |
||
| 82 | -7x | +145 | +15x |
- estimability::all.estble+ p_val <- stats::pf( |
| 83 | -+ | |||
| 146 | +15x |
- }+ q = f_statistic, |
||
| 84 | -13x | +147 | +15x |
- dfargs <- list(object = object)+ df1 = num_df, |
| 85 | -13x | +148 | +15x |
- dffun <- function(k, dfargs) {
+ df2 = df, |
| 86 | -113x | +149 | +15x |
- mmrm::df_md(dfargs$object, contrast = k)$denom_df+ lower.tail = FALSE |
| 87 | +150 |
- }- |
- ||
| 88 | -13x | -
- list(+ ) |
||
| 89 | -13x | +|||
| 151 | +
- X = model_mat,+ |
|||
| 90 | -13x | +152 | +15x |
- bhat = beta_hat,+ list( |
| 91 | -13x | +153 | +15x |
- nbasis = nbasis,+ num_df = num_df, |
| 92 | -13x | +154 | +15x |
- V = component(object, "beta_vcov"),+ denom_df = df, |
| 93 | -13x | +155 | +15x |
- dffun = dffun,+ f_stat = f_statistic, |
| 94 | -13x | +156 | +15x |
- dfargs = dfargs+ p_val = p_val |
| 95 | +157 |
) |
||
| 96 | +158 |
}@@ -35203,6 +35008,229 @@ mmrm coverage - 97.08% |
| 1 | ++ |
+ # Internal functions used for skipping tests or examples.+ |
+
| 2 | ++ | + + | +
| 3 | ++ |
+ # Predicate whether currently running R version is under development.+ |
+
| 4 | ++ |
+ is_r_devel <- function() {
+ |
+
| 5 | +21x | +
+ grepl("devel", R.version$status)
+ |
+
| 6 | ++ |
+ }+ |
+
| 7 | ++ | + + | +
| 8 | ++ |
+ # Predicate whether currently running on a Linux operating system.+ |
+
| 9 | ++ |
+ is_linux <- function() {
+ |
+
| 10 | +1x | +
+ tolower(Sys.info()[["sysname"]]) == "linux"+ |
+
| 11 | ++ |
+ }+ |
+
| 12 | ++ | + + | +
| 13 | ++ |
+ # Get the compiler information. Workaround for older R versions+ |
+
| 14 | ++ |
+ # where R_compiled_by() is not available.+ |
+
| 15 | ++ |
+ get_compiler <- function() {
+ |
+
| 16 | +3x | +
+ r_cmd <- file.path(R.home("bin"), "R")
+ |
+
| 17 | +3x | +
+ system2(r_cmd, args = "CMD config CC", stdout = TRUE)+ |
+
| 18 | ++ |
+ }+ |
+
| 19 | ++ | + + | +
| 20 | ++ |
+ # Predicate whether currently using a clang compiler.+ |
+
| 21 | ++ |
+ is_using_clang <- function() {
+ |
+
| 22 | +2x | +
+ grepl("clang", get_compiler())
+ |
+
| 23 | ++ |
+ }+ |
+
| 24 | ++ | + + | +
| 25 | ++ |
+ # Predicate whether an R-devel version is running on Linux Fedora or+ |
+
| 26 | ++ |
+ # Debian with a clang compiler.+ |
+
| 27 | ++ |
+ is_r_devel_linux_clang <- function() {
+ |
+
| 28 | +20x | +
+ is_r_devel() &&+ |
+
| 29 | +20x | +
+ is_linux() &&+ |
+
| 30 | +20x | +
+ is_using_clang()+ |
+
| 31 | ++ |
+ }+ |
+