| 1 |
- #' Capture all Output+ #' Calculation of Degrees of Freedom for One-Dimensional Contrast |
||
| 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+ #' Calculates the estimate, adjusted standard error, degrees of freedom, |
||
| 5 |
- #' and messages and divergence signals as character vectors.+ #' t statistic and p-value for one-dimensional contrast. |
||
| 7 |
- #' @param expr (`expression`)\cr to be executed.+ #' @param object (`mmrm`)\cr the MMRM fit. |
||
| 8 |
- #' @param remove (`list`)\cr optional list with elements `warnings`, `errors`,+ #' @param contrast (`numeric`)\cr contrast vector. Note that this should not include |
||
| 9 |
- #' `messages` which can be character vectors, which will be removed from the+ #' elements for singular coefficient estimates, i.e. only refer to the |
||
| 10 |
- #' results if specified.+ #' actually estimated coefficients. |
||
| 11 |
- #' @param divergence (`list`)\cr optional list similar as `remove`, but these+ #' @return List with `est`, `se`, `df`, `t_stat` and `p_val`. |
||
| 12 |
- #' character vectors will be moved to the `divergence` result and signal+ #' @export |
||
| 13 |
- #' that the fit did not converge.+ #' |
||
| 14 |
- #'+ #' @examples |
||
| 15 |
- #' @return+ #' object <- mmrm( |
||
| 16 |
- #' A list containing+ #' formula = FEV1 ~ RACE + SEX + ARMCD * AVISIT + us(AVISIT | USUBJID), |
||
| 17 |
- #'+ #' data = fev_data |
||
| 18 |
- #' - `result`: The object returned by `expr` or `list()` if an error was thrown.+ #' ) |
||
| 19 |
- #' - `warnings`: `NULL` or a character vector if warnings were thrown.+ #' contrast <- numeric(length(object$beta_est)) |
||
| 20 |
- #' - `errors`: `NULL` or a string if an error was thrown.+ #' contrast[3] <- 1 |
||
| 21 |
- #' - `messages`: `NULL` or a character vector if messages were produced.+ #' df_1d(object, contrast) |
||
| 22 |
- #' - `divergence`: `NULL` or a character vector if divergence messages were caught.+ df_1d <- function(object, contrast) {
|
||
| 23 | -+ | 338x |
- #'+ assert_class(object, "mmrm") |
| 24 | -+ | 338x |
- #' @keywords internal+ assert_numeric(contrast, len = length(component(object, "beta_est")), any.missing = FALSE) |
| 25 | -+ | 338x |
- h_record_all_output <- function(expr,+ contrast <- as.vector(contrast) |
| 26 | -+ | 338x |
- remove = list(),+ switch(object$method, |
| 27 | -+ | 318x |
- divergence = list()) {
+ "Satterthwaite" = h_df_1d_sat(object, contrast), |
| 28 | -+ | 19x |
- # Note: We don't need to and cannot assert `expr` here.+ "Kenward-Roger" = h_df_1d_kr(object, contrast), |
| 29 | -201x | +! |
- assert_list(remove, types = "character")+ "Residual" = h_df_1d_res(object, contrast), |
| 30 | -201x | +1x |
- assert_list(divergence, types = "character")+ "Between-Within" = h_df_1d_bw(object, contrast), |
| 31 | -201x | +! |
- env <- new.env()+ stop("Unrecognized degrees of freedom method: ", object$method)
|
| 32 | -201x | +
- result <- withCallingHandlers(+ ) |
|
| 33 | -201x | +
- withRestarts(+ } |
|
| 34 | -201x | +
- expr,+ |
|
| 35 | -201x | +
- muffleStop = function(e) structure(e$message, class = "try-error")+ |
|
| 36 |
- ),+ #' Calculation of Degrees of Freedom for Multi-Dimensional Contrast |
||
| 37 | -201x | +
- message = function(m) {
+ #' |
|
| 38 | -6x | +
- msg_without_newline <- gsub(m$message, pattern = "\n$", replacement = "")+ #' @description `r lifecycle::badge("stable")`
|
|
| 39 | -6x | +
- env$message <- c(env$message, msg_without_newline)+ #' Calculates the estimate, standard error, degrees of freedom, |
|
| 40 | -6x | +
- invokeRestart("muffleMessage")
+ #' t statistic and p-value for one-dimensional contrast, depending on the method |
|
| 41 |
- },+ #' used in [mmrm()]. |
||
| 42 | -201x | +
- warning = function(w) {
+ #' |
|
| 43 | -14x | +
- env$warning <- c(env$warning, w$message)+ #' @param object (`mmrm`)\cr the MMRM fit. |
|
| 44 | -14x | +
- invokeRestart("muffleWarning")
+ #' @param contrast (`matrix`)\cr numeric contrast matrix, if given a `numeric` |
|
| 45 |
- },+ #' then this is coerced to a row vector. Note that this should not include |
||
| 46 | -201x | +
- error = function(e) {
+ #' elements for singular coefficient estimates, i.e. only refer to the |
|
| 47 | -14x | +
- env$error <- c(env$error, e$message)+ #' actually estimated coefficients. |
|
| 48 | -14x | +
- invokeRestart("muffleStop", e)
+ #' |
|
| 49 |
- }+ #' @return List with `num_df`, `denom_df`, `f_stat` and `p_val` (2-sided p-value). |
||
| 50 |
- )+ #' @export |
||
| 51 | -201x | +
- list(+ #' |
|
| 52 | -201x | +
- result = result,+ #' @examples |
|
| 53 | -201x | +
- warnings = setdiff(env$warning, c(remove$warnings, divergence$warnings)),+ #' object <- mmrm( |
|
| 54 | -201x | +
- errors = setdiff(env$error, c(remove$errors, divergence$errors)),+ #' formula = FEV1 ~ RACE + SEX + ARMCD * AVISIT + us(AVISIT | USUBJID), |
|
| 55 | -201x | +
- messages = setdiff(env$message, c(remove$messages, divergence$messages)),+ #' data = fev_data |
|
| 56 | -201x | +
- divergence = c(+ #' ) |
|
| 57 | -201x | +
- intersect(env$warning, divergence$warnings),+ #' contrast <- matrix(data = 0, nrow = 2, ncol = length(object$beta_est)) |
|
| 58 | -201x | +
- intersect(env$error, divergence$errors),+ #' contrast[1, 2] <- contrast[2, 3] <- 1 |
|
| 59 | -201x | +
- intersect(env$message, divergence$messages)+ #' df_md(object, contrast) |
|
| 60 |
- )+ df_md <- function(object, contrast) {
|
||
| 61 | -+ | 150x |
- )+ assert_class(object, "mmrm") |
| 62 | -+ | 150x |
- }+ assert_numeric(contrast, any.missing = FALSE) |
| 63 | -+ | 150x |
-
+ if (!is.matrix(contrast)) {
|
| 64 | -+ | 113x |
- #' Trace of a Matrix+ contrast <- matrix(contrast, ncol = length(contrast)) |
| 65 |
- #'+ } |
||
| 66 | -+ | 150x |
- #' @description Obtain the trace of a matrix if the matrix is diagonal, otherwise raise an error.+ assert_matrix(contrast, ncols = length(component(object, "beta_est"))) |
| 67 | -+ | 150x |
- #'+ if (nrow(contrast) == 0) {
|
| 68 | -+ | 1x |
- #' @param x (`matrix`)\cr square matrix input.+ return( |
| 69 | -+ | 1x |
- #'+ list( |
| 70 | -+ | 1x |
- #' @return The trace of the square matrix.+ num_df = 0, |
| 71 | -+ | 1x |
- #'+ denom_df = NA_real_, |
| 72 | -+ | 1x |
- #' @keywords internal+ f_stat = NA_real_, |
| 73 | -+ | 1x |
- h_tr <- function(x) {
+ p_val = NA_real_ |
| 74 | -1790x | +
- if (nrow(x) != ncol(x)) {
+ ) |
|
| 75 | -1x | +
- stop("x must be square matrix")
+ ) |
|
| 77 | -1789x | +149x |
- sum(Matrix::diag(x))+ switch(object$method, |
| 78 | -+ | 145x |
- }+ "Satterthwaite" = h_df_md_sat(object, contrast), |
| 79 | -+ | 3x |
-
+ "Kenward-Roger" = h_df_md_kr(object, contrast), |
| 80 | -+ | ! |
- #' Split Control List+ "Residual" = h_df_md_res(object, contrast), |
| 81 | -+ | 1x |
- #'+ "Between-Within" = h_df_md_bw(object, contrast), |
| 82 | -+ | ! |
- #' @description Split the [mmrm_control()] object according to its optimizers and use additional arguments+ stop("Unrecognized degrees of freedom method: ", object$method)
|
| 83 |
- #' to replace the elements in the original object.+ ) |
||
| 84 |
- #'+ } |
||
| 85 |
- #' @param control (`mmrm_control`)\cr object.+ |
||
| 86 |
- #' @param ... additional parameters to update the `control` object.+ #' Creating T-Statistic Test Results For One-Dimensional Contrast |
||
| 88 |
- #' @return A `list` of `mmrm_control` entries.+ #' @description Creates a list of results for one-dimensional contrasts using |
||
| 89 |
- #' @keywords internal+ #' a t-test statistic and the given degrees of freedom. |
||
| 90 |
- h_split_control <- function(control, ...) {
+ #' |
||
| 91 | -8x | +
- assert_class(control, "mmrm_control")+ #' @inheritParams df_1d |
|
| 92 | -8x | +
- l <- length(control$optimizers)+ #' @param df (`number`)\cr degrees of freedom for the one-dimensional contrast. |
|
| 93 | -8x | +
- lapply(seq_len(l), function(i) {
+ #' |
|
| 94 | -22x | +
- ret <- utils::modifyList(control, list(...))+ #' @return List with `est`, `se`, `df`, `t_stat` and `p_val` (2-sided p-value). |
|
| 95 | -22x | +
- ret$optimizers <- control$optimizers[i]+ #' |
|
| 96 | -22x | +
- ret+ #' @keywords internal |
|
| 97 |
- })+ h_test_1d <- function(object, |
||
| 98 |
- }+ contrast, |
||
| 99 |
-
+ df) {
|
||
| 100 | -+ | 486x |
- #' Obtain Optimizer according to Optimizer String Value+ assert_class(object, "mmrm") |
| 101 | -+ | 486x |
- #'+ assert_numeric(contrast, len = length(component(object, "beta_est"))) |
| 102 | -+ | 486x |
- #' @description This function creates optimizer functions with arguments.+ assert_number(df, lower = .Machine$double.xmin) |
| 103 |
- #'+ |
||
| 104 | -+ | 486x |
- #' @param optimizer (`character`)\cr names of built-in optimizers to try, subset+ est <- sum(contrast * component(object, "beta_est")) |
| 105 | -+ | 486x |
- #' of "L-BFGS-B", "BFGS", "CG" and "nlminb".+ var <- h_quad_form_vec(contrast, component(object, "beta_vcov")) |
| 106 | -+ | 486x |
- #' @param optimizer_fun (`function` or `list` of `function`)\cr alternatively to `optimizer`,+ se <- sqrt(var) |
| 107 | -+ | 486x |
- #' an optimizer function or a list of optimizer functions can be passed directly here.+ t_stat <- est / se |
| 108 | -+ | 486x |
- #' @param optimizer_args (`list`)\cr additional arguments for `optimizer_fun`.+ p_val <- 2 * stats::pt(q = abs(t_stat), df = df, lower.tail = FALSE) |
| 109 |
- #' @param optimizer_control (`list`)\cr passed to argument `control` in `optimizer_fun`.+ |
||
| 110 | -+ | 486x |
- #'+ list( |
| 111 | -+ | 486x |
- #' @details+ est = est, |
| 112 | -+ | 486x |
- #' If you want to use only the built-in optimizers:+ se = se, |
| 113 | -+ | 486x |
- #' - `optimizer` is a shortcut to create a list of built-in optimizer functions+ df = df, |
| 114 | -+ | 486x |
- #' passed to `optimizer_fun`.+ t_stat = t_stat, |
| 115 | -+ | 486x |
- #' - Allowed are "L-BFGS-B", "BFGS", "CG" (using [stats::optim()] with corresponding method)+ p_val = p_val |
| 116 |
- #' and "nlminb" (using [stats::nlminb()]).+ ) |
||
| 117 |
- #' - Other arguments should go into `optimizer_args`.+ } |
||
| 118 |
- #'+ |
||
| 119 |
- #' If you want to use your own optimizer function:+ #' Creating F-Statistic Test Results For Multi-Dimensional Contrast |
||
| 120 |
- #' - Make sure that there are three arguments: parameter (start value), objective function+ #' |
||
| 121 |
- #' and gradient function are sequentially in the function arguments.+ #' @description Creates a list of results for multi-dimensional contrasts using |
||
| 122 |
- #' - If there are other named arguments in front of these, make sure they are correctly+ #' an F-test statistic and the given degrees of freedom. |
||
| 123 |
- #' specified through `optimizer_args`.+ #' |
||
| 124 |
- #' - If the hessian can be used, please make sure its argument name is `hessian` and+ #' @inheritParams df_md |
||
| 125 |
- #' please add attribute `use_hessian = TRUE` to the function,+ #' @param contrast (`matrix`)\cr numeric contrast matrix. |
||
| 126 |
- #' using `attr(fun, "use_hessian) <- TRUE`.+ #' @param df (`number`)\cr denominator degrees of freedom for the multi-dimensional contrast. |
||
| 127 |
- #'+ #' @param f_stat_factor (`number`)\cr optional scaling factor on top of the standard F-statistic. |
||
| 128 |
- #' @return Named `list` of optimizers created by [h_partial_fun_args()].+ #' |
||
| 129 |
- #'+ #' @return List with `num_df`, `denom_df`, `f_stat` and `p_val` (2-sided p-value). |
||
| 130 |
- #' @keywords internal+ #' |
||
| 131 |
- h_get_optimizers <- function(optimizer = c("L-BFGS-B", "BFGS", "CG", "nlminb"),
+ #' @keywords internal |
||
| 132 |
- optimizer_fun = h_optimizer_fun(optimizer),+ h_test_md <- function(object, |
||
| 133 |
- optimizer_args = list(),+ contrast, |
||
| 134 |
- optimizer_control = list()) {
+ df, |
||
| 135 | -246x | +
- if ("automatic" %in% optimizer) {
+ f_stat_factor = 1) {
|
|
| 136 | -1x | +15x |
- lifecycle::deprecate_warn(+ assert_class(object, "mmrm") |
| 137 | -1x | +15x |
- when = "0.2.0",+ assert_matrix(contrast, ncols = length(component(object, "beta_est"))) |
| 138 | -1x | +15x |
- what = I("\"automatic\" optimizer"),
+ num_df <- nrow(contrast) |
| 139 | -1x | +15x |
- details = "please just omit optimizer argument"+ assert_number(df, lower = .Machine$double.xmin) |
| 140 | -+ | 15x |
- )+ assert_number(f_stat_factor, lower = .Machine$double.xmin) |
| 141 | -1x | +
- optimizer_fun <- h_optimizer_fun()+ |
|
| 142 | -+ | 15x |
- }+ prec_contrast <- solve(h_quad_form_mat(contrast, component(object, "beta_vcov"))) |
| 143 | -246x | +15x |
- assert(+ contrast_est <- component(object, "beta_est") %*% t(contrast) |
| 144 | -246x | +15x |
- test_function(optimizer_fun),+ f_statistic <- as.numeric(f_stat_factor / num_df * h_quad_form_mat(contrast_est, prec_contrast)) |
| 145 | -246x | +15x |
- test_list(optimizer_fun, types = "function", names = "unique")+ p_val <- stats::pf( |
| 146 | -+ | 15x |
- )+ q = f_statistic, |
| 147 | -246x | +15x |
- if (is.function(optimizer_fun)) {
+ df1 = num_df, |
| 148 | -7x | +15x |
- optimizer_fun <- list(custom_optimizer = optimizer_fun)+ df2 = df, |
| 149 | -+ | 15x |
- }+ lower.tail = FALSE |
| 150 | -246x | +
- lapply(optimizer_fun, function(x) {
+ ) |
|
| 151 | -924x | +
- do.call(h_partial_fun_args, c(list(fun = x, control = optimizer_control), optimizer_args))+ |
|
| 152 | -+ | 15x |
- })+ list( |
| 153 | -+ | 15x |
- }+ num_df = num_df, |
| 154 | -+ | 15x |
-
+ denom_df = df, |
| 155 | -+ | 15x |
- #' Obtain Optimizer Function with Character+ f_stat = f_statistic, |
| 156 | -+ | 15x |
- #' @description Obtain the optimizer function through the character provided.+ p_val = p_val |
| 157 |
- #' @param optimizer (`character`)\cr vector of optimizers.+ ) |
||
| 158 |
- #'+ } |
| 159 | +1 |
- #' @return A (`list`)\cr of optimizer functions generated from [h_partial_fun_args()].+ #' Capture all Output |
||
| 160 | +2 |
- #' @keywords internal+ #' |
||
| 161 | +3 |
- h_optimizer_fun <- function(optimizer = c("L-BFGS-B", "BFGS", "CG", "nlminb")) {
- |
- ||
| 162 | -240x | -
- optimizer <- match.arg(optimizer, several.ok = TRUE)- |
- ||
| 163 | -240x | -
- lapply(stats::setNames(optimizer, optimizer), function(x) {
+ #' This function silences all warnings, errors & messages and instead returns a list |
||
| 164 | -920x | +|||
| 4 | +
- switch(x,+ #' containing the results (if it didn't error), as well as the warnings, errors |
|||
| 165 | -229x | +|||
| 5 | +
- "L-BFGS-B" = h_partial_fun_args(fun = stats::optim, method = x),+ #' and messages and divergence signals as character vectors. |
|||
| 166 | -230x | +|||
| 6 | +
- "BFGS" = h_partial_fun_args(fun = stats::optim, method = x),+ #' |
|||
| 167 | -228x | +|||
| 7 | +
- "CG" = h_partial_fun_args(fun = stats::optim, method = x),+ #' @param expr (`expression`)\cr to be executed. |
|||
| 168 | -233x | +|||
| 8 | +
- "nlminb" = h_partial_fun_args(fun = stats::nlminb, additional_attr = list(use_hessian = TRUE))+ #' @param remove (`list`)\cr optional list with elements `warnings`, `errors`, |
|||
| 169 | +9 |
- )+ #' `messages` which can be character vectors, which will be removed from the |
||
| 170 | +10 |
- })+ #' results if specified. |
||
| 171 | +11 |
- }+ #' @param divergence (`list`)\cr optional list similar as `remove`, but these |
||
| 172 | +12 |
-
+ #' character vectors will be moved to the `divergence` result and signal |
||
| 173 | +13 |
- #' Create Partial Functions+ #' that the fit did not converge. |
||
| 174 | +14 |
- #' @description Creates partial functions with arguments.+ #' |
||
| 175 | +15 |
- #'+ #' @return |
||
| 176 | +16 |
- #' @param fun (`function`)\cr to be wrapped.+ #' A list containing |
||
| 177 | +17 |
- #' @param ... Additional arguments for `fun`.+ #' |
||
| 178 | +18 |
- #' @param additional_attr (`list`)\cr of additional attributes to apply to the result.+ #' - `result`: The object returned by `expr` or `list()` if an error was thrown. |
||
| 179 | +19 |
- #'+ #' - `warnings`: `NULL` or a character vector if warnings were thrown. |
||
| 180 | +20 |
- #' @details This function add `args` attribute to the original function,+ #' - `errors`: `NULL` or a string if an error was thrown. |
||
| 181 | +21 |
- #' and add an extra class `partial` to the function.+ #' - `messages`: `NULL` or a character vector if messages were produced. |
||
| 182 | +22 |
- #' `args` is the argument for the function, and elements in `...` will override the existing+ #' - `divergence`: `NULL` or a character vector if divergence messages were caught. |
||
| 183 | +23 |
- #' arguments in attribute `args`. `additional_attr` will override the existing attributes.+ #' |
||
| 184 | +24 |
- #'+ #' @keywords internal |
||
| 185 | +25 |
- #' @return Object with S3 class `"partial"`, a `function` with `args` attribute (and possibly more+ h_record_all_output <- function(expr, |
||
| 186 | +26 |
- #' attributes from `additional_attr`).+ remove = list(), |
||
| 187 | +27 |
- #' @keywords internal+ divergence = list()) {
|
||
| 188 | +28 |
- h_partial_fun_args <- function(fun, ..., additional_attr = list()) {
+ # Note: We don't need to and cannot assert `expr` here. |
||
| 189 | -1848x | +29 | +201x |
- assert_function(fun)+ assert_list(remove, types = "character") |
| 190 | -1848x | +30 | +201x |
- assert_list(additional_attr, names = "unique")+ assert_list(divergence, types = "character") |
| 191 | -1848x | +31 | +201x |
- a_args <- list(...)+ env <- new.env() |
| 192 | -1848x | +32 | +201x |
- assert_list(a_args, names = "unique")+ result <- withCallingHandlers( |
| 193 | -1848x | +33 | +201x |
- args <- attr(fun, "args")+ withRestarts( |
| 194 | -1848x | +34 | +201x |
- if (is.null(args)) {
+ expr, |
| 195 | -932x | +35 | +201x |
- args <- list()+ muffleStop = function(e) structure(e$message, class = "try-error") |
| 196 | +36 |
- }+ ), |
||
| 197 | -1848x | +37 | +201x |
- do.call(+ message = function(m) {
|
| 198 | -1848x | +38 | +6x |
- structure,+ msg_without_newline <- gsub(m$message, pattern = "\n$", replacement = "") |
| 199 | -1848x | +39 | +6x |
- args = utils::modifyList(+ env$message <- c(env$message, msg_without_newline) |
| 200 | -1848x | +40 | +6x |
- list(+ invokeRestart("muffleMessage")
+ |
+
| 41 | ++ |
+ }, |
||
| 201 | -1848x | +42 | +201x |
- .Data = fun,+ warning = function(w) {
|
| 202 | -1848x | +43 | +14x |
- args = utils::modifyList(args, a_args),+ env$warning <- c(env$warning, w$message) |
| 203 | -1848x | +44 | +14x |
- class = c("partial", "function")
+ invokeRestart("muffleWarning")
|
| 204 | +45 |
- ),+ }, |
||
| 205 | -1848x | +46 | +201x |
- additional_attr+ error = function(e) {
|
| 206 | -+ | |||
| 47 | +14x |
- )+ env$error <- c(env$error, e$message) |
||
| 207 | -+ | |||
| 48 | +14x |
- )+ invokeRestart("muffleStop", e)
|
||
| 208 | +49 |
- }+ } |
||
| 209 | +50 |
-
+ ) |
||
| 210 | -+ | |||
| 51 | +201x |
- #' Obtain Default Covariance Method+ list( |
||
| 211 | -+ | |||
| 52 | +201x |
- #'+ result = result, |
||
| 212 | -+ | |||
| 53 | +201x |
- #' @description Obtain the default covariance method depending on+ warnings = setdiff(env$warning, c(remove$warnings, divergence$warnings)), |
||
| 213 | -+ | |||
| 54 | +201x |
- #' the degrees of freedom method used.+ errors = setdiff(env$error, c(remove$errors, divergence$errors)), |
||
| 214 | -+ | |||
| 55 | +201x |
- #'+ messages = setdiff(env$message, c(remove$messages, divergence$messages)), |
||
| 215 | -+ | |||
| 56 | +201x |
- #' @param method (`string`)\cr degrees of freedom method.+ divergence = c( |
||
| 216 | -+ | |||
| 57 | +201x |
- #'+ intersect(env$warning, divergence$warnings), |
||
| 217 | -+ | |||
| 58 | +201x |
- #' @details The default covariance method is different for different degrees of freedom method.+ intersect(env$error, divergence$errors), |
||
| 218 | -+ | |||
| 59 | +201x |
- #' For "Satterthwaite" or "Between-Within", "Asymptotic" is returned.+ intersect(env$message, divergence$messages) |
||
| 219 | +60 |
- #' For "Kenward-Roger" only, "Kenward-Roger" is returned.+ ) |
||
| 220 | +61 |
- #' For "Residual" only, "Empirical" is returned.+ ) |
||
| 221 | +62 | ++ |
+ }+ |
+ |
| 63 | ++ | + + | +||
| 64 | ++ |
+ #' Trace of a Matrix+ |
+ ||
| 65 |
#' |
|||
| 222 | +66 |
- #' @return String of the default covariance method.+ #' @description Obtain the trace of a matrix if the matrix is diagonal, otherwise raise an error. |
||
| 223 | +67 |
- #' @keywords internal+ #' |
||
| 224 | +68 |
- h_get_cov_default <- function(method = c("Satterthwaite", "Kenward-Roger", "Residual", "Between-Within")) {
+ #' @param x (`matrix`)\cr square matrix input. |
||
| 225 | -197x | +|||
| 69 | +
- assert_string(method)+ #' |
|||
| 226 | -197x | +|||
| 70 | +
- method <- match.arg(method)+ #' @return The trace of the square matrix. |
|||
| 227 | -196x | +|||
| 71 | +
- switch(method,+ #' |
|||
| 228 | -1x | +|||
| 72 | +
- "Residual" = "Empirical",+ #' @keywords internal |
|||
| 229 | -158x | +|||
| 73 | +
- "Satterthwaite" = "Asymptotic",+ h_tr <- function(x) {
|
|||
| 230 | -35x | +74 | +1790x |
- "Kenward-Roger" = "Kenward-Roger",+ if (nrow(x) != ncol(x)) {
|
| 231 | -2x | +75 | +1x |
- "Between-Within" = "Asymptotic"+ stop("x must be square matrix")
|
| 232 | +76 |
- )+ }+ |
+ ||
| 77 | +1789x | +
+ sum(Matrix::diag(x)) |
||
| 233 | +78 |
} |
||
| 234 | +79 | |||
| 235 | +80 |
- #' Complete `character` Vector Names From Values+ #' Split Control List |
||
| 236 | +81 |
#' |
||
| 237 | +82 |
- #' @param x (`character` or `list`)\cr value whose names should be completed+ #' @description Split the [mmrm_control()] object according to its optimizers and use additional arguments |
||
| 238 | +83 |
- #' from element values.+ #' to replace the elements in the original object. |
||
| 239 | +84 |
#' |
||
| 240 | +85 |
- #' @return A named vector or list.+ #' @param control (`mmrm_control`)\cr object. |
||
| 241 | +86 | ++ |
+ #' @param ... additional parameters to update the `control` object.+ |
+ |
| 87 |
#' |
|||
| 242 | +88 | ++ |
+ #' @return A `list` of `mmrm_control` entries.+ |
+ |
| 89 |
#' @keywords internal |
|||
| 243 | +90 |
- fill_names <- function(x) {
+ h_split_control <- function(control, ...) {
|
||
| 244 | -4x | +91 | +8x |
- n <- names(x)+ assert_class(control, "mmrm_control") |
| 245 | -4x | +92 | +8x |
- is_unnamed <- if (is.null(n)) rep_len(TRUE, length(x)) else n == ""+ l <- length(control$optimizers) |
| 246 | -4x | +93 | +8x |
- names(x)[is_unnamed] <- x[is_unnamed]+ lapply(seq_len(l), function(i) {
|
| 247 | -4x | +94 | +22x |
- x+ ret <- utils::modifyList(control, list(...))+ |
+
| 95 | +22x | +
+ ret$optimizers <- control$optimizers[i]+ |
+ ||
| 96 | +22x | +
+ ret |
||
| 248 | +97 | ++ |
+ })+ |
+ |
| 98 |
} |
|||
| 249 | +99 | |||
| 250 | +100 |
- #' Drop Items from an Indexible+ #' Obtain Optimizer according to Optimizer String Value |
||
| 251 | +101 |
#' |
||
| 252 | +102 |
- #' Drop elements from an indexible object (`vector`, `list`, etc.).+ #' @description This function creates optimizer functions with arguments. |
||
| 253 | +103 |
#' |
||
| 254 | +104 |
- #' @param x Any object that can be consumed by [seq_along()] and indexed by a+ #' @param optimizer (`character`)\cr names of built-in optimizers to try, subset |
||
| 255 | +105 |
- #' logical vector of the same length.+ #' of "L-BFGS-B", "BFGS", "CG" and "nlminb". |
||
| 256 | +106 |
- #' @param n (`integer`)\cr the number of terms to drop.+ #' @param optimizer_fun (`function` or `list` of `function`)\cr alternatively to `optimizer`, |
||
| 257 | +107 |
- #'+ #' an optimizer function or a list of optimizer functions can be passed directly here. |
||
| 258 | +108 |
- #' @return A subset of `x`.+ #' @param optimizer_args (`list`)\cr additional arguments for `optimizer_fun`. |
||
| 259 | +109 | ++ |
+ #' @param optimizer_control (`list`)\cr passed to argument `control` in `optimizer_fun`.+ |
+ |
| 110 |
#' |
|||
| 260 | +111 |
- #' @keywords internal+ #' @details |
||
| 261 | +112 |
- drop_elements <- function(x, n) {
+ #' If you want to use only the built-in optimizers: |
||
| 262 | -819x | +|||
| 113 | +
- x[seq_along(x) > n]+ #' - `optimizer` is a shortcut to create a list of built-in optimizer functions |
|||
| 263 | +114 |
- }+ #' passed to `optimizer_fun`. |
||
| 264 | +115 |
-
+ #' - Allowed are "L-BFGS-B", "BFGS", "CG" (using [stats::optim()] with corresponding method) |
||
| 265 | +116 |
- #' Ask for Confirmation on Large Visit Levels+ #' and "nlminb" (using [stats::nlminb()]). |
||
| 266 | +117 | ++ |
+ #' - Other arguments should go into `optimizer_args`.+ |
+ |
| 118 |
#' |
|||
| 267 | +119 |
- #' @description Ask the user for confirmation if there are too many visit levels+ #' If you want to use your own optimizer function: |
||
| 268 | +120 |
- #' for non-spatial covariance structure in interactive sessions.+ #' - Make sure that there are three arguments: parameter (start value), objective function |
||
| 269 | +121 |
- #'+ #' and gradient function are sequentially in the function arguments. |
||
| 270 | +122 |
- #' @param x (`numeric`)\cr number of visit levels.+ #' - If there are other named arguments in front of these, make sure they are correctly |
||
| 271 | +123 |
- #'+ #' specified through `optimizer_args`. |
||
| 272 | +124 |
- #' @return Logical value `TRUE`.+ #' - If the hessian can be used, please make sure its argument name is `hessian` and |
||
| 273 | +125 |
- #' @keywords internal+ #' please add attribute `use_hessian = TRUE` to the function, |
||
| 274 | +126 |
- h_confirm_large_levels <- function(x) {
+ #' using `attr(fun, "use_hessian) <- TRUE`. |
||
| 275 | -297x | +|||
| 127 | +
- assert_count(x)+ #' |
|||
| 276 | -297x | +|||
| 128 | +
- allowed_lvls <- x <= getOption("mmrm.max_visits", 100)
+ #' @return Named `list` of optimizers created by [h_partial_fun_args()]. |
|||
| 277 | -297x | +|||
| 129 | +
- if (allowed_lvls) {
+ #' |
|||
| 278 | -295x | +|||
| 130 | +
- return(TRUE)+ #' @keywords internal |
|||
| 279 | +131 |
- }+ h_get_optimizers <- function(optimizer = c("L-BFGS-B", "BFGS", "CG", "nlminb"),
|
||
| 280 | -2x | +|||
| 132 | +
- if (!interactive()) {
+ optimizer_fun = h_optimizer_fun(optimizer), |
|||
| 281 | -2x | +|||
| 133 | +
- stop("Visit levels too large!", call. = FALSE)
+ optimizer_args = list(), |
|||
| 282 | +134 |
- }+ optimizer_control = list()) {
|
||
| 283 | -! | +|||
| 135 | +246x |
- proceed <- utils::askYesNo(+ if ("automatic" %in% optimizer) {
|
||
| 284 | -! | +|||
| 136 | +1x |
- paste(+ lifecycle::deprecate_warn( |
||
| 285 | -! | +|||
| 137 | +1x |
- "Visit levels is possibly too large.",+ when = "0.2.0", |
||
| 286 | -! | +|||
| 138 | +1x |
- "This requires large memory. Are you sure to continue?",+ what = I("\"automatic\" optimizer"),
|
||
| 287 | -! | +|||
| 139 | +1x |
- collapse = " "+ details = "please just omit optimizer argument" |
||
| 288 | +140 |
) |
||
| 141 | +1x | +
+ optimizer_fun <- h_optimizer_fun()+ |
+ ||
| 289 | +142 |
- )+ } |
||
| 290 | -! | +|||
| 143 | +246x |
- if (!identical(proceed, TRUE)) {
+ assert( |
||
| 291 | -! | +|||
| 144 | +246x |
- stop("Visit levels too large!", call. = FALSE)
+ test_function(optimizer_fun),+ |
+ ||
| 145 | +246x | +
+ test_list(optimizer_fun, types = "function", names = "unique") |
||
| 292 | +146 |
- }+ ) |
||
| 293 | -! | +|||
| 147 | +246x |
- return(TRUE)+ if (is.function(optimizer_fun)) {
|
||
| 294 | -+ | |||
| 148 | +7x |
- }+ optimizer_fun <- list(custom_optimizer = optimizer_fun) |
||
| 295 | +149 |
-
+ }+ |
+ ||
| 150 | +246x | +
+ lapply(optimizer_fun, function(x) {
+ |
+ ||
| 151 | +924x | +
+ do.call(h_partial_fun_args, c(list(fun = x, control = optimizer_control), optimizer_args)) |
||
| 296 | +152 |
- #' Default Value on NULL+ }) |
||
| 297 | +153 |
- #' Return default value when first argument is NULL.+ } |
||
| 298 | +154 |
- #'+ |
||
| 299 | +155 |
- #' @param x Object.+ #' Obtain Optimizer Function with Character |
||
| 300 | +156 |
- #' @param y Object.+ #' @description Obtain the optimizer function through the character provided. |
||
| 301 | +157 |
- #'+ #' @param optimizer (`character`)\cr vector of optimizers. |
||
| 302 | +158 |
- #' @details If `x` is NULL, returns `y`. Otherwise return `x`.+ #' |
||
| 303 | +159 |
- #'+ #' @return A (`list`)\cr of optimizer functions generated from [h_partial_fun_args()]. |
||
| 304 | +160 |
#' @keywords internal |
||
| 305 | +161 |
- h_default_value <- function(x, y) {
+ h_optimizer_fun <- function(optimizer = c("L-BFGS-B", "BFGS", "CG", "nlminb")) {
|
||
| 306 | -312x | +162 | +240x |
- if (is.null(x)) {
+ optimizer <- match.arg(optimizer, several.ok = TRUE) |
| 307 | -277x | +163 | +240x |
- y+ lapply(stats::setNames(optimizer, optimizer), function(x) {
|
| 308 | -+ | |||
| 164 | +920x |
- } else {
+ switch(x, |
||
| 309 | -35x | +165 | +229x |
- x+ "L-BFGS-B" = h_partial_fun_args(fun = stats::optim, method = x), |
| 310 | -+ | |||
| 166 | +230x |
- }+ "BFGS" = h_partial_fun_args(fun = stats::optim, method = x), |
||
| 311 | -+ | |||
| 167 | +228x |
- }+ "CG" = h_partial_fun_args(fun = stats::optim, method = x), |
||
| 312 | -+ | |||
| 168 | +233x |
-
+ "nlminb" = h_partial_fun_args(fun = stats::nlminb, additional_attr = list(use_hessian = TRUE)) |
||
| 313 | +169 |
- #' Warn on na.action+ ) |
||
| 314 | +170 |
- #' @keywords internal+ }) |
||
| 315 | +171 |
- h_warn_na_action <- function() {
- |
- ||
| 316 | -260x | -
- if (!identical(getOption("na.action"), "na.omit")) {
- |
- ||
| 317 | -6x | -
- warning("na.action is always set to `na.omit` for `mmrm` fit!")
+ } |
||
| 318 | +172 |
- }+ |
||
| 319 | +173 |
- }+ #' Create Partial Functions |
||
| 320 | +174 |
-
+ #' @description Creates partial functions with arguments. |
||
| 321 | +175 |
- #' Obtain `na.action` as Function+ #' |
||
| 322 | +176 |
- #' @keywords internal+ #' @param fun (`function`)\cr to be wrapped. |
||
| 323 | +177 |
- h_get_na_action <- function(na_action) {
- |
- ||
| 324 | -56x | -
- if (is.function(na_action) && identical(methods::formalArgs(na_action), c("object", "..."))) {
- |
- ||
| 325 | -5x | -
- return(na_action)+ #' @param ... Additional arguments for `fun`. |
||
| 326 | +178 |
- }+ #' @param additional_attr (`list`)\cr of additional attributes to apply to the result. |
||
| 327 | -51x | +|||
| 179 | +
- if (is.character(na_action) && length(na_action) == 1L) {
+ #' |
|||
| 328 | -51x | +|||
| 180 | +
- assert_subset(na_action, c("na.omit", "na.exclude", "na.fail", "na.pass", "na.contiguous"))
+ #' @details This function add `args` attribute to the original function, |
|||
| 329 | -51x | +|||
| 181 | +
- return(get(na_action, mode = "function", pos = "package:stats"))+ #' and add an extra class `partial` to the function. |
|||
| 330 | +182 |
- }+ #' `args` is the argument for the function, and elements in `...` will override the existing |
||
| 331 | +183 |
- }+ #' arguments in attribute `args`. `additional_attr` will override the existing attributes. |
||
| 332 | +184 |
-
+ #' |
||
| 333 | +185 |
- #' Validate mmrm Formula+ #' @return Object with S3 class `"partial"`, a `function` with `args` attribute (and possibly more |
||
| 334 | +186 |
- #' @param formula (`formula`)\cr to check.+ #' attributes from `additional_attr`). |
||
| 335 | +187 |
- #'+ #' @keywords internal |
||
| 336 | +188 |
- #' @details In mmrm models, `.` is not allowed as it introduces ambiguity of covariates+ h_partial_fun_args <- function(fun, ..., additional_attr = list()) {
|
||
| 337 | -+ | |||
| 189 | +1848x |
- #' to be used, so it is not allowed to be in formula.+ assert_function(fun) |
||
| 338 | -+ | |||
| 190 | +1848x |
- #'+ assert_list(additional_attr, names = "unique") |
||
| 339 | -+ | |||
| 191 | +1848x |
- #' @keywords internal+ a_args <- list(...) |
||
| 340 | -+ | |||
| 192 | +1848x |
- h_valid_formula <- function(formula) {
+ assert_list(a_args, names = "unique") |
||
| 341 | -183x | +193 | +1848x |
- assert_formula(formula)+ args <- attr(fun, "args") |
| 342 | -183x | +194 | +1848x |
- if ("." %in% all.vars(formula)) {
+ if (is.null(args)) {
|
| 343 | -2x | +195 | +932x |
- stop("`.` is not allowed in mmrm models!")
+ args <- list() |
| 344 | +196 |
} |
||
| 345 | -+ | |||
| 197 | +1848x |
- }+ do.call( |
||
| 346 | -+ | |||
| 198 | +1848x |
-
+ structure, |
||
| 347 | -+ | |||
| 199 | +1848x |
- #' Standard Starting Value+ args = utils::modifyList( |
||
| 348 | -+ | |||
| 200 | +1848x |
- #'+ list( |
||
| 349 | -+ | |||
| 201 | +1848x |
- #' @description Obtain standard start values.+ .Data = fun, |
||
| 350 | -+ | |||
| 202 | +1848x |
- #'+ args = utils::modifyList(args, a_args), |
||
| 351 | -+ | |||
| 203 | +1848x |
- #' @param cov_type (`string`)\cr name of the covariance structure.+ class = c("partial", "function")
|
||
| 352 | +204 |
- #' @param n_visits (`int`)\cr number of visits.+ ),+ |
+ ||
| 205 | +1848x | +
+ additional_attr |
||
| 353 | +206 |
- #' @param n_groups (`int`)\cr number of groups.+ ) |
||
| 354 | +207 |
- #' @param ... not used.+ ) |
||
| 355 | +208 |
- #'+ } |
||
| 356 | +209 |
- #' @details+ |
||
| 357 | +210 |
- #' `std_start` will try to provide variance parameter from identity matrix.+ #' Obtain Default Covariance Method |
||
| 358 | +211 |
- #' However, for `ar1` and `ar1h` the corresponding values are not ideal because the+ #' |
||
| 359 | +212 |
- #' \eqn{\rho} is usually a positive number thus using 0 as starting value can lead to
+ #' @description Obtain the default covariance method depending on |
||
| 360 | +213 |
- #' incorrect optimization result, and we use 0.5 as the initial value of \eqn{\rho}.
+ #' the degrees of freedom method used. |
||
| 361 | +214 |
#' |
||
| 362 | +215 |
- #' @return A numeric vector of starting values.+ #' @param method (`string`)\cr degrees of freedom method. |
||
| 363 | +216 |
#' |
||
| 364 | +217 |
- #' @export+ #' @details The default covariance method is different for different degrees of freedom method. |
||
| 365 | +218 |
- std_start <- function(cov_type, n_visits, n_groups, ...) {
- |
- ||
| 366 | -502x | -
- assert_string(cov_type)- |
- ||
| 367 | -502x | -
- assert_subset(cov_type, cov_types(c("abbr", "habbr")))
+ #' For "Satterthwaite" or "Between-Within", "Asymptotic" is returned. |
||
| 368 | -502x | +|||
| 219 | +
- assert_int(n_visits, lower = 1L)+ #' For "Kenward-Roger" only, "Kenward-Roger" is returned. |
|||
| 369 | -502x | +|||
| 220 | +
- assert_int(n_groups, lower = 1L)+ #' For "Residual" only, "Empirical" is returned. |
|||
| 370 | -502x | +|||
| 221 | +
- start_value <- switch(cov_type,+ #' |
|||
| 371 | -502x | +|||
| 222 | +
- us = rep(0, n_visits * (n_visits + 1) / 2),+ #' @return String of the default covariance method. |
|||
| 372 | -502x | +|||
| 223 | +
- toep = rep(0, n_visits),+ #' @keywords internal |
|||
| 373 | -502x | +|||
| 224 | +
- toeph = rep(0, 2 * n_visits - 1),+ h_get_cov_default <- function(method = c("Satterthwaite", "Kenward-Roger", "Residual", "Between-Within")) {
|
|||
| 374 | -502x | +225 | +197x |
- ar1 = c(0, 0.5),+ assert_string(method) |
| 375 | -502x | +226 | +197x |
- ar1h = c(rep(0, n_visits), 0.5),+ method <- match.arg(method) |
| 376 | -502x | +227 | +196x |
- ad = rep(0, n_visits),+ switch(method, |
| 377 | -502x | +228 | +1x |
- adh = rep(0, 2 * n_visits - 1),+ "Residual" = "Empirical", |
| 378 | -502x | +229 | +158x |
- cs = rep(0, 2),+ "Satterthwaite" = "Asymptotic", |
| 379 | -502x | +230 | +35x |
- csh = rep(0, n_visits + 1),+ "Kenward-Roger" = "Kenward-Roger", |
| 380 | -502x | +231 | +2x |
- sp_exp = rep(0, 2)+ "Between-Within" = "Asymptotic" |
| 381 | +232 |
) |
||
| 382 | -502x | -
- rep(start_value, n_groups)- |
- ||
| 383 | +233 |
} |
||
| 384 | +234 | |||
| 385 | +235 |
- #' Empirical Starting Value+ #' Complete `character` Vector Names From Values |
||
| 386 | +236 |
#' |
||
| 387 | +237 |
- #' @description Obtain empirical start value for unstructured covariance+ #' @param x (`character` or `list`)\cr value whose names should be completed |
||
| 388 | +238 |
- #'+ #' from element values. |
||
| 389 | +239 |
- #' @param data (`data.frame`)\cr data used for model fitting.+ #' |
||
| 390 | +240 |
- #' @param model_formula (`formula`)\cr the formula in mmrm model without covariance structure part.+ #' @return A named vector or list. |
||
| 391 | +241 |
- #' @param visit_var (`string`)\cr visit variable.+ #' |
||
| 392 | +242 |
- #' @param subject_var (`string`)\cr subject id variable.+ #' @keywords internal |
||
| 393 | +243 |
- #' @param subject_groups (`factor`)\cr subject group assignment.+ fill_names <- function(x) {
|
||
| 394 | -+ | |||
| 244 | +4x |
- #' @param ... not used.+ n <- names(x) |
||
| 395 | -+ | |||
| 245 | +4x |
- #'+ is_unnamed <- if (is.null(n)) rep_len(TRUE, length(x)) else n == "" |
||
| 396 | -+ | |||
| 246 | +4x |
- #' @details+ names(x)[is_unnamed] <- x[is_unnamed]+ |
+ ||
| 247 | +4x | +
+ x |
||
| 397 | +248 |
- #' This `emp_start` only works for unstructured covariance structure.+ } |
||
| 398 | +249 |
- #' It uses linear regression to first obtain the coefficients and use the residuals+ |
||
| 399 | +250 |
- #' to obtain the empirical variance-covariance, and it is then used to obtain the+ #' Drop Items from an Indexible |
||
| 400 | +251 |
- #' starting values.+ #' |
||
| 401 | +252 | ++ |
+ #' Drop elements from an indexible object (`vector`, `list`, etc.).+ |
+ |
| 253 |
#' |
|||
| 402 | +254 |
- #' @note `data` is used instead of `full_frame` because `full_frame` is already+ #' @param x Any object that can be consumed by [seq_along()] and indexed by a |
||
| 403 | +255 |
- #' transformed if model contains transformations, e.g. `log(FEV1) ~ exp(FEV1_BL)` will+ #' logical vector of the same length. |
||
| 404 | +256 |
- #' drop `FEV1` and `FEV1_BL` but add `log(FEV1)` and `exp(FEV1_BL)` in `full_frame`.+ #' @param n (`integer`)\cr the number of terms to drop. |
||
| 405 | +257 |
#' |
||
| 406 | +258 |
- #' @return A numeric vector of starting values.+ #' @return A subset of `x`. |
||
| 407 | +259 |
#' |
||
| 408 | +260 |
- #' @export+ #' @keywords internal |
||
| 409 | +261 |
- emp_start <- function(data, model_formula, visit_var, subject_var, subject_groups, ...) {
+ drop_elements <- function(x, n) {
|
||
| 410 | -4x | +262 | +819x |
- assert_formula(model_formula)+ x[seq_along(x) > n] |
| 411 | -4x | +|||
| 263 | +
- assert_data_frame(data)+ } |
|||
| 412 | -4x | +|||
| 264 | +
- assert_subset(all.vars(model_formula), colnames(data))+ |
|||
| 413 | -4x | +|||
| 265 | +
- assert_string(visit_var)+ #' Ask for Confirmation on Large Visit Levels |
|||
| 414 | -4x | +|||
| 266 | +
- assert_string(subject_var)+ #' |
|||
| 415 | -4x | +|||
| 267 | +
- assert_factor(data[[visit_var]])+ #' @description Ask the user for confirmation if there are too many visit levels |
|||
| 416 | -4x | +|||
| 268 | +
- n_visits <- length(levels(data[[visit_var]]))+ #' for non-spatial covariance structure in interactive sessions. |
|||
| 417 | -4x | +|||
| 269 | +
- assert_factor(data[[subject_var]])+ #' |
|||
| 418 | -4x | +|||
| 270 | +
- subjects <- droplevels(data[[subject_var]])+ #' @param x (`numeric`)\cr number of visit levels. |
|||
| 419 | -4x | +|||
| 271 | +
- n_subjects <- length(levels(subjects))+ #' |
|||
| 420 | -4x | +|||
| 272 | +
- fit <- stats::lm(formula = model_formula, data = data)+ #' @return Logical value `TRUE`. |
|||
| 421 | -4x | +|||
| 273 | +
- res <- rep(NA, n_subjects * n_visits)+ #' @keywords internal |
|||
| 422 | -4x | +|||
| 274 | +
- res[+ h_confirm_large_levels <- function(x) {
|
|||
| 423 | -4x | +275 | +297x |
- n_visits * as.integer(subjects) - n_visits + as.integer(data[[visit_var]])+ assert_count(x) |
| 424 | -4x | +276 | +297x |
- ] <- residuals(fit)+ allowed_lvls <- x <= getOption("mmrm.max_visits", 100)
|
| 425 | -4x | +277 | +297x |
- res_mat <- matrix(res, ncol = n_visits, nrow = n_subjects, byrow = TRUE)+ if (allowed_lvls) {
|
| 426 | -4x | +278 | +295x |
- emp_covs <- lapply(+ return(TRUE) |
| 427 | -4x | +|||
| 279 | +
- unname(split(seq_len(n_subjects), subject_groups)),+ } |
|||
| 428 | -4x | +280 | +2x |
- function(x) {
+ if (!interactive()) {
|
| 429 | -4x | +281 | +2x |
- stats::cov(res_mat[x, , drop = FALSE], use = "pairwise.complete.obs")+ stop("Visit levels too large!", call. = FALSE)
|
| 430 | +282 |
- }+ } |
||
| 431 | -+ | |||
| 283 | +! |
- )+ proceed <- utils::askYesNo( |
||
| 432 | -4x | +|||
| 284 | +! |
- unlist(lapply(emp_covs, h_get_theta_from_cov))+ paste( |
||
| 433 | -+ | |||
| 285 | +! |
- }+ "Visit levels is possibly too large.", |
||
| 434 | -+ | |||
| 286 | +! |
- #' Obtain Theta from Covariance Matrix+ "This requires large memory. Are you sure to continue?", |
||
| 435 | -+ | |||
| 287 | +! |
- #'+ collapse = " " |
||
| 436 | +288 |
- #' @description Obtain unstructured theta from covariance matrix.+ ) |
||
| 437 | +289 |
- #'+ ) |
||
| 438 | -+ | |||
| 290 | +! |
- #' @param covariance (`matrix`) of covariance matrix values.+ if (!identical(proceed, TRUE)) {
|
||
| 439 | -+ | |||
| 291 | +! |
- #'+ stop("Visit levels too large!", call. = FALSE)
|
||
| 440 | +292 |
- #' @details+ } |
||
| 441 | -+ | |||
| 293 | +! |
- #' If the covariance matrix has `NA` in some of the elements, they will be replaced by+ return(TRUE) |
||
| 442 | +294 |
- #' 0 (non-diagonal) and 1 (diagonal). This ensures that the matrix is positive definite.+ } |
||
| 443 | +295 |
- #'+ |
||
| 444 | +296 |
- #' @return Numeric vector of the theta values.+ #' Default Value on NULL |
||
| 445 | +297 |
- #' @keywords internal+ #' Return default value when first argument is NULL. |
||
| 446 | +298 |
- h_get_theta_from_cov <- function(covariance) {
- |
- ||
| 447 | -7x | -
- assert_matrix(covariance, mode = "numeric", ncols = nrow(covariance))+ #' |
||
| 448 | -7x | +|||
| 299 | +
- covariance[is.na(covariance)] <- 0+ #' @param x Object. |
|||
| 449 | -7x | +|||
| 300 | +
- diag(covariance)[diag(covariance) == 0] <- 1+ #' @param y Object. |
|||
| 450 | +301 |
- # empirical is not always positive definite in some special cases of numeric singularity.+ #' |
||
| 451 | -7x | +|||
| 302 | +
- qr_res <- qr(covariance)+ #' @details If `x` is NULL, returns `y`. Otherwise return `x`. |
|||
| 452 | -7x | +|||
| 303 | +
- if (qr_res$rank < ncol(covariance)) {
+ #' |
|||
| 453 | -! | +|||
| 304 | +
- covariance <- Matrix::nearPD(covariance)$mat+ #' @keywords internal |
|||
| 454 | +305 |
- }+ h_default_value <- function(x, y) {
|
||
| 455 | -7x | +306 | +312x |
- emp_chol <- t(chol(covariance))+ if (is.null(x)) {
|
| 456 | -7x | +307 | +277x |
- mat <- t(solve(diag(diag(emp_chol)), emp_chol))+ y |
| 457 | -7x | +|||
| 308 | +
- ret <- c(log(diag(emp_chol)), mat[upper.tri(mat)])+ } else {
|
|||
| 458 | -7x | +309 | +35x |
- unname(ret)+ x |
| 459 | +310 |
- }+ } |
||
| 460 | +311 |
-
+ } |
||
| 461 | +312 |
- #' Register S3 Method+ |
||
| 462 | +313 |
- #' Register S3 method to a generic.+ #' Warn on na.action |
||
| 463 | +314 |
- #'+ #' @keywords internal |
||
| 464 | +315 |
- #' @param pkg (`string`) name of the package name.+ h_warn_na_action <- function() {
|
||
| 465 | -+ | |||
| 316 | +260x |
- #' @param generic (`string`) name of the generic.+ if (!identical(getOption("na.action"), "na.omit")) {
|
||
| 466 | -+ | |||
| 317 | +6x |
- #' @param class (`string`) class name the function want to dispatch.+ warning("na.action is always set to `na.omit` for `mmrm` fit!")
|
||
| 467 | +318 |
- #' @param envir (`environment`) the location the method is defined.+ } |
||
| 468 | +319 |
- #'+ } |
||
| 469 | +320 |
- #' @details This function is adapted from `emmeans:::register_s3_method()`.+ |
||
| 470 | +321 |
- #'+ #' Obtain `na.action` as Function |
||
| 471 | +322 |
#' @keywords internal |
||
| 472 | +323 |
- h_register_s3 <- function(pkg, generic, class, envir = parent.frame()) {
- |
- ||
| 473 | -1x | -
- assert_string(pkg)+ h_get_na_action <- function(na_action) {
|
||
| 474 | -1x | +324 | +56x |
- assert_string(generic)+ if (is.function(na_action) && identical(methods::formalArgs(na_action), c("object", "..."))) {
|
| 475 | -1x | +325 | +5x |
- assert_string(class)+ return(na_action) |
| 476 | -1x | +|||
| 326 | +
- assert_environment(envir)+ } |
|||
| 477 | -1x | +327 | +51x |
- fun <- get(paste0(generic, ".", class), envir = envir)+ if (is.character(na_action) && length(na_action) == 1L) {
|
| 478 | -1x | +328 | +51x |
- if (isNamespaceLoaded(pkg)) {
+ assert_subset(na_action, c("na.omit", "na.exclude", "na.fail", "na.pass", "na.contiguous"))
|
| 479 | -1x | +329 | +51x |
- registerS3method(generic, class, fun, envir = asNamespace(pkg))+ return(get(na_action, mode = "function", pos = "package:stats")) |
| 480 | +330 |
} |
||
| 481 | -1x | +|||
| 331 | +
- setHook(packageEvent(pkg, "onLoad"), function(...) {
+ } |
|||
| 482 | -! | +|||
| 332 | +
- registerS3method(generic, class, fun, envir = asNamespace(pkg))+ |
|||
| 483 | -- |
- })- |
- ||
| 484 | +333 |
- }+ #' Validate mmrm Formula |
||
| 485 | +334 |
-
+ #' @param formula (`formula`)\cr to check. |
||
| 486 | +335 |
- #' Check if a Factor Should Drop Levels+ #' |
||
| 487 | +336 |
- #'+ #' @details In mmrm models, `.` is not allowed as it introduces ambiguity of covariates |
||
| 488 | +337 |
- #' @param x (`vector`) vector to check.+ #' to be used, so it is not allowed to be in formula. |
||
| 489 | +338 |
#' |
||
| 490 | +339 |
#' @keywords internal |
||
| 491 | +340 |
- h_extra_levels <- function(x) {
+ h_valid_formula <- function(formula) {
|
||
| 492 | -1629x | +341 | +183x |
- is.factor(x) && length(levels(x)) > length(unique(x))+ assert_formula(formula) |
| 493 | -+ | |||
| 342 | +183x |
- }+ if ("." %in% all.vars(formula)) {
|
||
| 494 | -+ | |||
| 343 | +2x |
-
+ stop("`.` is not allowed in mmrm models!")
|
||
| 495 | +344 |
- #' Drop Levels from Dataset+ } |
||
| 496 | +345 |
- #' @param data (`data.frame`) data to drop levels.+ } |
||
| 497 | +346 |
- #' @param subject_var (`character`) subject variable.+ |
||
| 498 | +347 |
- #' @param visit_var (`character`) visit variable.+ #' Standard Starting Value |
||
| 499 | +348 |
- #' @param except (`character`) variables to exclude from dropping.+ #' |
||
| 500 | +349 |
- #' @keywords internal+ #' @description Obtain standard start values. |
||
| 501 | +350 |
- h_drop_levels <- function(data, subject_var, visit_var, except) {
- |
- ||
| 502 | -263x | -
- assert_data_frame(data)- |
- ||
| 503 | -263x | -
- assert_character(subject_var)- |
- ||
| 504 | -263x | -
- assert_character(visit_var)- |
- ||
| 505 | -263x | -
- assert_character(except, null.ok = TRUE)- |
- ||
| 506 | -263x | -
- all_cols <- colnames(data)- |
- ||
| 507 | -263x | -
- to_drop <- vapply(- |
- ||
| 508 | -263x | -
- data,- |
- ||
| 509 | -263x | -
- h_extra_levels,- |
- ||
| 510 | -263x | -
- logical(1L)+ #' |
||
| 511 | +351 |
- )- |
- ||
| 512 | -263x | -
- to_drop <- all_cols[to_drop]+ #' @param cov_type (`string`)\cr name of the covariance structure. |
||
| 513 | +352 |
- # only drop levels for those not defined in excep and not in visit_var.- |
- ||
| 514 | -263x | -
- to_drop <- setdiff(to_drop, c(visit_var, except))- |
- ||
| 515 | -263x | -
- data[to_drop] <- lapply(data[to_drop], droplevels)+ #' @param n_visits (`int`)\cr number of visits. |
||
| 516 | +353 |
- # subject var are always dropped and no message given.- |
- ||
| 517 | -263x | -
- dropped <- setdiff(to_drop, subject_var)- |
- ||
| 518 | -263x | -
- if (length(dropped) > 0) {
- |
- ||
| 519 | -3x | -
- message(- |
- ||
| 520 | -3x | -
- "Some factor levels are dropped due to singular design matrix: ",- |
- ||
| 521 | -3x | -
- toString(dropped)+ #' @param n_groups (`int`)\cr number of groups. |
||
| 522 | +354 |
- )+ #' @param ... not used. |
||
| 523 | +355 |
- }- |
- ||
| 524 | -263x | -
- data+ #' |
||
| 525 | +356 |
- }+ #' @details |
||
| 526 | +357 |
-
+ #' `std_start` will try to provide variance parameter from identity matrix. |
||
| 527 | +358 |
- #' Warn if TMB is Configured to Use Non-Deterministic Hash for Tape Optimizer+ #' However, for `ar1` and `ar1h` the corresponding values are not ideal because the |
||
| 528 | +359 |
- #'+ #' \eqn{\rho} is usually a positive number thus using 0 as starting value can lead to
|
||
| 529 | +360 |
- #' This function checks the TMB configuration for the `tmbad_deterministic_hash` setting+ #' incorrect optimization result, and we use 0.5 as the initial value of \eqn{\rho}.
|
||
| 530 | +361 |
- #' If it is set to `FALSE`, a warning is issued indicating that this may lead to+ #' |
||
| 531 | +362 |
- #' unreproducible results.+ #' @return A numeric vector of starting values. |
||
| 532 | +363 |
#' |
||
| 533 | +364 |
- #' @return No return value, called for side effects.+ #' @export |
||
| 534 | +365 |
- #' @keywords internal+ std_start <- function(cov_type, n_visits, n_groups, ...) {
|
||
| 535 | -+ | |||
| 366 | +502x |
- h_tmb_warn_non_deterministic <- function() {
+ assert_string(cov_type) |
||
| 536 | -169x | +367 | +502x |
- if (utils::packageVersion("TMB") < "1.9.15") {
+ assert_subset(cov_type, cov_types(c("abbr", "habbr")))
|
| 537 | -! | +|||
| 368 | +502x |
- return()+ assert_int(n_visits, lower = 1L) |
||
| 538 | -+ | |||
| 369 | +502x |
- }+ assert_int(n_groups, lower = 1L) |
||
| 539 | -169x | +370 | +502x |
- tmb_config <- TMB::config(DLL = "mmrm")+ start_value <- switch(cov_type, |
| 540 | -169x | +371 | +502x |
- tape_deterministic <- tmb_config$tmbad_deterministic_hash+ us = rep(0, n_visits * (n_visits + 1) / 2), |
| 541 | -169x | +372 | +502x |
- if (!tape_deterministic) {
+ toep = rep(0, n_visits), |
| 542 | -2x | +373 | +502x |
- msg <- paste(+ toeph = rep(0, 2 * n_visits - 1), |
| 543 | -2x | +374 | +502x |
- "TMB is configured to use a non-deterministic hash for its tape optimizer,",+ ar1 = c(0, 0.5), |
| 544 | -2x | +375 | +502x |
- "and this may lead to unreproducible results.",+ ar1h = c(rep(0, n_visits), 0.5), |
| 545 | -2x | +376 | +502x |
- "To disable this behavior, use `TMB::config(tmbad_deterministic_hash = 1)`.",+ ad = rep(0, n_visits), |
| 546 | -2x | +377 | +502x |
- sep = "\n"+ adh = rep(0, 2 * n_visits - 1), |
| 547 | -+ | |||
| 378 | +502x |
- )+ cs = rep(0, 2), |
||
| 548 | -2x | +379 | +502x |
- warning(msg)+ csh = rep(0, n_visits + 1), |
| 549 | -+ | |||
| 380 | +502x |
- }+ sp_exp = rep(0, 2) |
||
| 550 | +381 |
- }+ ) |
| 1 | -+ | |||
| 382 | +502x |
- #' Extract Formula Terms used for Covariance Structure Definition+ rep(start_value, n_groups) |
||
| 2 | +383 |
- #'+ } |
||
| 3 | +384 |
- #' @param f (`formula`)\cr a formula from which covariance terms should be+ |
||
| 4 | +385 |
- #' extracted.+ #' Empirical Starting Value |
||
| 5 | +386 |
#' |
||
| 6 | +387 |
- #' @return A list of covariance structure expressions found in `f`.+ #' @description Obtain empirical start value for unstructured covariance |
||
| 7 | +388 |
#' |
||
| 8 | +389 |
- #' @importFrom stats terms+ #' @param data (`data.frame`)\cr data used for model fitting. |
||
| 9 | +390 |
- #' @keywords internal+ #' @param model_formula (`formula`)\cr the formula in mmrm model without covariance structure part. |
||
| 10 | +391 |
- h_extract_covariance_terms <- function(f) {
+ #' @param visit_var (`string`)\cr visit variable. |
||
| 11 | -291x | +|||
| 392 | +
- specials <- cov_types(c("abbr", "habbr"))
+ #' @param subject_var (`string`)\cr subject id variable. |
|||
| 12 | -291x | +|||
| 393 | +
- terms <- stats::terms(formula_rhs(f), specials = specials)+ #' @param subject_groups (`factor`)\cr subject group assignment. |
|||
| 13 | -291x | +|||
| 394 | +
- covariance_terms <- Filter(length, attr(terms, "specials"))+ #' @param ... not used. |
|||
| 14 | -291x | +|||
| 395 | +
- variables <- attr(terms, "variables")+ #' |
|||
| 15 | -291x | +|||
| 396 | +
- lapply(covariance_terms, function(i) variables[[i + 1]])+ #' @details |
|||
| 16 | +397 |
- }+ #' This `emp_start` only works for unstructured covariance structure. |
||
| 17 | +398 |
-
+ #' It uses linear regression to first obtain the coefficients and use the residuals |
||
| 18 | +399 |
- #' Drop Formula Terms used for Covariance Structure Definition+ #' to obtain the empirical variance-covariance, and it is then used to obtain the |
||
| 19 | +400 |
- #'+ #' starting values. |
||
| 20 | +401 |
- #' @param f (`formula`)\cr a formula from which covariance terms should be+ #' |
||
| 21 | +402 |
- #' dropped.+ #' @note `data` is used instead of `full_frame` because `full_frame` is already |
||
| 22 | +403 |
- #'+ #' transformed if model contains transformations, e.g. `log(FEV1) ~ exp(FEV1_BL)` will |
||
| 23 | +404 |
- #' @return The formula without accepted covariance terms.+ #' drop `FEV1` and `FEV1_BL` but add `log(FEV1)` and `exp(FEV1_BL)` in `full_frame`. |
||
| 24 | +405 |
#' |
||
| 25 | +406 |
- #' @details `terms` is used and it will preserve the environment attribute.+ #' @return A numeric vector of starting values. |
||
| 26 | +407 |
- #' This ensures the returned formula and the input formula have the same environment.+ #' |
||
| 27 | +408 |
- #' @importFrom stats terms drop.terms+ #' @export |
||
| 28 | +409 |
- #' @keywords internal+ emp_start <- function(data, model_formula, visit_var, subject_var, subject_groups, ...) {
|
||
| 29 | -- |
- h_drop_covariance_terms <- function(f) {
+ | ||
| 410 | +4x | +
+ assert_formula(model_formula) |
||
| 30 | -274x | +411 | +4x |
- specials <- cov_types(c("abbr", "habbr"))
+ assert_data_frame(data) |
| 31 | -+ | |||
| 412 | +4x |
-
+ assert_subset(all.vars(model_formula), colnames(data)) |
||
| 32 | -274x | +413 | +4x |
- terms <- stats::terms(f, specials = specials)+ assert_string(visit_var) |
| 33 | -274x | +414 | +4x |
- covariance_terms <- Filter(Negate(is.null), attr(terms, "specials"))+ assert_string(subject_var) |
| 34 | -+ | |||
| 415 | +4x |
-
+ assert_factor(data[[visit_var]]) |
||
| 35 | -+ | |||
| 416 | +4x |
- # if no covariance terms were found, return original formula+ n_visits <- length(levels(data[[visit_var]])) |
||
| 36 | -274x | +417 | +4x |
- if (length(covariance_terms) == 0) {
+ assert_factor(data[[subject_var]]) |
| 37 | -6x | +418 | +4x |
- return(f)+ subjects <- droplevels(data[[subject_var]]) |
| 38 | -+ | |||
| 419 | +4x |
- }+ n_subjects <- length(levels(subjects)) |
||
| 39 | -268x | +420 | +4x |
- if (length(f) != 3) {
+ fit <- stats::lm(formula = model_formula, data = data) |
| 40 | -1x | +421 | +4x |
- update_str <- "~ . -"+ res <- rep(NA, n_subjects * n_visits) |
| 41 | -+ | |||
| 422 | +4x |
- } else {
+ res[ |
||
| 42 | -267x | +423 | +4x |
- update_str <- ". ~ . -"+ n_visits * as.integer(subjects) - n_visits + as.integer(data[[visit_var]]) |
| 43 | -+ | |||
| 424 | +4x |
- }+ ] <- residuals(fit) |
||
| 44 | -268x | +425 | +4x |
- stats::update(+ res_mat <- matrix(res, ncol = n_visits, nrow = n_subjects, byrow = TRUE) |
| 45 | -268x | +426 | +4x |
- f,+ emp_covs <- lapply( |
| 46 | -268x | +427 | +4x |
- stats::as.formula(paste(update_str, deparse(attr(terms, "variables")[[covariance_terms[[1]] + 1]])))+ unname(split(seq_len(n_subjects), subject_groups)), |
| 47 | -+ | |||
| 428 | +4x |
- )+ function(x) {
|
||
| 48 | -+ | |||
| 429 | +4x |
- }+ stats::cov(res_mat[x, , drop = FALSE], use = "pairwise.complete.obs") |
||
| 49 | +430 |
-
+ } |
||
| 50 | +431 |
- #' Add Individual Covariance Variables As Terms to Formula+ ) |
||
| 51 | -+ | |||
| 432 | +4x |
- #'+ unlist(lapply(emp_covs, h_get_theta_from_cov)) |
||
| 52 | +433 |
- #' @param f (`formula`)\cr a formula to which covariance structure terms should+ } |
||
| 53 | +434 |
- #' be added.+ #' Obtain Theta from Covariance Matrix |
||
| 54 | +435 |
- #' @param covariance (`cov_struct`)\cr a covariance structure object from which+ #' |
||
| 55 | +436 |
- #' additional variables should be sourced.+ #' @description Obtain unstructured theta from covariance matrix. |
||
| 56 | +437 |
#' |
||
| 57 | +438 |
- #' @return A new formula with included covariance terms.+ #' @param covariance (`matrix`) of covariance matrix values. |
||
| 58 | +439 |
#' |
||
| 59 | +440 |
- #' @details [stats::update()] is used to append the covariance structure and the environment+ #' @details |
||
| 60 | +441 |
- #' attribute will not be changed. This ensures the returned formula and the input formula+ #' If the covariance matrix has `NA` in some of the elements, they will be replaced by |
||
| 61 | +442 |
- #' have the same environment.+ #' 0 (non-diagonal) and 1 (diagonal). This ensures that the matrix is positive definite. |
||
| 62 | +443 |
#' |
||
| 63 | +444 | ++ |
+ #' @return Numeric vector of the theta values.+ |
+ |
| 445 |
#' @keywords internal |
|||
| 64 | +446 |
- h_add_covariance_terms <- function(f, covariance) {
+ h_get_theta_from_cov <- function(covariance) {
|
||
| 65 | -272x | +447 | +7x |
- cov_terms <- with(covariance, c(subject, visits, group))+ assert_matrix(covariance, mode = "numeric", ncols = nrow(covariance)) |
| 66 | -266x | +448 | +7x |
- cov_terms <- paste(cov_terms, collapse = " + ")+ covariance[is.na(covariance)] <- 0 |
| 67 | -266x | +449 | +7x |
- stats::update(f, stats::as.formula(paste(". ~ . + ", cov_terms)))
+ diag(covariance)[diag(covariance) == 0] <- 1 |
| 68 | +450 |
- }+ # empirical is not always positive definite in some special cases of numeric singularity. |
||
| 69 | -+ | |||
| 451 | +7x |
-
+ qr_res <- qr(covariance)+ |
+ ||
| 452 | +7x | +
+ if (qr_res$rank < ncol(covariance)) {
+ |
+ ||
| 453 | +! | +
+ covariance <- Matrix::nearPD(covariance)$mat |
||
| 70 | +454 |
- #' Add Formula Terms with Character+ }+ |
+ ||
| 455 | +7x | +
+ emp_chol <- t(chol(covariance))+ |
+ ||
| 456 | +7x | +
+ mat <- t(solve(diag(diag(emp_chol)), emp_chol))+ |
+ ||
| 457 | +7x | +
+ ret <- c(log(diag(emp_chol)), mat[upper.tri(mat)])+ |
+ ||
| 458 | +7x | +
+ unname(ret) |
||
| 71 | +459 |
- #'+ } |
||
| 72 | +460 |
- #' Add formula terms from the original formula with character representation.+ |
||
| 73 | +461 |
- #'+ #' Register S3 Method |
||
| 74 | +462 |
- #' @param f (`formula`)\cr a formula to be updated.+ #' Register S3 method to a generic. |
||
| 75 | +463 |
- #' @param adds (`character`)\cr representation of elements to be added.+ #' |
||
| 76 | +464 |
- #' @param drop_response (`flag`)\cr whether response should be dropped.+ #' @param pkg (`string`) name of the package name. |
||
| 77 | +465 |
- #'+ #' @param generic (`string`) name of the generic. |
||
| 78 | +466 |
- #' @details Elements in `adds` will be added from the formula, while the environment+ #' @param class (`string`) class name the function want to dispatch. |
||
| 79 | +467 |
- #' of the formula is unchanged. If `adds` is `NULL` or `character(0)`, the formula is+ #' @param envir (`environment`) the location the method is defined. |
||
| 80 | +468 |
- #' unchanged.+ #' |
||
| 81 | +469 |
- #' @return A new formula with elements in `drops` removed.+ #' @details This function is adapted from `emmeans:::register_s3_method()`. |
||
| 82 | +470 |
#' |
||
| 83 | +471 |
#' @keywords internal |
||
| 84 | +472 |
- h_add_terms <- function(f, adds, drop_response = FALSE) {
+ h_register_s3 <- function(pkg, generic, class, envir = parent.frame()) {
|
||
| 85 | -599x | +473 | +1x |
- assert_character(adds, null.ok = TRUE)+ assert_string(pkg) |
| 86 | -599x | +474 | +1x |
- if (length(adds) > 0L) {
+ assert_string(generic) |
| 87 | -321x | +475 | +1x |
- add_terms <- stats::as.formula(sprintf(". ~ . + %s", paste(adds, collapse = "+")))
+ assert_string(class) |
| 88 | -321x | +476 | +1x |
- f <- stats::update(f, add_terms)+ assert_environment(envir) |
| 89 | -+ | |||
| 477 | +1x |
- }+ fun <- get(paste0(generic, ".", class), envir = envir) |
||
| 90 | -599x | +478 | +1x |
- if (drop_response && length(f) == 3L) {
+ if (isNamespaceLoaded(pkg)) {
|
| 91 | -35x | +479 | +1x |
- f[[2]] <- NULL+ registerS3method(generic, class, fun, envir = asNamespace(pkg)) |
| 92 | +480 |
} |
||
| 93 | -599x | +481 | +1x |
- f+ setHook(packageEvent(pkg, "onLoad"), function(...) {
|
| 94 | -+ | |||
| 482 | +! |
- }+ registerS3method(generic, class, fun, envir = asNamespace(pkg)) |
| 1 | +483 |
- #' Methods for `mmrm_tmb` Objects+ }) |
||
| 2 | +484 |
- #'+ } |
||
| 3 | +485 |
- #' @description `r lifecycle::badge("stable")`
+
|
||
| 4 | +486 |
- #'+ #' Check if a Factor Should Drop Levels |
||
| 5 | +487 |
- #' @param object (`mmrm_tmb`)\cr the fitted MMRM object.+ #' |
||
| 6 | +488 |
- #' @param x (`mmrm_tmb`)\cr same as `object`.+ #' @param x (`vector`) vector to check. |
||
| 7 | +489 |
- #' @param formula (`mmrm_tmb`)\cr same as `object`.+ #' |
||
| 8 | +490 |
- #' @param complete (`flag`)\cr whether to include potential non-estimable+ #' @keywords internal |
||
| 9 | +491 |
- #' coefficients.+ h_extra_levels <- function(x) {
|
||
| 10 | -+ | |||
| 492 | +1629x |
- #' @param ... mostly not used;+ is.factor(x) && length(levels(x)) > length(unique(x)) |
||
| 11 | +493 |
- #' Exception is `model.matrix()` passing `...` to the default method.+ } |
||
| 12 | +494 |
- #' @return Depends on the method, see Functions.+ |
||
| 13 | +495 |
- #'+ #' Drop Levels from Dataset |
||
| 14 | +496 |
- #' @name mmrm_tmb_methods+ #' @param data (`data.frame`) data to drop levels. |
||
| 15 | +497 |
- #'+ #' @param subject_var (`character`) subject variable. |
||
| 16 | +498 |
- #' @seealso [`mmrm_methods`], [`mmrm_tidiers`] for additional methods.+ #' @param visit_var (`character`) visit variable. |
||
| 17 | +499 |
- #'+ #' @param except (`character`) variables to exclude from dropping. |
||
| 18 | +500 |
- #' @examples+ #' @keywords internal |
||
| 19 | +501 |
- #' formula <- FEV1 ~ RACE + SEX + ARMCD * AVISIT + us(AVISIT | USUBJID)+ h_drop_levels <- function(data, subject_var, visit_var, except) {
|
||
| 20 | -+ | |||
| 502 | +263x |
- #' object <- fit_mmrm(formula, fev_data, weights = rep(1, nrow(fev_data)))+ assert_data_frame(data) |
||
| 21 | -+ | |||
| 503 | +263x |
- NULL+ assert_character(subject_var) |
||
| 22 | -+ | |||
| 504 | +263x |
-
+ assert_character(visit_var) |
||
| 23 | -+ | |||
| 505 | +263x |
- #' @describeIn mmrm_tmb_methods obtains the estimated coefficients.+ assert_character(except, null.ok = TRUE) |
||
| 24 | -- |
- #' @importFrom stats coef- |
- ||
| 25 | -- |
- #' @exportS3Method- |
- ||
| 26 | -- |
- #' @examples- |
- ||
| 27 | -- |
- #' # Estimated coefficients:- |
- ||
| 28 | -- |
- #' coef(object)- |
- ||
| 29 | -+ | |||
| 506 | +263x |
- coef.mmrm_tmb <- function(object, complete = TRUE, ...) {
+ all_cols <- colnames(data) |
||
| 30 | -58x | +507 | +263x |
- assert_flag(complete)+ to_drop <- vapply( |
| 31 | -58x | +508 | +263x |
- nm <- if (complete) "beta_est_complete" else "beta_est"+ data, |
| 32 | -58x | +509 | +263x |
- component(object, name = nm)+ h_extra_levels, |
| 33 | -+ | |||
| 510 | +263x |
- }+ logical(1L) |
||
| 34 | +511 |
-
+ ) |
||
| 35 | -+ | |||
| 512 | +263x |
- #' @describeIn mmrm_tmb_methods obtains the fitted values.+ to_drop <- all_cols[to_drop] |
||
| 36 | +513 |
- #' @importFrom stats fitted+ # only drop levels for those not defined in excep and not in visit_var. |
||
| 37 | -+ | |||
| 514 | +263x |
- #' @exportS3Method+ to_drop <- setdiff(to_drop, c(visit_var, except)) |
||
| 38 | -+ | |||
| 515 | +263x |
- #' @examples+ data[to_drop] <- lapply(data[to_drop], droplevels) |
||
| 39 | +516 |
- #' # Fitted values:+ # subject var are always dropped and no message given. |
||
| 40 | -+ | |||
| 517 | +263x |
- #' fitted(object)+ dropped <- setdiff(to_drop, subject_var) |
||
| 41 | -+ | |||
| 518 | +263x |
- fitted.mmrm_tmb <- function(object, ...) {
+ if (length(dropped) > 0) {
|
||
| 42 | -19x | +519 | +3x |
- fitted_col <- component(object, "x_matrix") %*% component(object, "beta_est")+ message( |
| 43 | -19x | +520 | +3x |
- fitted_col[, 1L, drop = TRUE]+ "Some factor levels are dropped due to singular design matrix: ", |
| 44 | -+ | |||
| 521 | +3x |
- }+ toString(dropped) |
||
| 45 | +522 |
-
+ ) |
||
| 46 | +523 |
- #' @describeIn mmrm_tmb_methods predict conditional means for new data;+ } |
||
| 47 | -+ | |||
| 524 | +263x |
- #' optionally with standard errors and confidence or prediction intervals.+ data |
||
| 48 | +525 |
- #' Returns a vector of predictions if `se.fit == FALSE` and+ } |
||
| 49 | +526 |
- #' `interval == "none"`; otherwise it returns a data.frame with multiple+ |
||
| 50 | +527 |
- #' columns and one row per input data row.+ #' Predicate if the TMB Version Used to Compile the Package is Sufficient |
||
| 51 | +528 |
#' |
||
| 52 | -- |
- #' @param newdata (`data.frame`)\cr optional new data, otherwise data from `object` is used.- |
- ||
| 53 | +529 |
- #' @param se.fit (`flag`)\cr indicator if standard errors are required.+ #' @return Flag whether the TMB version is sufficient. |
||
| 54 | +530 |
- #' @param interval (`string`)\cr type of interval calculation. Can be abbreviated.+ #' @keywords internal |
||
| 55 | +531 |
- #' @param level (`number`)\cr tolerance/confidence level.+ h_tmb_version_sufficient <- function() {
|
||
| 56 | +532 |
- #' @param nsim (`count`)\cr number of simulations to use.+ # Note: There is no version information saved in the dynamic library, but |
||
| 57 | +533 |
- #' @param conditional (`flag`)\cr indicator if the prediction is conditional on the observation or not.+ # we can check like this: |
||
| 58 | -+ | |||
| 534 | +170x |
- #'+ tmb_config <- TMB::config(DLL = "mmrm") |
||
| 59 | -+ | |||
| 535 | +170x |
- #' @importFrom stats predict+ tape_deterministic <- tmb_config$tmbad_deterministic_hash |
||
| 60 | -+ | |||
| 536 | +170x |
- #' @exportS3Method+ !is.null(tape_deterministic) |
||
| 61 | +537 |
- #'+ } |
||
| 62 | +538 |
- #' @examples+ |
||
| 63 | +539 |
- #' predict(object, newdata = fev_data)+ #' Warn if TMB is Configured to Use Non-Deterministic Hash for Tape Optimizer |
||
| 64 | +540 |
- predict.mmrm_tmb <- function(object,+ #' |
||
| 65 | +541 |
- newdata,+ #' This function checks the TMB configuration for the `tmbad_deterministic_hash` setting |
||
| 66 | +542 |
- se.fit = FALSE, # nolint+ #' If it is set to `FALSE`, a warning is issued indicating that this may lead to |
||
| 67 | +543 |
- interval = c("none", "confidence", "prediction"),
+ #' unreproducible results. |
||
| 68 | +544 |
- level = 0.95,+ #' |
||
| 69 | +545 |
- nsim = 1000L,+ #' @return No return value, called for side effects. |
||
| 70 | +546 |
- conditional = FALSE,+ #' @keywords internal |
||
| 71 | +547 |
- ...) {
+ h_tmb_warn_non_deterministic <- function() {
|
||
| 72 | -45x | +548 | +169x |
- if (missing(newdata)) {
+ if (!h_tmb_version_sufficient()) {
|
| 73 | -8x | +|||
| 549 | +! |
- newdata <- object$data+ return() |
||
| 74 | +550 |
} |
||
| 75 | -45x | +551 | +169x |
- assert_data_frame(newdata)+ tmb_config <- TMB::config(DLL = "mmrm") |
| 76 | -45x | +552 | +169x |
- orig_row_names <- row.names(newdata)+ tape_deterministic <- tmb_config$tmbad_deterministic_hash |
| 77 | -45x | +553 | +169x |
- assert_flag(se.fit)+ if (!tape_deterministic) {
|
| 78 | -45x | +554 | +2x |
- assert_number(level, lower = 0, upper = 1)+ msg <- paste( |
| 79 | -45x | +555 | +2x |
- assert_count(nsim, positive = TRUE)+ "TMB is configured to use a non-deterministic hash for its tape optimizer,", |
| 80 | -45x | +556 | +2x |
- assert_flag(conditional)+ "and this may lead to unreproducible results.", |
| 81 | -45x | +557 | +2x |
- interval <- match.arg(interval)+ "To disable this behavior, use `TMB::config(tmbad_deterministic_hash = 1)`.", |
| 82 | -45x | +558 | +2x |
- formula_parts <- object$formula_parts+ sep = "\n" |
| 83 | -45x | +|||
| 559 | +
- if (any(object$tmb_data$x_cols_aliased)) {
+ ) |
|||
| 84 | -1x | +560 | +2x |
- warning(+ warning(msg) |
| 85 | -1x | +|||
| 561 | +
- "In fitted object there are co-linear variables and therefore dropped terms, ",+ } |
|||
| 86 | -1x | +|||
| 562 | +
- "and this could lead to incorrect prediction on new data."+ } |
| 87 | +1 |
- )+ #' Processing the Formula for `TMB` Fit |
||
| 88 | +2 |
- }+ #' |
||
| 89 | -45x | +|||
| 3 | +
- colnames <- names(Filter(isFALSE, object$tmb_data$x_cols_aliased))+ #' @param formula (`formula`)\cr Original formula. |
|||
| 90 | -45x | +|||
| 4 | +
- if (!conditional && interval %in% c("none", "confidence")) {
+ #' @param covariance (`cov_struct`)\cr A covariance structure from which |
|||
| 91 | +5 |
- # model.matrix always return a complete matrix (no NA allowed)+ #' additional formula parts should be added. |
||
| 92 | -27x | +|||
| 6 | +
- x_mat <- stats::model.matrix(object, data = newdata, use_response = FALSE)[, colnames, drop = FALSE]+ #' |
|||
| 93 | -27x | +|||
| 7 | +
- x_mat_full <- matrix(+ #' @return List of class `mmrm_tmb_formula_parts` with elements: |
|||
| 94 | -27x | +|||
| 8 | +
- NA,+ #' |
|||
| 95 | -27x | +|||
| 9 | +
- nrow = nrow(newdata), ncol = ncol(x_mat),+ #' - `formula`: the original input. |
|||
| 96 | -27x | +|||
| 10 | +
- dimnames = list(row.names(newdata), colnames(x_mat))+ #' - `model_formula`: `formula` with the covariance term is removed. |
|||
| 97 | +11 |
- )+ #' - `model_formula`: `formula` with the covariance term removed. |
||
| 98 | -27x | +|||
| 12 | +
- x_mat_full[row.names(x_mat), ] <- x_mat+ #' - `full_formula`: same as `model_formula` but includes the covariance |
|||
| 99 | -27x | +|||
| 13 | +
- predictions <- (x_mat_full %*% component(object, "beta_est"))[, 1]+ #' structure's subject, visit and (optionally) group variables. |
|||
| 100 | -27x | +|||
| 14 | +
- predictions_raw <- stats::setNames(rep(NA_real_, nrow(newdata)), row.names(newdata))+ #' - `cov_type`: `string` with covariance term type (e.g. `"us"`). |
|||
| 101 | -27x | +|||
| 15 | +
- predictions_raw[names(predictions)] <- predictions+ #' - `is_spatial`: `flag` indicator of whether the covariance structure is |
|||
| 102 | -27x | +|||
| 16 | +
- if (identical(interval, "none")) {
+ #' spatial |
|||
| 103 | -20x | +|||
| 17 | +
- return(predictions_raw)+ #' - `visit_var`: `character` with the visit variable name. |
|||
| 104 | +18 |
- }+ #' - `subject_var`: `string` with the subject variable name. |
||
| 105 | -7x | +|||
| 19 | +
- se <- switch(interval,+ #' - `group_var`: `string` with the group variable name. If no group specified, |
|||
| 106 | +20 |
- # can be NA if there are aliased cols+ #' this element is `NULL`. |
||
| 107 | -7x | +|||
| 21 | +
- "confidence" = diag(x_mat_full %*% component(object, "beta_vcov") %*% t(x_mat_full)),+ #' - `model_var`: `character` with the variables names of the formula, except `subject_var`. |
|||
| 108 | -7x | +|||
| 22 | +
- "none" = NA_real_+ #' |
|||
| 109 | +23 |
- )- |
- ||
| 110 | -7x | -
- res <- cbind(- |
- ||
| 111 | -7x | -
- fit = predictions, se = se,- |
- ||
| 112 | -7x | -
- lwr = predictions - stats::qnorm(1 - level / 2) * se, upr = predictions + stats::qnorm(1 - level / 2) * se+ #' @keywords internal |
||
| 113 | +24 |
- )- |
- ||
| 114 | -7x | -
- if (!se.fit) {
+ h_mmrm_tmb_formula_parts <- function( |
||
| 115 | -1x | +|||
| 25 | +
- res <- res[, setdiff(colnames(res), "se")]+ formula, |
|||
| 116 | +26 |
- }+ covariance = as.cov_struct(formula, warn_partial = FALSE)) {
|
||
| 117 | -7x | +27 | +270x |
- res_raw <- matrix(+ assert_formula(formula) |
| 118 | -7x | +28 | +270x |
- NA_real_,+ assert_true(identical(length(formula), 3L)) |
| 119 | -7x | +|||
| 29 | +
- ncol = ncol(res), nrow = nrow(newdata),+ |
|||
| 120 | -7x | +30 | +270x |
- dimnames = list(row.names(newdata), colnames(res))+ model_formula <- h_drop_covariance_terms(formula) |
| 121 | +31 |
- )+ |
||
| 122 | -7x | +32 | +270x |
- res_raw[row.names(res), ] <- res+ structure( |
| 123 | -7x | +33 | +270x |
- return(res_raw)+ list( |
| 124 | -+ | |||
| 34 | +270x |
- }+ formula = formula, |
||
| 125 | -18x | +35 | +270x |
- tmb_data <- h_mmrm_tmb_data(+ model_formula = model_formula, |
| 126 | -18x | +36 | +270x |
- formula_parts, newdata,+ full_formula = h_add_covariance_terms(model_formula, covariance), |
| 127 | -18x | +37 | +270x |
- weights = rep(1, nrow(newdata)),+ cov_type = tmb_cov_type(covariance), |
| 128 | -18x | +38 | +270x |
- reml = TRUE,+ is_spatial = covariance$type == "sp_exp", |
| 129 | -18x | +39 | +270x |
- singular = "keep",+ visit_var = covariance$visits, |
| 130 | -18x | +40 | +270x |
- drop_visit_levels = FALSE,+ subject_var = covariance$subject, |
| 131 | -18x | +41 | +270x |
- allow_na_response = TRUE,+ group_var = if (length(covariance$group) < 1) NULL else covariance$group, |
| 132 | -18x | +42 | +270x |
- drop_levels = FALSE,+ model_var = setdiff(all.vars(formula[[3]]), covariance$subject) |
| 133 | -18x | +|||
| 43 | +
- xlev = component(object, "xlev"),+ ), |
|||
| 134 | -18x | +44 | +270x |
- contrasts = component(object, "contrasts")+ class = "mmrm_tmb_formula_parts" |
| 135 | +45 |
) |
||
| 136 | -18x | +|||
| 46 | +
- tmb_data$x_matrix <- tmb_data$x_matrix[, colnames, drop = FALSE]+ } |
|||
| 137 | -18x | +|||
| 47 | +
- predictions <- h_get_prediction(+ |
|||
| 138 | -18x | +|||
| 48 | +
- tmb_data, object$theta_est, object$beta_est, component(object, "beta_vcov")+ #' Data for `TMB` Fit |
|||
| 139 | -18x | +|||
| 49 | +
- )$prediction+ #' |
|||
| 140 | -18x | +|||
| 50 | +
- res <- cbind(fit = rep(NA_real_, nrow(newdata)))+ #' @param formula_parts (`mmrm_tmb_formula_parts`)\cr list with formula parts |
|||
| 141 | -18x | +|||
| 51 | +
- new_order <- match(row.names(tmb_data$full_frame), orig_row_names)+ #' from [h_mmrm_tmb_formula_parts()]. |
|||
| 142 | -18x | +|||
| 52 | +
- res[new_order, "fit"] <- predictions[, "fit"]+ #' @param data (`data.frame`)\cr which contains variables used in `formula_parts`. |
|||
| 143 | -18x | +|||
| 53 | +
- se <- switch(interval,+ #' @param weights (`vector`)\cr weights to be used in the fitting process. |
|||
| 144 | -18x | +|||
| 54 | +
- "confidence" = sqrt(predictions[, "conf_var"]),+ #' @param reml (`flag`)\cr whether restricted maximum likelihood (REML) estimation is used, |
|||
| 145 | -18x | +|||
| 55 | +
- "prediction" = sqrt(h_get_prediction_variance(object, nsim, tmb_data)),+ #' otherwise maximum likelihood (ML) is used. |
|||
| 146 | -18x | +|||
| 56 | +
- "none" = NULL+ #' @param singular (`string`)\cr choices of method deal with rank-deficient matrices. "error" to |
|||
| 147 | +57 |
- )+ #' stop the function return the error, "drop" to drop these columns, and "keep" to keep all the columns. |
||
| 148 | -18x | +|||
| 58 | +
- if (interval != "none") {
+ #' @param drop_visit_levels (`flag`)\cr whether to drop levels for visit variable, if visit variable is a factor. |
|||
| 149 | -7x | +|||
| 59 | +
- res <- cbind(+ #' @param allow_na_response (`flag`)\cr whether NA in response is allowed. |
|||
| 150 | -7x | +|||
| 60 | +
- res,+ #' @param drop_levels (`flag`)\cr whether drop levels for covariates. If not dropped could lead to singular matrix. |
|||
| 151 | -7x | +|||
| 61 | +
- se = NA_real_+ #' |
|||
| 152 | +62 |
- )+ #' @return List of class `mmrm_tmb_data` with elements: |
||
| 153 | -7x | +|||
| 63 | +
- res[new_order, "se"] <- se+ #' - `full_frame`: `data.frame` with `n` rows containing all variables needed in the model. |
|||
| 154 | -7x | +|||
| 64 | +
- alpha <- 1 - level+ #' - `data`: `data.frame` of input dataset. |
|||
| 155 | -7x | +|||
| 65 | +
- z <- stats::qnorm(1 - alpha / 2) * res[, "se"]+ #' - `x_matrix`: `matrix` with `n` rows and `p` columns specifying the overall design matrix. |
|||
| 156 | -7x | +|||
| 66 | +
- res <- cbind(+ #' - `x_cols_aliased`: `logical` with potentially more than `p` elements indicating which |
|||
| 157 | -7x | +|||
| 67 | +
- res,+ #' columns in the original design matrix have been left out to obtain a full rank |
|||
| 158 | -7x | +|||
| 68 | +
- lwr = res[, "fit"] - z,+ #' `x_matrix`. |
|||
| 159 | -7x | +|||
| 69 | +
- upr = res[, "fit"] + z+ #' - `y_vector`: length `n` `numeric` specifying the overall response vector. |
|||
| 160 | +70 |
- )+ #' - `weights_vector`: length `n` `numeric` specifying the weights vector. |
||
| 161 | -7x | +|||
| 71 | +
- if (!se.fit) {
+ #' - `n_visits`: `int` with the number of visits, which is the dimension of the |
|||
| 162 | -! | +|||
| 72 | +
- res <- res[, setdiff(colnames(res), "se")]+ #' covariance matrix. |
|||
| 163 | +73 |
- }+ #' - `n_subjects`: `int` with the number of subjects. |
||
| 164 | +74 |
- }+ #' - `subject_zero_inds`: length `n_subjects` `integer` containing the zero-based start |
||
| 165 | +75 |
- # Use original names.+ #' indices for each subject. |
||
| 166 | -18x | +|||
| 76 | +
- row.names(res) <- orig_row_names+ #' - `subject_n_visits`: length `n_subjects` `integer` containing the number of |
|||
| 167 | -18x | +|||
| 77 | +
- if (ncol(res) == 1) {
+ #' observed visits for each subjects. So the sum of this vector equals `n`. |
|||
| 168 | -11x | +|||
| 78 | +
- res <- res[, "fit"]+ #' - `cov_type`: `string` value specifying the covariance type. |
|||
| 169 | +79 |
- }+ #' - `is_spatial_int`: `int` specifying whether the covariance structure is spatial(1) or not(0). |
||
| 170 | -18x | +|||
| 80 | +
- return(res)+ #' - `reml`: `int` specifying whether REML estimation is used (1), otherwise ML (0). |
|||
| 171 | +81 |
- }+ #' - `subject_groups`: `factor` specifying the grouping for each subject. |
||
| 172 | +82 |
-
+ #' - `n_groups`: `int` with the number of total groups |
||
| 173 | +83 |
- #' Get Prediction+ #' |
||
| 174 | +84 |
- #'+ #' @details Note that the `subject_var` must not be factor but can also be character. |
||
| 175 | +85 |
- #' @description Get predictions with given `data`, `theta`, `beta`, `beta_vcov`.+ #' If it is character, then it will be converted to factor internally. Here |
||
| 176 | +86 |
- #'+ #' the levels will be the unique values, sorted alphabetically and numerically if there |
||
| 177 | +87 |
- #' @details See `predict` function in `predict.cpp` which is called internally.+ #' is a common string prefix of numbers in the character elements. For full control |
||
| 178 | +88 |
- #'+ #' on the order please use a factor. |
||
| 179 | +89 |
- #' @param tmb_data (`mmrm_tmb_data`)\cr object.+ #' |
||
| 180 | +90 |
- #' @param theta (`numeric`)\cr theta value.+ #' @keywords internal |
||
| 181 | +91 |
- #' @param beta (`numeric`)\cr beta value.+ h_mmrm_tmb_data <- function(formula_parts, |
||
| 182 | +92 |
- #' @param beta_vcov (`matrix`)\cr beta_vcov matrix.+ data, |
||
| 183 | +93 |
- #'+ weights, |
||
| 184 | +94 |
- #' @return List with:+ reml, |
||
| 185 | +95 |
- #' - `prediction`: Matrix with columns `fit`, `conf_var`, and `var`.+ singular = c("drop", "error", "keep"),
|
||
| 186 | +96 |
- #' - `covariance`: List with subject specific covariance matrices.+ drop_visit_levels, |
||
| 187 | +97 |
- #' - `index`: List of zero-based subject indices.+ allow_na_response = FALSE, |
||
| 188 | +98 |
- #'+ drop_levels = TRUE, |
||
| 189 | +99 |
- #' @keywords internal+ xlev = NULL, |
||
| 190 | +100 |
- h_get_prediction <- function(tmb_data, theta, beta, beta_vcov) {
+ contrasts = NULL) {
|
||
| 191 | -1696x | +101 | +312x |
- assert_class(tmb_data, "mmrm_tmb_data")+ assert_class(formula_parts, "mmrm_tmb_formula_parts") |
| 192 | -1696x | +102 | +312x |
- assert_numeric(theta)+ assert_data_frame(data) |
| 193 | -1696x | +103 | +312x |
- n_beta <- ncol(tmb_data$x_matrix)+ varname <- formula_parts[grepl("_var", names(formula_parts))]
|
| 194 | -1696x | +104 | +312x |
- assert_numeric(beta, finite = TRUE, any.missing = FALSE, len = n_beta)+ assert_names( |
| 195 | -1696x | +105 | +312x |
- assert_matrix(beta_vcov, mode = "numeric", any.missing = FALSE, nrows = n_beta, ncols = n_beta)+ names(data), |
| 196 | -1696x | +106 | +312x |
- .Call(`_mmrm_predict`, PACKAGE = "mmrm", tmb_data, theta, beta, beta_vcov)+ must.include = unlist(varname, use.names = FALSE) |
| 197 | +107 |
- }+ ) |
||
| 198 | -+ | |||
| 108 | +312x |
-
+ assert_true(is.factor(data[[formula_parts$subject_var]]) || is.character(data[[formula_parts$subject_var]])) |
||
| 199 | -+ | |||
| 109 | +312x |
- #' Get Prediction Variance+ assert_numeric(weights, len = nrow(data)) |
||
| 200 | -+ | |||
| 110 | +312x |
- #'+ assert_flag(reml) |
||
| 201 | -+ | |||
| 111 | +312x |
- #' @description Get prediction variance with given fit, `tmb_data` with the Monte Carlo sampling method.+ singular <- match.arg(singular) |
||
| 202 | -+ | |||
| 112 | +312x |
- #'+ assert_flag(drop_visit_levels) |
||
| 203 | +113 |
- #' @param object (`mmrm_tmb`)\cr the fitted MMRM.+ |
||
| 204 | -+ | |||
| 114 | +312x |
- #' @param nsim (`count`)\cr number of samples.+ if (is.character(data[[formula_parts$subject_var]])) {
|
||
| 205 | -+ | |||
| 115 | +5x |
- #' @param tmb_data (`mmrm_tmb_data`)\cr object.+ data[[formula_parts$subject_var]] <- factor( |
||
| 206 | -+ | |||
| 116 | +5x |
- #'+ data[[formula_parts$subject_var]],+ |
+ ||
| 117 | +5x | +
+ levels = stringr::str_sort(unique(data[[formula_parts$subject_var]]), numeric = TRUE) |
||
| 207 | +118 |
- #' @keywords internal+ ) |
||
| 208 | +119 |
- h_get_prediction_variance <- function(object, nsim, tmb_data) {
+ } |
||
| 209 | -7x | +120 | +312x |
- assert_class(object, "mmrm_tmb")+ data_order <- if (formula_parts$is_spatial) {
|
| 210 | -7x | +121 | +16x |
- assert_class(tmb_data, "mmrm_tmb_data")+ order(data[[formula_parts$subject_var]]) |
| 211 | -7x | +|||
| 122 | +
- assert_count(nsim, positive = TRUE)+ } else {
|
|||
| 212 | -7x | +123 | +296x |
- theta_chol <- chol(object$theta_vcov)+ subject_visit_data <- data[, c(formula_parts$subject_var, formula_parts$visit_var)] |
| 213 | -7x | +124 | +296x |
- n_theta <- length(object$theta_est)+ is_duplicated <- duplicated(subject_visit_data) |
| 214 | -7x | +125 | +296x |
- res <- replicate(nsim, {
+ if (any(is_duplicated)) {
|
| 215 | -1150x | +126 | +1x |
- z <- stats::rnorm(n = n_theta)+ stop( |
| 216 | -1150x | +127 | +1x |
- theta_sample <- object$theta_est + z %*% theta_chol+ "time points have to be unique for each subject, detected following duplicates in data:\n", |
| 217 | -1150x | +128 | +1x |
- cond_beta_results <- object$tmb_object$report(theta_sample)+ paste(utils::capture.output(print(subject_visit_data[is_duplicated, ])), collapse = "\n") |
| 218 | -1150x | +|||
| 129 | +
- beta_mean <- cond_beta_results$beta+ ) |
|||
| 219 | -1150x | +|||
| 130 | +
- beta_cov <- cond_beta_results$beta_vcov+ } |
|||
| 220 | -1150x | +131 | +295x |
- h_get_prediction(tmb_data, theta_sample, beta_mean, beta_cov)$prediction+ order(data[[formula_parts$subject_var]], data[[formula_parts$visit_var]]) |
| 221 | +132 |
- })- |
- ||
| 222 | -7x | -
- mean_of_var <- rowMeans(res[, "var", ])+ } |
||
| 223 | -7x | +133 | +311x |
- var_of_mean <- apply(res[, "fit", ], 1, stats::var)+ if (identical(formula_parts$is_spatial, FALSE)) {
|
| 224 | -7x | +134 | +295x |
- mean_of_var + var_of_mean+ h_confirm_large_levels(length(levels(data[[formula_parts$visit_var]]))) |
| 225 | +135 |
- }+ } |
||
| 226 | -+ | |||
| 136 | +310x |
-
+ data <- data[data_order, ] |
||
| 227 | -+ | |||
| 137 | +310x |
- #' @describeIn mmrm_tmb_methods obtains the model frame.+ weights <- weights[data_order] |
||
| 228 | -+ | |||
| 138 | +310x |
- #' @param data (`data.frame`)\cr object in which to construct the frame.+ data <- data.frame(data, weights) |
||
| 229 | +139 |
- #' @param include (`character`)\cr names of variable types to include.+ # Weights is always the last column. |
||
| 230 | -+ | |||
| 140 | +310x |
- #' Must be `NULL` or one or more of `c("subject_var", "visit_var", "group_var", "response_var")`.
+ weights_name <- colnames(data)[ncol(data)] |
||
| 231 | +141 |
- #' @param full (`flag`)\cr indicator whether to return full model frame (deprecated).+ # If `y` is allowed to be NA, then first replace y with 1:n, then replace it with original y. |
||
| 232 | -+ | |||
| 142 | +310x |
- #' @param na.action (`string`)\cr na action.+ if (!allow_na_response) {
|
||
| 233 | -+ | |||
| 143 | +260x |
- #' @importFrom stats model.frame+ h_warn_na_action() |
||
| 234 | +144 |
- #' @exportS3Method+ } |
||
| 235 | -+ | |||
| 145 | +310x |
- #'+ full_frame <- eval( |
||
| 236 | -+ | |||
| 146 | +310x |
- #' @details+ bquote(stats::model.frame( |
||
| 237 | -+ | |||
| 147 | +310x |
- #' `include` argument controls the variables the returned model frame will include.+ formula_parts$full_formula, |
||
| 238 | -+ | |||
| 148 | +310x |
- #' Possible options are "response_var", "subject_var", "visit_var" and "group_var", representing the+ data = data, |
||
| 239 | -+ | |||
| 149 | +310x |
- #' response variable, subject variable, visit variable or group variable.+ weights = .(as.symbol(weights_name)), |
||
| 240 | -+ | |||
| 150 | +310x |
- #' `character` values in new data will always be factorized according to the data in the fit+ na.action = "na.pass", |
||
| 241 | -+ | |||
| 151 | +310x |
- #' to avoid mismatched in levels or issues in `model.matrix`.+ xlev = xlev |
||
| 242 | +152 |
- #'+ )) |
||
| 243 | +153 |
- #' @examples+ ) |
||
| 244 | -+ | |||
| 154 | +310x |
- #' # Model frame:+ if (drop_levels) {
|
||
| 245 | -+ | |||
| 155 | +262x |
- #' model.frame(object)+ full_frame <- h_drop_levels(full_frame, formula_parts$subject_var, formula_parts$visit_var, names(xlev)) |
||
| 246 | +156 |
- #' model.frame(object, include = "subject_var")+ } |
||
| 247 | -+ | |||
| 157 | +310x |
- model.frame.mmrm_tmb <- function(formula, data, include = c("subject_var", "visit_var", "group_var", "response_var"),
+ has_response <- !identical(attr(attr(full_frame, "terms"), "response"), 0L) |
||
| 248 | -+ | |||
| 158 | +310x |
- full, na.action = "na.omit", ...) { # nolint
+ keep_ind <- if (allow_na_response && has_response) {
|
||
| 249 | +159 |
- # Construct updated formula and data arguments.+ # Note that response is always the first column if there is response. |
||
| 250 | -46x | +160 | +50x |
- lst_formula_and_data <-+ stats::complete.cases(full_frame[, -1L, drop = FALSE]) |
| 251 | -46x | +|||
| 161 | +
- h_construct_model_frame_inputs(+ } else {
|
|||
| 252 | -46x | +162 | +260x |
- formula = formula,+ stats::complete.cases(full_frame) |
| 253 | -46x | +|||
| 163 | +
- data = data,+ } |
|||
| 254 | -46x | +164 | +310x |
- include = include,+ full_frame <- full_frame[keep_ind, ] |
| 255 | -46x | +165 | +310x |
- full = full+ if (drop_visit_levels && !formula_parts$is_spatial && h_extra_levels(full_frame[[formula_parts$visit_var]])) {
|
| 256 | -+ | |||
| 166 | +3x |
- )+ visit_vec <- full_frame[[formula_parts$visit_var]] |
||
| 257 | -+ | |||
| 167 | +3x |
- # Only if include is default (full) and also data is missing, and also na.action is na.omit we will+ old_levels <- levels(visit_vec) |
||
| 258 | -+ | |||
| 168 | +3x |
- # use the model frame from the tmb_data.+ full_frame[[formula_parts$visit_var]] <- droplevels(visit_vec) |
||
| 259 | -46x | +169 | +3x |
- include_choice <- c("subject_var", "visit_var", "group_var", "response_var")
+ new_levels <- levels(full_frame[[formula_parts$visit_var]]) |
| 260 | -46x | +170 | +3x |
- if (missing(data) && setequal(include, include_choice) && identical(h_get_na_action(na.action), stats::na.omit)) {
+ dropped <- setdiff(old_levels, new_levels) |
| 261 | -2x | +171 | +3x |
- ret <- formula$tmb_data$full_frame+ message( |
| 262 | -+ | |||
| 172 | +3x |
- # Remove weights column.+ "In ", formula_parts$visit_var, " there are dropped visits: ", toString(dropped), |
||
| 263 | -2x | +173 | +3x |
- ret[, "(weights)"] <- NULL+ ".\n Additional attributes including contrasts are lost.\n", |
| 264 | -2x | +174 | +3x |
- ret+ "To avoid this behavior, make sure use `drop_visit_levels = FALSE`." |
| 265 | +175 |
- } else {
+ ) |
||
| 266 | +176 |
- # Construct data frame to return to users.+ } |
||
| 267 | -44x | +177 | +310x |
- ret <-+ is_factor_col <- vapply(full_frame, is.factor, FUN.VALUE = TRUE) |
| 268 | -44x | +178 | +310x |
- stats::model.frame(+ is_factor_col <- intersect(names(is_factor_col)[is_factor_col], all.vars(formula_parts$model_formula)) |
| 269 | -44x | +179 | +310x |
- formula = lst_formula_and_data$formula,+ x_matrix <- stats::model.matrix( |
| 270 | -44x | +180 | +310x |
- data = h_get_na_action(na.action)(lst_formula_and_data$data),+ formula_parts$model_formula, |
| 271 | -44x | +181 | +310x |
- na.action = na.action,+ data = full_frame, |
| 272 | -44x | +182 | +310x |
- xlev = stats::.getXlevels(terms(formula), formula$tmb_data$full_frame)+ contrasts.arg = h_default_value(contrasts, lapply(full_frame[is_factor_col], contrasts)) |
| 273 | +183 |
- )+ ) |
||
| 274 | -+ | |||
| 184 | +309x |
- }+ x_cols_aliased <- stats::setNames(rep(FALSE, ncol(x_matrix)), nm = colnames(x_matrix)) |
||
| 275 | -45x | +185 | +309x |
- ret+ qr_x_mat <- qr(x_matrix) |
| 276 | -+ | |||
| 186 | +309x |
- }+ if (qr_x_mat$rank < ncol(x_matrix)) {
|
||
| 277 | -+ | |||
| 187 | +23x |
-
+ cols_to_drop <- utils::tail(qr_x_mat$pivot, ncol(x_matrix) - qr_x_mat$rank) |
||
| 278 | -+ | |||
| 188 | +23x |
-
+ if (identical(singular, "error")) {
|
||
| 279 | -+ | |||
| 189 | +1x |
- #' Construction of Model Frame Formula and Data Inputs+ stop( |
||
| 280 | -+ | |||
| 190 | +1x |
- #'+ "design matrix only has rank ", qr_x_mat$rank, " and ", length(cols_to_drop), |
||
| 281 | -+ | |||
| 191 | +1x |
- #' @description+ " columns (", toString(colnames(x_matrix)[cols_to_drop]), ") could be dropped",
|
||
| 282 | -+ | |||
| 192 | +1x |
- #' Input formulas are converted from mmrm-style to a style compatible+ " to achieve full rank ", ncol(x_matrix), " by using `accept_singular = TRUE`" |
||
| 283 | +193 |
- #' with default [stats::model.frame()] and [stats::model.matrix()] methods.+ ) |
||
| 284 | -+ | |||
| 194 | +22x |
- #'+ } else if (identical(singular, "drop")) {
|
||
| 285 | -+ | |||
| 195 | +11x |
- #' The full formula is returned so we can construct, for example, the+ assign_attr <- attr(x_matrix, "assign") |
||
| 286 | -+ | |||
| 196 | +11x |
- #' `model.frame()` including all columns as well as the requested subset.+ contrasts_attr <- attr(x_matrix, "contrasts") |
||
| 287 | -+ | |||
| 197 | +11x |
- #' The full set is used to identify rows to include in the reduced model frame.+ x_matrix <- x_matrix[, -cols_to_drop, drop = FALSE] |
||
| 288 | -+ | |||
| 198 | +11x |
- #'+ x_cols_aliased[cols_to_drop] <- TRUE |
||
| 289 | -+ | |||
| 199 | +11x |
- #' @param formula (`mmrm`)\cr mmrm fit object.+ attr(x_matrix, "assign") <- assign_attr[-cols_to_drop] |
||
| 290 | -+ | |||
| 200 | +11x |
- #' @param data optional data frame that will be+ attr(x_matrix, "contrasts") <- contrasts_attr |
||
| 291 | +201 |
- #' passed to `model.frame()` or `model.matrix()`+ } |
||
| 292 | +202 |
- #' @param include (`character`)\cr names of variable to include+ } |
||
| 293 | -+ | |||
| 203 | +308x |
- #' @param full (`flag`)\cr indicator whether to return full model frame (deprecated).+ y_vector <- if (has_response) {
|
||
| 294 | -+ | |||
| 204 | +308x |
- #'+ as.numeric(stats::model.response(full_frame)) |
||
| 295 | +205 |
- #' @return named list with four elements:+ } else {
|
||
| 296 | -+ | |||
| 206 | +! |
- #' - `"formula"`: the formula including the columns requested in the `include=` argument.+ rep(NA_real_, nrow(full_frame)) |
||
| 297 | +207 |
- #' - `"data"`: a data frame including all columns needed in the formula.+ } |
||
| 298 | -+ | |||
| 208 | +308x |
- #' full formula are identical+ weights_vector <- as.numeric(stats::model.weights(full_frame)) |
||
| 299 | -+ | |||
| 209 | +308x |
- #' @keywords internal+ n_subjects <- length(unique(full_frame[[formula_parts$subject_var]])) |
||
| 300 | -+ | |||
| 210 | +308x |
- h_construct_model_frame_inputs <- function(formula,+ subject_zero_inds <- which(!duplicated(full_frame[[formula_parts$subject_var]])) - 1L |
||
| 301 | -+ | |||
| 211 | +308x |
- data,+ subject_n_visits <- c(utils::tail(subject_zero_inds, -1L), nrow(full_frame)) - subject_zero_inds |
||
| 302 | +212 |
- include,+ # It is possible that `subject_var` is factor with more levels (and this does not affect fit) |
||
| 303 | +213 |
- include_choice = c("subject_var", "visit_var", "group_var", "response_var"),
+ # so no check is needed for `subject_visits`. |
||
| 304 | -+ | |||
| 214 | +308x |
- full) {
+ assert_true(all(subject_n_visits > 0)) |
||
| 305 | -280x | +215 | +308x |
- if (!missing(full) && identical(full, TRUE)) {
+ if (!is.null(formula_parts$group_var)) {
|
| 306 | -! | +|||
| 216 | +41x |
- lifecycle::deprecate_warn("0.3", "model.frame.mmrm_tmb(full)")
+ assert_factor(data[[formula_parts$group_var]]) |
||
| 307 | -! | +|||
| 217 | +41x |
- include <- include_choice+ subject_groups <- full_frame[[formula_parts$group_var]][subject_zero_inds + 1L]+ |
+ ||
| 218 | +41x | +
+ n_groups <- nlevels(subject_groups) |
||
| 308 | +219 |
- }+ } else {
+ |
+ ||
| 220 | +267x | +
+ subject_groups <- factor(rep(0L, n_subjects))+ |
+ ||
| 221 | +267x | +
+ n_groups <- 1L |
||
| 309 | +222 |
-
+ } |
||
| 310 | -280x | +223 | +308x |
- assert_class(formula, classes = "mmrm_tmb")+ coordinates <- full_frame[, formula_parts$visit_var, drop = FALSE] |
| 311 | -280x | +224 | +308x |
- assert_subset(include, include_choice)+ if (formula_parts$is_spatial) {
|
| 312 | -280x | +225 | +16x |
- if (missing(data)) {
+ lapply(coordinates, assert_numeric) |
| 313 | -256x | +226 | +16x |
- data <- formula$data+ coordinates_matrix <- as.matrix(coordinates)+ |
+
| 227 | +16x | +
+ n_visits <- max(subject_n_visits) |
||
| 314 | +228 |
- }+ } else {
|
||
| 315 | -280x | +229 | +292x |
- assert_data_frame(data)+ assert(identical(ncol(coordinates), 1L)) |
| 316 | -+ | |||
| 230 | +292x |
-
+ assert_factor(coordinates[[1L]]) |
||
| 317 | -280x | +231 | +292x |
- drop_response <- !"response_var" %in% include+ coordinates_matrix <- as.matrix(as.integer(coordinates[[1L]]) - 1, ncol = 1) |
| 318 | -280x | +232 | +292x |
- add_vars <- unlist(formula$formula_parts[include])+ n_visits <- nlevels(coordinates[[1L]]) |
| 319 | -280x | +233 | +292x |
- new_formula <- h_add_terms(formula$formula_parts$model_formula, add_vars, drop_response)+ assert_true(all(subject_n_visits <= n_visits)) |
| 320 | +234 |
-
+ } |
||
| 321 | -280x | +235 | +308x |
- drop_response_full <- !"response_var" %in% include_choice+ structure( |
| 322 | -280x | +236 | +308x |
- add_vars_full <- unlist(formula$formula_parts[include_choice])+ list( |
| 323 | -280x | +237 | +308x |
- new_formula_full <-+ full_frame = full_frame, |
| 324 | -280x | +238 | +308x |
- h_add_terms(formula$formula_parts$model_formula, add_vars_full, drop_response_full)+ data = data, |
| 325 | -+ | |||
| 239 | +308x |
-
+ x_matrix = x_matrix, |
||
| 326 | -+ | |||
| 240 | +308x |
- # Update data based on the columns in the full formula return.+ x_cols_aliased = x_cols_aliased, |
||
| 327 | -280x | +241 | +308x |
- all_vars <- all.vars(new_formula_full)+ coordinates = coordinates_matrix, |
| 328 | -280x | +242 | +308x |
- assert_names(colnames(data), must.include = all_vars)+ y_vector = y_vector, |
| 329 | -280x | +243 | +308x |
- data <- data[, all_vars, drop = FALSE]+ weights_vector = weights_vector, |
| 330 | -+ | |||
| 244 | +308x |
-
+ n_visits = n_visits, |
||
| 331 | -+ | |||
| 245 | +308x |
- # Return list with updated formula, data.+ n_subjects = n_subjects, |
||
| 332 | -280x | +246 | +308x |
- list(+ subject_zero_inds = subject_zero_inds, |
| 333 | -280x | +247 | +308x |
- formula = new_formula,+ subject_n_visits = subject_n_visits, |
| 334 | -280x | +248 | +308x |
- data = data+ cov_type = formula_parts$cov_type, |
| 335 | -+ | |||
| 249 | +308x |
- )+ is_spatial_int = as.integer(formula_parts$is_spatial),+ |
+ ||
| 250 | +308x | +
+ reml = as.integer(reml),+ |
+ ||
| 251 | +308x | +
+ subject_groups = subject_groups,+ |
+ ||
| 252 | +308x | +
+ n_groups = n_groups |
||
| 336 | +253 |
- }+ ),+ |
+ ||
| 254 | +308x | +
+ class = "mmrm_tmb_data" |
||
| 337 | +255 |
-
+ ) |
||
| 338 | +256 |
- #' @describeIn mmrm_tmb_methods obtains the model matrix.+ } |
||
| 339 | +257 |
- #' @exportS3Method+ |
||
| 340 | +258 |
- #' @param use_response (`flag`)\cr whether to use the response for complete rows.+ #' Start Parameters for `TMB` Fit |
||
| 341 | +259 |
#' |
||
| 342 | +260 |
- #' @examples+ #' @param formula_parts (`mmrm_tmb_formula_parts`)\cr produced by |
||
| 343 | +261 |
- #' # Model matrix:+ #' [h_mmrm_tmb_formula_parts()]. |
||
| 344 | +262 |
- #' model.matrix(object)+ #' @param tmb_data (`mmrm_tmb_data`)\cr produced by [h_mmrm_tmb_data()]. |
||
| 345 | +263 |
- model.matrix.mmrm_tmb <- function(object, data, use_response = TRUE, ...) { # nolint
+ #' @param start (`numeric` or `NULL`)\cr optional start values for variance |
||
| 346 | +264 |
- # Always return the utilized model matrix if data not provided.- |
- ||
| 347 | -37x | -
- if (missing(data)) {
- |
- ||
| 348 | -3x | -
- return(object$tmb_data$x_matrix)+ #' parameters. |
||
| 349 | +265 |
- }- |
- ||
| 350 | -34x | -
- stats::model.matrix(- |
- ||
| 351 | -34x | -
- h_add_terms(object$formula_parts$model_formula, NULL, drop_response = !use_response),- |
- ||
| 352 | -34x | -
- data = data,- |
- ||
| 353 | -34x | -
- contrasts.arg = attr(object$tmb_data$x_matrix, "contrasts"),- |
- ||
| 354 | -34x | -
- xlev = component(object, "xlev"),+ #' @param n_groups (`int`)\cr number of groups. |
||
| 355 | +266 |
- ...+ #' @return List with element `theta` containing the start values for the variance |
||
| 356 | +267 |
- )+ #' parameters. |
||
| 357 | +268 |
- }+ #' |
||
| 358 | +269 |
-
+ #' @keywords internal |
||
| 359 | +270 |
- #' @describeIn mmrm_tmb_methods obtains the terms object.+ h_mmrm_tmb_parameters <- function(formula_parts, |
||
| 360 | +271 |
- #' @importFrom stats model.frame+ tmb_data, |
||
| 361 | +272 |
- #' @exportS3Method+ start, |
||
| 362 | +273 |
- #'+ n_groups = 1L) {
|
||
| 363 | -+ | |||
| 274 | +265x |
- #' @examples+ assert_class(formula_parts, "mmrm_tmb_formula_parts") |
||
| 364 | -+ | |||
| 275 | +265x |
- #' # terms:+ assert_class(tmb_data, "mmrm_tmb_data") |
||
| 365 | +276 |
- #' terms(object)+ |
||
| 366 | -+ | |||
| 277 | +265x |
- #' terms(object, include = "subject_var")+ m <- tmb_data$n_visits |
||
| 367 | -+ | |||
| 278 | +265x |
- terms.mmrm_tmb <- function(x, include = "response_var", ...) { # nolint
+ start_value0 <- std_start(formula_parts$cov_type, m, n_groups) |
||
| 368 | -+ | |||
| 279 | +265x |
- # Construct updated formula and data arguments.+ theta_dim <- length(start_value0) |
||
| 369 | -231x | +280 | +265x |
- lst_formula_and_data <-+ start_values <- if (is.null(start)) {
|
| 370 | -231x | +281 | +15x |
- h_construct_model_frame_inputs(+ start_value0 |
| 371 | -231x | +282 | +265x |
- formula = x,+ } else if (test_function(start)) {
|
| 372 | -231x | +283 | +233x |
- include = include+ do.call(start, utils::modifyList(formula_parts, tmb_data)) |
| 373 | +284 |
- )+ } else {
|
||
| 374 | -+ | |||
| 285 | +17x |
-
+ start |
||
| 375 | +286 |
- # Use formula method for `terms()` to construct the mmrm terms object.- |
- ||
| 376 | -231x | -
- stats::terms(+ } |
||
| 377 | -231x | +287 | +264x |
- x = lst_formula_and_data$formula,+ assert_numeric(start_values, len = theta_dim, any.missing = FALSE, finite = TRUE) |
| 378 | -231x | -
- data = lst_formula_and_data$data- |
- ||
| 379 | -+ | 288 | +262x |
- )+ list(theta = start_values) |
| 380 | +289 |
} |
||
| 381 | +290 | |||
| 382 | +291 |
-
+ #' Asserting Sane Start Values for `TMB` Fit |
||
| 383 | +292 |
- #' @describeIn mmrm_tmb_methods obtains the attained log likelihood value.+ #' |
||
| 384 | +293 |
- #' @importFrom stats logLik+ #' @param tmb_object (`list`)\cr created with [TMB::MakeADFun()]. |
||
| 385 | +294 |
- #' @exportS3Method+ #' |
||
| 386 | +295 |
- #' @examples+ #' @return Nothing, only used for assertions. |
||
| 387 | +296 |
- #' # Log likelihood given the estimated parameters:+ #' |
||
| 388 | +297 |
- #' logLik(object)+ #' @keywords internal |
||
| 389 | +298 |
- logLik.mmrm_tmb <- function(object, ...) {
+ h_mmrm_tmb_assert_start <- function(tmb_object) {
|
||
| 390 | -50x | +299 | +249x |
- -component(object, "neg_log_lik")+ assert_list(tmb_object) |
| 391 | -+ | |||
| 300 | +249x |
- }+ assert_subset(c("fn", "gr", "par"), names(tmb_object))
|
||
| 392 | +301 | |||
| 393 | -+ | |||
| 302 | +249x |
- #' @describeIn mmrm_tmb_methods obtains the used formula.+ if (is.na(tmb_object$fn(tmb_object$par))) {
|
||
| 394 | -+ | |||
| 303 | +1x |
- #' @importFrom stats formula+ stop("negative log-likelihood is NaN at starting parameter values")
|
||
| 395 | +304 |
- #' @exportS3Method+ } |
||
| 396 | -+ | |||
| 305 | +248x |
- #' @examples+ if (any(is.na(tmb_object$gr(tmb_object$par)))) {
|
||
| 397 | -+ | |||
| 306 | +1x |
- #' # Formula which was used:+ stop("some elements of gradient are NaN at starting parameter values")
|
||
| 398 | +307 |
- #' formula(object)+ } |
||
| 399 | +308 |
- formula.mmrm_tmb <- function(x, ...) {
+ } |
||
| 400 | -5x | +|||
| 309 | +
- x$formula_parts$formula+ |
|||
| 401 | +310 |
- }+ #' Checking the `TMB` Optimization Result |
||
| 402 | +311 |
-
+ #' |
||
| 403 | +312 |
- #' @describeIn mmrm_tmb_methods obtains the variance-covariance matrix estimate+ #' @param tmb_opt (`list`)\cr optimization result. |
||
| 404 | +313 |
- #' for the coefficients.+ #' @param mmrm_tmb (`mmrm_tmb`)\cr result from [h_mmrm_tmb_fit()]. |
||
| 405 | +314 |
- #' @importFrom stats vcov+ #' |
||
| 406 | +315 |
- #' @exportS3Method+ #' @return Nothing, only used to generate warnings in case that the model |
||
| 407 | +316 |
- #' @examples+ #' did not converge. |
||
| 408 | +317 |
- #' # Variance-covariance matrix estimate for coefficients:+ #' |
||
| 409 | +318 |
- #' vcov(object)+ #' @keywords internal |
||
| 410 | +319 |
- vcov.mmrm_tmb <- function(object, complete = TRUE, ...) {
+ h_mmrm_tmb_check_conv <- function(tmb_opt, mmrm_tmb) {
|
||
| 411 | -3x | +320 | +245x |
- assert_flag(complete)+ assert_list(tmb_opt) |
| 412 | -3x | +321 | +245x |
- nm <- if (complete) "beta_vcov_complete" else "beta_vcov"+ assert_subset(c("par", "objective", "convergence", "message"), names(tmb_opt))
|
| 413 | -3x | -
- component(object, name = nm)- |
- ||
| 414 | -+ | 322 | +245x |
- }+ assert_class(mmrm_tmb, "mmrm_tmb") |
| 415 | +323 | |||
| 416 | -+ | |||
| 324 | +245x |
- #' @describeIn mmrm_tmb_methods obtains the variance-covariance matrix estimate+ if (!is.null(tmb_opt$convergence) && tmb_opt$convergence != 0) {
|
||
| 417 | -+ | |||
| 325 | +3x |
- #' for the residuals.+ warning("Model convergence problem: ", tmb_opt$message, ".")
|
||
| 418 | -+ | |||
| 326 | +3x |
- #' @param sigma cannot be used (this parameter does not exist in MMRM).+ return() |
||
| 419 | +327 |
- #' @importFrom nlme VarCorr+ } |
||
| 420 | -+ | |||
| 328 | +242x |
- #' @export VarCorr+ theta_vcov <- mmrm_tmb$theta_vcov |
||
| 421 | -+ | |||
| 329 | +242x |
- #' @aliases VarCorr+ if (is(theta_vcov, "try-error")) {
|
||
| 422 | -+ | |||
| 330 | +3x |
- #' @exportS3Method+ warning("Model convergence problem: hessian is singular, theta_vcov not available.")
|
||
| 423 | -+ | |||
| 331 | +3x |
- #' @examples+ return() |
||
| 424 | +332 |
- #' # Variance-covariance matrix estimate for residuals:+ } |
||
| 425 | -+ | |||
| 333 | +239x |
- #' VarCorr(object)+ if (!all(is.finite(theta_vcov))) {
|
||
| 426 | -+ | |||
| 334 | +3x |
- VarCorr.mmrm_tmb <- function(x, sigma = NA, ...) { # nolint
+ warning("Model convergence problem: theta_vcov contains non-finite values.")
|
||
| 427 | -10x | +335 | +3x |
- assert_scalar_na(sigma)+ return() |
| 428 | +336 |
-
+ } |
||
| 429 | -10x | +337 | +236x |
- component(x, name = "varcor")+ eigen_vals <- eigen(theta_vcov, only.values = TRUE)$values |
| 430 | -+ | |||
| 338 | +236x |
- }+ if (mode(eigen_vals) == "complex" || any(eigen_vals <= 0)) {
|
||
| 431 | +339 |
-
+ # Note: complex eigen values signal that the matrix is not symmetric, therefore not positive definite. |
||
| 432 | -+ | |||
| 340 | +3x |
- #' @describeIn mmrm_tmb_methods obtains the deviance, which is defined here+ warning("Model convergence problem: theta_vcov is not positive definite.")
|
||
| 433 | -+ | |||
| 341 | +3x |
- #' as twice the negative log likelihood, which can either be integrated+ return() |
||
| 434 | +342 |
- #' over the coefficients for REML fits or the usual one for ML fits.+ } |
||
| 435 | -+ | |||
| 343 | +233x |
- #' @importFrom stats deviance+ qr_rank <- qr(theta_vcov)$rank |
||
| 436 | -+ | |||
| 344 | +233x |
- #' @exportS3Method+ if (qr_rank < ncol(theta_vcov)) {
|
||
| 437 | -+ | |||
| 345 | +1x |
- #' @examples+ warning("Model convergence problem: theta_vcov is numerically singular.")
|
||
| 438 | +346 |
- #' # REML criterion (twice the negative log likelihood):+ } |
||
| 439 | +347 |
- #' deviance(object)+ } |
||
| 440 | +348 |
- deviance.mmrm_tmb <- function(object, ...) {
- |
- ||
| 441 | -74x | -
- 2 * component(object, "neg_log_lik")+ |
||
| 442 | +349 |
- }+ #' Extract covariance matrix from `TMB` report and input data |
||
| 443 | +350 |
-
+ #' |
||
| 444 | +351 |
- #' @describeIn mmrm_tmb_methods obtains the Akaike Information Criterion,+ #' This helper does some simple post-processing to extract covariance matrix or named |
||
| 445 | +352 |
- #' where the degrees of freedom are the number of variance parameters (`n_theta`).+ #' list of covariance matrices if the fitting is using grouped covariance matrices. |
||
| 446 | +353 |
- #' If `corrected`, then this is multiplied with `m / (m - n_theta - 1)` where+ #' |
||
| 447 | +354 |
- #' `m` is the number of observations minus the number of coefficients, or+ #' @param tmb_report (`list`)\cr report created with [TMB::MakeADFun()] report function. |
||
| 448 | +355 |
- #' `n_theta + 2` if it is smaller than that \insertCite{hurvich1989regression,burnham1998practical}{mmrm}.
+ #' @param tmb_data (`mmrm_tmb_data`)\cr produced by [h_mmrm_tmb_data()]. |
||
| 449 | +356 |
- #' @param corrected (`flag`)\cr whether corrected AIC should be calculated.+ #' @param visit_var (`character`)\cr character vector of the visit variable |
||
| 450 | +357 |
- #' @param k (`number`)\cr the penalty per parameter to be used; default `k = 2`+ #' @param is_spatial (`flag`)\cr indicator whether the covariance structure is spatial. |
||
| 451 | +358 |
- #' is the classical AIC.+ #' @return Return a simple covariance matrix if there is no grouping, or a named |
||
| 452 | +359 |
- #' @importFrom stats AIC+ #' list of estimated grouped covariance matrices, |
||
| 453 | +360 |
- #' @exportS3Method+ #' with its name equal to the group levels. |
||
| 454 | +361 |
- #' @examples+ #' |
||
| 455 | +362 |
- #' # AIC:+ #' @keywords internal |
||
| 456 | +363 |
- #' AIC(object)+ h_mmrm_tmb_extract_cov <- function(tmb_report, tmb_data, visit_var, is_spatial) {
|
||
| 457 | -+ | |||
| 364 | +241x |
- #' AIC(object, corrected = TRUE)+ d <- dim(tmb_report$covariance_lower_chol) |
||
| 458 | -+ | |||
| 365 | +241x |
- #' @references+ visit_names <- if (!is_spatial) {
|
||
| 459 | -+ | |||
| 366 | +228x |
- #' - \insertRef{hurvich1989regression}{mmrm}
+ levels(tmb_data$full_frame[[visit_var]]) |
||
| 460 | +367 |
- #' - \insertRef{burnham1998practical}{mmrm}
+ } else {
|
||
| 461 | -+ | |||
| 368 | +13x |
- AIC.mmrm_tmb <- function(object, corrected = FALSE, ..., k = 2) {
+ c(0, 1) |
||
| 462 | +369 |
- # nolint+ } |
||
| 463 | -44x | +370 | +241x |
- assert_flag(corrected)+ cov <- lapply( |
| 464 | -44x | +371 | +241x |
- assert_number(k, lower = 1)+ seq_len(d[1] / d[2]), |
| 465 | -+ | |||
| 372 | +241x |
-
+ function(i) {
|
||
| 466 | -44x | +373 | +278x |
- n_theta <- length(component(object, "theta_est"))+ ret <- tcrossprod(tmb_report$covariance_lower_chol[seq(1 + (i - 1) * d[2], i * d[2]), ]) |
| 467 | -44x | +374 | +278x |
- df <- if (!corrected) {
+ dimnames(ret) <- list(visit_names, visit_names) |
| 468 | -43x | +375 | +278x |
- n_theta+ return(ret) |
| 469 | +376 |
- } else {
+ } |
||
| 470 | -1x | +|||
| 377 | +
- n_obs <- length(component(object, "y_vector"))+ ) |
|||
| 471 | -1x | +378 | +241x |
- n_beta <- length(component(object, "beta_est"))+ if (identical(tmb_data$n_groups, 1L)) {
|
| 472 | -1x | +379 | +204x |
- m <- max(n_theta + 2, n_obs - n_beta)+ cov <- cov[[1]] |
| 473 | -1x | +|||
| 380 | +
- n_theta * (m / (m - n_theta - 1))+ } else {
|
|||
| 474 | -+ | |||
| 381 | +37x |
- }+ names(cov) <- levels(tmb_data$subject_groups) |
||
| 475 | +382 |
-
+ } |
||
| 476 | -44x | +383 | +241x |
- 2 * component(object, "neg_log_lik") + k * df+ return(cov) |
| 477 | +384 |
} |
||
| 478 | +385 | |||
| 479 | +386 |
- #' @describeIn mmrm_tmb_methods obtains the Bayesian Information Criterion,+ #' Build `TMB` Fit Result List |
||
| 480 | +387 |
- #' which is using the natural logarithm of the number of subjects for the+ #' |
||
| 481 | +388 |
- #' penalty parameter `k`.+ #' This helper does some simple post-processing of the `TMB` object and |
||
| 482 | +389 |
- #' @importFrom stats BIC+ #' optimization results, including setting names, inverting matrices etc. |
||
| 483 | +390 |
- #' @exportS3Method+ #' |
||
| 484 | +391 |
- #' @examples+ #' @param tmb_object (`list`)\cr created with [TMB::MakeADFun()]. |
||
| 485 | +392 |
- #' # BIC:+ #' @param tmb_opt (`list`)\cr optimization result. |
||
| 486 | +393 |
- #' BIC(object)+ #' @param formula_parts (`mmrm_tmb_formula_parts`)\cr produced by |
||
| 487 | +394 |
- BIC.mmrm_tmb <- function(object, ...) {
+ #' [h_mmrm_tmb_formula_parts()]. |
||
| 488 | +395 |
- # nolint+ #' @param tmb_data (`mmrm_tmb_data`)\cr produced by [h_mmrm_tmb_data()]. |
||
| 489 | -21x | +|||
| 396 | +
- k <- log(component(object, "n_subjects"))+ #' |
|||
| 490 | -21x | +|||
| 397 | +
- AIC(object, corrected = FALSE, k = k)+ #' @return List of class `mmrm_tmb` with: |
|||
| 491 | +398 |
- }+ #' - `cov`: estimated covariance matrix, or named list of estimated group specific covariance matrices. |
||
| 492 | +399 |
-
+ #' - `beta_est`: vector of coefficient estimates. |
||
| 493 | +400 |
-
+ #' - `beta_vcov`: Variance-covariance matrix for coefficient estimates. |
||
| 494 | +401 |
- #' @describeIn mmrm_tmb_methods prints the object.+ #' - `beta_vcov_inv_L`: Lower triangular matrix `L` of the inverse variance-covariance matrix decomposition. |
||
| 495 | +402 |
- #' @exportS3Method+ #' - `beta_vcov_inv_D`: vector of diagonal matrix `D` of the inverse variance-covariance matrix decomposition. |
||
| 496 | +403 |
- print.mmrm_tmb <- function(x,+ #' - `theta_est`: vector of variance parameter estimates. |
||
| 497 | +404 |
- ...) {
+ #' - `theta_vcov`: variance-covariance matrix for variance parameter estimates. |
||
| 498 | -2x | +|||
| 405 | +
- cat("mmrm fit\n\n")
+ #' - `neg_log_lik`: obtained negative log-likelihood. |
|||
| 499 | +406 |
-
+ #' - `formula_parts`: input. |
||
| 500 | -2x | +|||
| 407 | +
- h_print_call(+ #' - `data`: input. |
|||
| 501 | -2x | +|||
| 408 | +
- component(x, "call"), component(x, "n_obs"),+ #' - `weights`: input. |
|||
| 502 | -2x | +|||
| 409 | +
- component(x, "n_subjects"), component(x, "n_timepoints")+ #' - `reml`: input as a flag. |
|||
| 503 | +410 |
- )+ #' - `opt_details`: list with optimization details including convergence code. |
||
| 504 | -2x | +|||
| 411 | +
- h_print_cov(component(x, "cov_type"), component(x, "n_theta"), component(x, "n_groups"))+ #' - `tmb_object`: original `TMB` object created with [TMB::MakeADFun()]. |
|||
| 505 | +412 |
-
+ #' - `tmb_data`: input. |
||
| 506 | -2x | +|||
| 413 | +
- cat("Inference: ")
+ #' |
|||
| 507 | -2x | +|||
| 414 | +
- cat(ifelse(component(x, "reml"), "REML", "ML"))+ #' @details Instead of inverting or decomposing `beta_vcov`, it can be more efficient to use its robust |
|||
| 508 | -2x | +|||
| 415 | +
- cat("\n")
+ #' Cholesky decomposition `LDL^T`, therefore we return the corresponding two components `L` and `D` |
|||
| 509 | -2x | +|||
| 416 | +
- cat("Deviance: ")
+ #' as well since they have been available on the `C++` side already. |
|||
| 510 | -2x | +|||
| 417 | +
- cat(deviance(x))+ #' |
|||
| 511 | +418 |
-
+ #' @keywords internal |
||
| 512 | -2x | +|||
| 419 | +
- cat("\n\nCoefficients: ")
+ h_mmrm_tmb_fit <- function(tmb_object, |
|||
| 513 | -2x | +|||
| 420 | +
- n_singular_coefs <- sum(component(x, "beta_aliased"))+ tmb_opt, |
|||
| 514 | -2x | +|||
| 421 | +
- if (n_singular_coefs > 0) {
+ formula_parts,+ |
+ |||
| 422 | ++ |
+ tmb_data) {
|
||
| 515 | -1x | +423 | +239x |
- cat("(", n_singular_coefs, " not defined because of singularities)", sep = "")
+ assert_list(tmb_object) |
| 516 | -+ | |||
| 424 | +239x |
- }+ assert_subset(c("fn", "gr", "par", "he"), names(tmb_object))
|
||
| 517 | -2x | +425 | +239x |
- cat("\n")
+ assert_list(tmb_opt) |
| 518 | -2x | +426 | +239x |
- print(coef(x, complete = TRUE))+ assert_subset(c("par", "objective", "convergence", "message"), names(tmb_opt))
|
| 519 | -+ | |||
| 427 | +239x |
-
+ assert_class(formula_parts, "mmrm_tmb_formula_parts") |
||
| 520 | -2x | +428 | +239x |
- cat("\nModel Inference Optimization:")
+ assert_class(tmb_data, "mmrm_tmb_data") |
| 521 | +429 | |||
| 522 | -2x | +430 | +239x |
- cat(ifelse(component(x, "convergence") == 0, "\nConverged", "\nFailed to converge"))+ tmb_report <- tmb_object$report(par = tmb_opt$par) |
| 523 | -2x | +431 | +239x |
- cat(+ x_matrix_cols <- colnames(tmb_data$x_matrix) |
| 524 | -2x | +432 | +239x |
- " with code", component(x, "convergence"),+ cov <- h_mmrm_tmb_extract_cov(tmb_report, tmb_data, formula_parts$visit_var, formula_parts$is_spatial) |
| 525 | -2x | +433 | +239x |
- "and message:",+ beta_est <- tmb_report$beta |
| 526 | -2x | +434 | +239x |
- if (is.null(component(x, "conv_message"))) "No message provided." else tolower(component(x, "conv_message"))+ names(beta_est) <- x_matrix_cols |
| 527 | -+ | |||
| 435 | +239x |
- )+ beta_vcov <- tmb_report$beta_vcov |
||
| 528 | -2x | +436 | +239x |
- cat("\n")
+ dimnames(beta_vcov) <- list(x_matrix_cols, x_matrix_cols) |
| 529 | -2x | +437 | +239x |
- invisible(x)+ beta_vcov_inv_L <- tmb_report$XtWX_L # nolint |
| 530 | -+ | |||
| 438 | +239x |
- }+ beta_vcov_inv_D <- tmb_report$XtWX_D # nolint |
||
| 531 | -+ | |||
| 439 | +239x |
-
+ theta_est <- tmb_opt$par |
||
| 532 | -+ | |||
| 440 | +239x |
-
+ names(theta_est) <- NULL |
||
| 533 | -+ | |||
| 441 | +239x |
- #' @describeIn mmrm_tmb_methods to obtain residuals - either unscaled ('response'), 'pearson' or 'normalized'.
+ theta_vcov <- try(solve(tmb_object$he(tmb_opt$par)), silent = TRUE) |
||
| 534 | -+ | |||
| 442 | +239x |
- #' @param type (`string`)\cr unscaled (`response`), `pearson` or `normalized`. Default is `response`,+ opt_details_names <- setdiff( |
||
| 535 | -+ | |||
| 443 | +239x |
- #' and this is the only type available for use with models with a spatial covariance structure.+ names(tmb_opt), |
||
| 536 | -+ | |||
| 444 | +239x |
- #' @importFrom stats residuals+ c("par", "objective")
|
||
| 537 | +445 |
- #' @exportS3Method+ ) |
||
| 538 | -+ | |||
| 446 | +239x |
- #' @examples+ structure( |
||
| 539 | -+ | |||
| 447 | +239x |
- #' # residuals:+ list( |
||
| 540 | -+ | |||
| 448 | +239x |
- #' residuals(object, type = "response")+ cov = cov, |
||
| 541 | -+ | |||
| 449 | +239x |
- #' residuals(object, type = "pearson")+ beta_est = beta_est, |
||
| 542 | -+ | |||
| 450 | +239x |
- #' residuals(object, type = "normalized")+ beta_vcov = beta_vcov, |
||
| 543 | -+ | |||
| 451 | +239x |
- #' @references+ beta_vcov_inv_L = beta_vcov_inv_L, |
||
| 544 | -+ | |||
| 452 | +239x |
- #' - \insertRef{galecki2013linear}{mmrm}
+ beta_vcov_inv_D = beta_vcov_inv_D, |
||
| 545 | -+ | |||
| 453 | +239x |
- residuals.mmrm_tmb <- function(object, type = c("response", "pearson", "normalized"), ...) {
+ theta_est = theta_est, |
||
| 546 | -20x | +454 | +239x |
- type <- match.arg(type)+ theta_vcov = theta_vcov, |
| 547 | -20x | +455 | +239x |
- switch(type,+ neg_log_lik = tmb_opt$objective, |
| 548 | -8x | +456 | +239x |
- "response" = h_residuals_response(object),+ formula_parts = formula_parts, |
| 549 | -5x | +457 | +239x |
- "pearson" = h_residuals_pearson(object),+ data = tmb_data$data, |
| 550 | -7x | +458 | +239x |
- "normalized" = h_residuals_normalized(object)+ weights = tmb_data$weights_vector, |
| 551 | -+ | |||
| 459 | +239x |
- )+ reml = as.logical(tmb_data$reml), |
||
| 552 | -+ | |||
| 460 | +239x |
- }+ opt_details = tmb_opt[opt_details_names], |
||
| 553 | -+ | |||
| 461 | +239x |
- #' Calculate Pearson Residuals+ tmb_object = tmb_object, |
||
| 554 | -+ | |||
| 462 | +239x |
- #'+ tmb_data = tmb_data |
||
| 555 | +463 |
- #' This is used by [residuals.mmrm_tmb()] to calculate Pearson residuals.+ ), |
||
| 556 | -+ | |||
| 464 | +239x |
- #'+ class = "mmrm_tmb" |
||
| 557 | +465 |
- #' @param object (`mmrm_tmb`)\cr the fitted MMRM.+ ) |
||
| 558 | +466 |
- #'+ } |
||
| 559 | +467 |
- #' @return Vector of residuals.+ |
||
| 560 | +468 |
- #'+ #' Low-Level Fitting Function for MMRM |
||
| 561 | +469 |
- #' @keywords internal+ #' |
||
| 562 | +470 |
- h_residuals_pearson <- function(object) {
- |
- ||
| 563 | -6x | -
- assert_class(object, "mmrm_tmb")+ #' @description `r lifecycle::badge("stable")`
|
||
| 564 | -6x | +|||
| 471 | +
- h_residuals_response(object) * object$tmb_object$report()$diag_cov_inv_sqrt+ #' |
|||
| 565 | +472 |
- }+ #' This is the low-level function to fit an MMRM. Note that this does not |
||
| 566 | +473 |
-
+ #' try different optimizers or adds Jacobian information etc. in contrast to |
||
| 567 | +474 |
- #' Calculate normalized residuals+ #' [mmrm()]. |
||
| 568 | +475 |
#' |
||
| 569 | +476 |
- #' This is used by [residuals.mmrm_tmb()] to calculate normalized / scaled residuals.+ #' @param formula (`formula`)\cr model formula with exactly one special term |
||
| 570 | +477 |
- #'+ #' specifying the visits within subjects, see details. |
||
| 571 | +478 |
- #' @param object (`mmrm_tmb`)\cr the fitted MMRM.+ #' @param data (`data.frame`)\cr input data containing the variables used in |
||
| 572 | +479 |
- #'+ #' `formula`. |
||
| 573 | +480 |
- #' @return Vector of residuals+ #' @param weights (`vector`)\cr input vector containing the weights. |
||
| 574 | +481 |
- #'+ #' @inheritParams h_mmrm_tmb_data |
||
| 575 | +482 |
- #' @keywords internal+ #' @param covariance (`cov_struct`)\cr A covariance structure type definition, |
||
| 576 | +483 |
- h_residuals_normalized <- function(object) {
- |
- ||
| 577 | -8x | -
- assert_class(object, "mmrm_tmb")- |
- ||
| 578 | -8x | -
- object$tmb_object$report()$epsilonTilde+ #' or value that can be coerced to a covariance structure using |
||
| 579 | +484 |
- }+ #' [as.cov_struct()]. If no value is provided, a structure is derived from |
||
| 580 | +485 |
- #' Calculate response residuals.+ #' the provided formula. |
||
| 581 | +486 |
- #'+ #' @param control (`mmrm_control`)\cr list of control options produced by |
||
| 582 | +487 |
- #' This is used by [residuals.mmrm_tmb()] to calculate response residuals.+ #' [mmrm_control()]. |
||
| 583 | +488 |
- #'+ #' @inheritParams fit_single_optimizer |
||
| 584 | +489 |
- #' @param object (`mmrm_tmb`)\cr the fitted MMRM.+ #' |
||
| 585 | +490 |
- #'+ #' @return List of class `mmrm_tmb`, see [h_mmrm_tmb_fit()] for details. |
||
| 586 | +491 |
- #' @return Vector of residuals+ #' In addition, it contains elements `call` and `optimizer`. |
||
| 587 | +492 |
#' |
||
| 588 | +493 |
- #' @keywords internal+ #' @details |
||
| 589 | +494 |
- h_residuals_response <- function(object) {
+ #' The `formula` typically looks like: |
||
| 590 | -15x | +|||
| 495 | +
- assert_class(object, "mmrm_tmb")+ #' |
|||
| 591 | -15x | +|||
| 496 | +
- component(object, "y_vector") - unname(fitted(object))+ #' `FEV1 ~ RACE + SEX + ARMCD * AVISIT + us(AVISIT | USUBJID)` |
|||
| 592 | +497 |
- }+ #' |
||
| 593 | +498 |
-
+ #' which specifies response and covariates as usual, and exactly one special term |
||
| 594 | +499 |
- #' @describeIn mmrm_tmb_methods simulate responses from a fitted model according+ #' defines which covariance structure is used and what are the visit and |
||
| 595 | +500 |
- #' to the simulation `method`, returning a `data.frame` of dimension `[n, m]`+ #' subject variables. |
||
| 596 | +501 |
- #' where n is the number of rows in `newdata`,+ #' |
||
| 597 | +502 |
- #' and m is the number `nsim` of simulated responses.+ #' Always use only the first optimizer if multiple optimizers are provided. |
||
| 598 | +503 |
#' |
||
| 599 | +504 |
- #' @param seed unused argument from [stats::simulate()].+ #' @export |
||
| 600 | +505 |
- #' @param method (`string`)\cr simulation method to use. If "conditional",+ #' |
||
| 601 | +506 |
- #' simulated values are sampled given the estimated covariance matrix of `object`.+ #' @examples |
||
| 602 | +507 |
- #' If "marginal", the variance of the estimated covariance matrix is taken into account.+ #' formula <- FEV1 ~ RACE + SEX + ARMCD * AVISIT + us(AVISIT | USUBJID) |
||
| 603 | +508 |
- #'+ #' data <- fev_data |
||
| 604 | +509 |
- #' @importFrom stats simulate+ #' system.time(result <- fit_mmrm(formula, data, rep(1, nrow(fev_data)))) |
||
| 605 | +510 |
- #' @exportS3Method+ fit_mmrm <- function(formula, |
||
| 606 | +511 |
- simulate.mmrm_tmb <- function(object,+ data, |
||
| 607 | +512 |
- nsim = 1,+ weights, |
||
| 608 | +513 |
- seed = NULL,+ reml = TRUE, |
||
| 609 | +514 |
- newdata,+ covariance = NULL, |
||
| 610 | +515 |
- ...,+ tmb_data, |
||
| 611 | +516 |
- method = c("conditional", "marginal")) {
+ formula_parts, |
||
| 612 | -15x | +|||
| 517 | +
- assert_count(nsim, positive = TRUE)+ control = mmrm_control()) {
|
|||
| 613 | -15x | +518 | +252x |
- assert_null(seed)+ if (missing(formula_parts) || missing(tmb_data)) {
|
| 614 | -15x | +519 | +67x |
- if (missing(newdata)) {
+ covariance <- h_reconcile_cov_struct(formula, covariance) |
| 615 | -12x | +520 | +65x |
- newdata <- object$data+ formula_parts <- h_mmrm_tmb_formula_parts(formula, covariance) |
| 616 | +521 |
- }+ |
||
| 617 | -15x | +522 | +65x |
- assert_data_frame(newdata)+ if (!formula_parts$is_spatial && !is.factor(data[[formula_parts$visit_var]])) {
|
| 618 | -15x | +523 | +1x |
- method <- match.arg(method)+ stop("Time variable must be a factor for non-spatial covariance structures")
|
| 619 | +524 |
-
+ } |
||
| 620 | +525 | |||
| 621 | -15x | +526 | +64x |
- tmb_data <- h_mmrm_tmb_data(+ assert_class(control, "mmrm_control") |
| 622 | -15x | +527 | +64x |
- object$formula_parts, newdata,+ assert_list(control$optimizers, min.len = 1) |
| 623 | -15x | +528 | +64x |
- weights = rep(1, nrow(newdata)),+ assert_numeric(weights, any.missing = FALSE) |
| 624 | -15x | -
- reml = TRUE,- |
- ||
| 625 | -15x | -
- singular = "keep",- |
- ||
| 626 | -15x | -
- drop_visit_levels = FALSE,- |
- ||
| 627 | -15x | +529 | +64x |
- allow_na_response = TRUE,+ assert_true(all(weights > 0)) |
| 628 | -15x | +530 | +64x |
- drop_levels = FALSE,+ tmb_data <- h_mmrm_tmb_data( |
| 629 | -15x | +531 | +64x |
- xlev = component(object, "xlev"),+ formula_parts, data, weights, reml, |
| 630 | -15x | +532 | +64x |
- contrasts = component(object, "contrasts")+ singular = if (control$accept_singular) "drop" else "error", drop_visit_levels = control$drop_visit_levels |
| 631 | +533 |
- )- |
- ||
| 632 | -15x | -
- ret <- if (method == "conditional") {
- |
- ||
| 633 | -8x | -
- predict_res <- h_get_prediction(tmb_data, object$theta_est, object$beta_est, object$beta_vcov)- |
- ||
| 634 | -8x | -
- as.data.frame(h_get_sim_per_subj(predict_res, tmb_data$n_subjects, nsim))- |
- ||
| 635 | -15x | -
- } else if (method == "marginal") {
- |
- ||
| 636 | -7x | -
- theta_chol <- t(chol(object$theta_vcov))- |
- ||
| 637 | -7x | -
- n_theta <- length(object$theta_est)+ ) |
||
| 638 | -7x | +|||
| 534 | +
- as.data.frame(+ } else {
|
|||
| 639 | -7x | +535 | +185x |
- sapply(seq_len(nsim), function(x) {
+ assert_class(tmb_data, "mmrm_tmb_data") |
| 640 | -503x | +536 | +185x |
- newtheta <- object$theta_est + theta_chol %*% matrix(stats::rnorm(n_theta), ncol = 1)+ assert_class(formula_parts, "mmrm_tmb_formula_parts") |
| 641 | +537 |
- # Recalculate betas with sampled thetas.+ } |
||
| 642 | -503x | -
- hold <- object$tmb_object$report(newtheta)- |
- ||
| 643 | -+ | 538 | +249x |
- # Resample betas given new beta distribution.+ tmb_parameters <- h_mmrm_tmb_parameters(formula_parts, tmb_data, start = control$start, n_groups = tmb_data$n_groups) |
| 644 | +539 |
- # We first solve L^\top w = D^{-1/2}z_{sample}:
+
|
||
| 645 | -503x | +540 | +246x |
- w_sample <- backsolve(+ tmb_object <- TMB::MakeADFun( |
| 646 | -503x | +541 | +246x |
- r = hold$XtWX_L,+ data = tmb_data, |
| 647 | -503x | +542 | +246x |
- x = stats::rnorm(length(hold$beta)) / sqrt(hold$XtWX_D),+ parameters = tmb_parameters, |
| 648 | -503x | +543 | +246x |
- upper.tri = FALSE,+ hessian = TRUE, |
| 649 | -503x | +544 | +246x |
- transpose = TRUE+ DLL = "mmrm", |
| 650 | -+ | |||
| 545 | +246x |
- )+ silent = TRUE |
||
| 651 | +546 |
- # Then we add the mean vector, the beta estimate.+ ) |
||
| 652 | -503x | +547 | +246x |
- beta_sample <- hold$beta + w_sample+ h_mmrm_tmb_assert_start(tmb_object) |
| 653 | -503x | +548 | +246x |
- predict_res <- h_get_prediction(tmb_data, newtheta, beta_sample, hold$beta_vcov)+ used_optimizer <- control$optimizers[[1L]] |
| 654 | -503x | -
- h_get_sim_per_subj(predict_res, tmb_data$n_subjects, 1L)- |
- ||
| 655 | -- |
- })- |
- ||
| 656 | -- |
- )- |
- ||
| 657 | -+ | 549 | +246x |
- }+ used_optimizer_name <- names(control$optimizers)[1L] |
| 658 | -15x | +550 | +246x |
- orig_row_names <- row.names(newdata)+ args <- with( |
| 659 | -15x | +551 | +246x |
- new_order <- match(orig_row_names, row.names(tmb_data$full_frame))+ tmb_object, |
| 660 | -15x | -
- ret[new_order, , drop = FALSE]- |
- ||
| 661 | -- |
- }- |
- ||
| 662 | -- | - - | -||
| 663 | -- |
- #' Get simulated values by patient.- |
- ||
| 664 | -- |
- #'- |
- ||
| 665 | -- |
- #' @param predict_res (`list`)\cr from [h_get_prediction()].- |
- ||
| 666 | -+ | 552 | +246x |
- #' @param nsub (`count`)\cr number of subjects.+ c( |
| 667 | -+ | |||
| 553 | +246x |
- #' @param nsim (`count`)\cr number of values to simulate.+ list(par, fn, gr), |
||
| 668 | -+ | |||
| 554 | +246x |
- #'+ attr(used_optimizer, "args") |
||
| 669 | +555 |
- #' @keywords internal+ ) |
||
| 670 | +556 |
- h_get_sim_per_subj <- function(predict_res, nsub, nsim) {
- |
- ||
| 671 | -517x | -
- assert_list(predict_res)+ ) |
||
| 672 | -517x | +557 | +246x |
- assert_count(nsub, positive = TRUE)+ if (identical(attr(used_optimizer, "use_hessian"), TRUE)) {
|
| 673 | -516x | +558 | +8x |
- assert_count(nsim, positive = TRUE)+ args$hessian <- tmb_object$he |
| 674 | +559 | - - | -||
| 675 | -515x | -
- ret <- matrix(+ } |
||
| 676 | -515x | +560 | +246x |
- predict_res$prediction[, "fit"],+ tmb_opt <- do.call( |
| 677 | -515x | +561 | +246x |
- ncol = nsim,+ what = used_optimizer, |
| 678 | -515x | +562 | +246x |
- nrow = nrow(predict_res$prediction)+ args = args |
| 679 | +563 |
) |
||
| 680 | -515x | -
- for (i in seq_len(nsub)) {
- |
- ||
| 681 | +564 |
- # Skip subjects which are not included in predict_res.+ # Ensure negative log likelihood is stored in `objective` element of list. |
||
| 682 | -82699x | -
- if (length(predict_res$index[[i]]) > 0) {
- |
- ||
| 683 | -- |
- # Obtain indices of data.frame belonging to subject i- |
- ||
| 684 | -+ | 565 | +237x |
- # (increment by 1, since indices from cpp are 0-order).+ if ("value" %in% names(tmb_opt)) {
|
| 685 | -66631x | +566 | +227x |
- inds <- predict_res$index[[i]] + 1+ tmb_opt$objective <- tmb_opt$value |
| 686 | -66631x | -
- obs <- length(inds)- |
- ||
| 687 | -+ | 567 | +227x |
-
+ tmb_opt$value <- NULL |
| 688 | +568 |
- # Get relevant covariance matrix for subject i.+ } |
||
| 689 | -66631x | +569 | +237x |
- covmat_i <- predict_res$covariance[[i]]+ fit <- h_mmrm_tmb_fit(tmb_object, tmb_opt, formula_parts, tmb_data) |
| 690 | -66631x | -
- theta_chol <- t(chol(covmat_i))- |
- ||
| 691 | -- | - - | -||
| 692 | -+ | 570 | +237x |
- # Simulate epsilon from covariance matrix.+ h_mmrm_tmb_check_conv(tmb_opt, fit) |
| 693 | -66631x | +571 | +237x |
- mus <- ret[inds, , drop = FALSE]+ fit$call <- match.call() |
| 694 | -66631x | +572 | +237x |
- epsilons <- theta_chol %*% matrix(stats::rnorm(nsim * obs), ncol = nsim)+ fit$call$formula <- formula_parts$formula |
| 695 | -66631x | -
- ret[inds, ] <- mus + epsilons- |
- ||
| 696 | -- |
- }- |
- ||
| 697 | -- |
- }- |
- ||
| 698 | -+ | 573 | +237x |
-
+ fit$optimizer <- used_optimizer_name |
| 699 | -515x | +574 | +237x |
- ret+ fit |
| 700 | +575 |
}@@ -13163,14 +12820,14 @@ mmrm coverage - 97.05% |
| 1 |
- #' Processing the Formula for `TMB` Fit+ #' Tidying Methods for `mmrm` Objects |
||
| 3 |
- #' @param formula (`formula`)\cr Original formula.+ #' @description `r lifecycle::badge("stable")`
|
||
| 4 |
- #' @param covariance (`cov_struct`)\cr A covariance structure from which+ #' |
||
| 5 |
- #' additional formula parts should be added.+ #' These methods tidy the estimates from an `mmrm` object into a |
||
| 6 |
- #'+ #' summary. |
||
| 7 |
- #' @return List of class `mmrm_tmb_formula_parts` with elements:+ #' |
||
| 8 |
- #'+ #' @param x (`mmrm`)\cr fitted model. |
||
| 9 |
- #' - `formula`: the original input.+ #' @param conf.int (`flag`)\cr if `TRUE` columns for the lower (`conf.low`) and upper bounds |
||
| 10 |
- #' - `model_formula`: `formula` with the covariance term is removed.+ #' (`conf.high`) of coefficient estimates are included. |
||
| 11 |
- #' - `model_formula`: `formula` with the covariance term removed.+ #' @param conf.level (`number`)\cr defines the range of the optional confidence internal. |
||
| 12 |
- #' - `full_formula`: same as `model_formula` but includes the covariance+ #' @param newdata (`data.frame` or `NULL`)\cr optional new data frame. |
||
| 13 |
- #' structure's subject, visit and (optionally) group variables.+ #' @param se_fit (`flag`)\cr whether to return standard errors of fit. |
||
| 14 |
- #' - `cov_type`: `string` with covariance term type (e.g. `"us"`).+ #' @param interval (`string`)\cr type of interval calculation. |
||
| 15 |
- #' - `is_spatial`: `flag` indicator of whether the covariance structure is+ #' @param type.residuals (`string`)\cr passed on to [residuals.mmrm_tmb()]. |
||
| 16 |
- #' spatial+ #' @param ... only used by `augment()` to pass arguments to the [predict.mmrm_tmb()] method. |
||
| 17 |
- #' - `visit_var`: `character` with the visit variable name.+ #' |
||
| 18 |
- #' - `subject_var`: `string` with the subject variable name.+ #' @name mmrm_tidiers |
||
| 19 |
- #' - `group_var`: `string` with the group variable name. If no group specified,+ #' @aliases mmrm_tidiers |
||
| 20 |
- #' this element is `NULL`.+ #' |
||
| 21 |
- #' - `model_var`: `character` with the variables names of the formula, except `subject_var`.+ #' @seealso [`mmrm_methods`], [`mmrm_tmb_methods`] for additional methods. |
||
| 23 |
- #' @keywords internal+ #' @examples |
||
| 24 |
- h_mmrm_tmb_formula_parts <- function(+ #' fit <- mmrm( |
||
| 25 |
- formula,+ #' formula = FEV1 ~ RACE + SEX + ARMCD * AVISIT + us(AVISIT | USUBJID), |
||
| 26 |
- covariance = as.cov_struct(formula, warn_partial = FALSE)) {
+ #' data = fev_data |
||
| 27 | -270x | +
- assert_formula(formula)+ #' ) |
|
| 28 | -270x | +
- assert_true(identical(length(formula), 3L))+ NULL |
|
| 30 | -270x | +
- model_formula <- h_drop_covariance_terms(formula)+ #' @describeIn mmrm_tidiers derives tidy `tibble` from an `mmrm` object. |
|
| 31 |
-
+ #' @exportS3Method |
||
| 32 | -270x | +
- structure(+ #' @examples |
|
| 33 | -270x | +
- list(+ #' # Applying tidy method to return summary table of covariate estimates. |
|
| 34 | -270x | +
- formula = formula,+ #' fit |> tidy() |
|
| 35 | -270x | +
- model_formula = model_formula,+ #' fit |> tidy(conf.int = TRUE, conf.level = 0.9) |
|
| 36 | -270x | +
- full_formula = h_add_covariance_terms(model_formula, covariance),+ tidy.mmrm <- function(x, # nolint |
|
| 37 | -270x | +
- cov_type = tmb_cov_type(covariance),+ conf.int = FALSE, # nolint |
|
| 38 | -270x | +
- is_spatial = covariance$type == "sp_exp",+ conf.level = 0.95, # nolint |
|
| 39 | -270x | +
- visit_var = covariance$visits,+ ...) {
|
|
| 40 | -270x | +5x |
- subject_var = covariance$subject,+ assert_flag(conf.int) |
| 41 | -270x | +5x |
- group_var = if (length(covariance$group) < 1) NULL else covariance$group,+ assert_number(conf.level, lower = 0, upper = 1) |
| 42 | -270x | +5x |
- model_var = setdiff(all.vars(formula[[3]]), covariance$subject)+ tbl <- tibble::as_tibble(summary(x)$coefficients, rownames = "term") |
| 43 | -+ | 5x |
- ),+ colnames(tbl) <- c("term", "estimate", "std.error", "df", "statistic", "p.value")
|
| 44 | -270x | +5x |
- class = "mmrm_tmb_formula_parts"+ 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"))
|
| 48 |
- #' Data for `TMB` Fit+ } |
||
| 49 | -+ | 5x |
- #'+ if (conf.int) {
|
| 50 | -+ | 4x |
- #' @param formula_parts (`mmrm_tmb_formula_parts`)\cr list with formula parts+ ci <- h_tbl_confint_terms(x, level = conf.level) |
| 51 | -+ | 4x |
- #' from [h_mmrm_tmb_formula_parts()].+ tbl <- tibble::as_tibble(merge(tbl, ci, by = "term")) |
| 52 |
- #' @param data (`data.frame`)\cr which contains variables used in `formula_parts`.+ } |
||
| 53 | -+ | 5x |
- #' @param weights (`vector`)\cr weights to be used in the fitting process.+ tbl |
| 54 |
- #' @param reml (`flag`)\cr whether restricted maximum likelihood (REML) estimation is used,+ } |
||
| 55 |
- #' otherwise maximum likelihood (ML) is used.+ |
||
| 56 |
- #' @param singular (`string`)\cr choices of method deal with rank-deficient matrices. "error" to+ #' @describeIn mmrm_tidiers derives `glance` `tibble` from an `mmrm` object. |
||
| 57 |
- #' stop the function return the error, "drop" to drop these columns, and "keep" to keep all the columns.+ #' @exportS3Method |
||
| 58 |
- #' @param drop_visit_levels (`flag`)\cr whether to drop levels for visit variable, if visit variable is a factor.+ #' @examples |
||
| 59 |
- #' @param allow_na_response (`flag`)\cr whether NA in response is allowed.+ #' # Applying glance method to return summary table of goodness of fit statistics. |
||
| 60 |
- #' @param drop_levels (`flag`)\cr whether drop levels for covariates. If not dropped could lead to singular matrix.+ #' fit |> glance() |
||
| 61 |
- #'+ glance.mmrm <- function(x, ...) { # nolint
|
||
| 62 | -+ | 1x |
- #' @return List of class `mmrm_tmb_data` with elements:+ tibble::as_tibble(summary(x)$aic_list) |
| 63 |
- #' - `full_frame`: `data.frame` with `n` rows containing all variables needed in the model.+ } |
||
| 64 |
- #' - `data`: `data.frame` of input dataset.+ |
||
| 65 |
- #' - `x_matrix`: `matrix` with `n` rows and `p` columns specifying the overall design matrix.+ #' @describeIn mmrm_tidiers derives `augment` `tibble` from an `mmrm` object. |
||
| 66 |
- #' - `x_cols_aliased`: `logical` with potentially more than `p` elements indicating which+ #' @exportS3Method |
||
| 67 |
- #' columns in the original design matrix have been left out to obtain a full rank+ #' @examples |
||
| 68 |
- #' `x_matrix`.+ #' # Applying augment method to return merged `tibble` of model data, fitted and residuals. |
||
| 69 |
- #' - `y_vector`: length `n` `numeric` specifying the overall response vector.+ #' fit |> augment() |
||
| 70 |
- #' - `weights_vector`: length `n` `numeric` specifying the weights vector.+ #' fit |> augment(interval = "confidence") |
||
| 71 |
- #' - `n_visits`: `int` with the number of visits, which is the dimension of the+ #' fit |> augment(type.residuals = "pearson") |
||
| 72 |
- #' covariance matrix.+ augment.mmrm <- function(x, # nolint |
||
| 73 |
- #' - `n_subjects`: `int` with the number of subjects.+ newdata = NULL, |
||
| 74 |
- #' - `subject_zero_inds`: length `n_subjects` `integer` containing the zero-based start+ interval = c("none", "confidence", "prediction"),
|
||
| 75 |
- #' indices for each subject.+ se_fit = (interval != "none"), |
||
| 76 |
- #' - `subject_n_visits`: length `n_subjects` `integer` containing the number of+ type.residuals = c("response", "pearson", "normalized"), # nolint
|
||
| 77 |
- #' observed visits for each subjects. So the sum of this vector equals `n`.+ ...) {
|
||
| 78 | -+ | 9x |
- #' - `cov_type`: `string` value specifying the covariance type.+ type.residuals <- match.arg(type.residuals) # nolint |
| 79 | -+ | 9x |
- #' - `is_spatial_int`: `int` specifying whether the covariance structure is spatial(1) or not(0).+ resid_df <- NULL |
| 80 | -+ | 9x |
- #' - `reml`: `int` specifying whether REML estimation is used (1), otherwise ML (0).+ if (is.null(newdata)) {
|
| 81 | -+ | 4x |
- #' - `subject_groups`: `factor` specifying the grouping for each subject.+ newdata <- stats::get_all_vars(x, data = stats::na.omit(x$data)) |
| 82 | -+ | 4x |
- #' - `n_groups`: `int` with the number of total groups+ resid_df <- data.frame( |
| 83 | -+ | 4x |
- #'+ .rownames = rownames(newdata), |
| 84 | -+ | 4x |
- #' @details Note that the `subject_var` must not be factor but can also be character.+ .resid = unname(residuals(x, type = type.residuals)) |
| 85 |
- #' If it is character, then it will be converted to factor internally. Here+ ) |
||
| 86 |
- #' the levels will be the unique values, sorted alphabetically and numerically if there+ } |
||
| 87 | -+ | 9x |
- #' is a common string prefix of numbers in the character elements. For full control+ interval <- match.arg(interval) |
| 88 |
- #' on the order please use a factor.+ |
||
| 89 | -+ | 9x |
- #'+ tbl <- h_newdata_add_pred( |
| 90 | -+ | 9x |
- #' @keywords internal+ x, |
| 91 | -+ | 9x |
- h_mmrm_tmb_data <- function(formula_parts,+ newdata = newdata, |
| 92 | -+ | 9x |
- data,+ se_fit = se_fit, |
| 93 | -+ | 9x |
- weights,+ interval = interval, |
| 94 |
- reml,+ ... |
||
| 95 |
- singular = c("drop", "error", "keep"),
+ ) |
||
| 96 | -+ | 9x |
- drop_visit_levels,+ if (!is.null(resid_df)) {
|
| 97 | -+ | 4x |
- allow_na_response = FALSE,+ tbl <- merge(tbl, resid_df, by = ".rownames") |
| 98 | -+ | 4x |
- drop_levels = TRUE,+ tbl$.rownames <- as.numeric(tbl$.rownames) |
| 99 | -+ | 4x |
- xlev = NULL,+ tbl <- tbl[order(tbl$.rownames), , drop = FALSE] |
| 100 |
- contrasts = NULL) {
+ } |
||
| 101 | -312x | +9x |
- assert_class(formula_parts, "mmrm_tmb_formula_parts")+ tibble::as_tibble(tbl) |
| 102 | -312x | +
- assert_data_frame(data)+ } |
|
| 103 | -312x | +
- varname <- formula_parts[grepl("_var", names(formula_parts))]
+
|
|
| 104 | -312x | +
- assert_names(+ #' Extract `tibble` with Confidence Intervals and Term Names |
|
| 105 | -312x | +
- names(data),+ #' |
|
| 106 | -312x | +
- must.include = unlist(varname, use.names = FALSE)+ #' This is used in [tidy.mmrm()]. |
|
| 107 |
- )+ #' |
||
| 108 | -312x | +
- assert_true(is.factor(data[[formula_parts$subject_var]]) || is.character(data[[formula_parts$subject_var]]))+ #' @param x (`mmrm`)\cr fit object. |
|
| 109 | -312x | +
- assert_numeric(weights, len = nrow(data))+ #' @param ... passed to [stats::confint()], hence not used at the moment. |
|
| 110 | -312x | +
- assert_flag(reml)+ #' |
|
| 111 | -312x | +
- singular <- match.arg(singular)+ #' @return A `tibble` with `term`, `conf.low`, `conf.high` columns. |
|
| 112 | -312x | +
- assert_flag(drop_visit_levels)+ #' |
|
| 113 |
-
+ #' @keywords internal |
||
| 114 | -312x | +
- if (is.character(data[[formula_parts$subject_var]])) {
+ h_tbl_confint_terms <- function(x, ...) {
|
|
| 115 | -5x | +8x |
- data[[formula_parts$subject_var]] <- factor(+ df <- stats::confint(x, ...) |
| 116 | -5x | +8x |
- data[[formula_parts$subject_var]],+ tbl <- tibble::as_tibble(df, rownames = "term", .name_repair = "minimal") |
| 117 | -5x | +8x |
- levels = stringr::str_sort(unique(data[[formula_parts$subject_var]]), numeric = TRUE)+ names(tbl) <- c("term", "conf.low", "conf.high")
|
| 118 | -+ | 8x |
- )+ tbl |
| 119 |
- }+ } |
||
| 120 | -312x | +
- data_order <- if (formula_parts$is_spatial) {
+
|
|
| 121 | -16x | +
- order(data[[formula_parts$subject_var]])+ #' Add Prediction Results to New Data |
|
| 122 |
- } else {
+ #' |
||
| 123 | -296x | +
- subject_visit_data <- data[, c(formula_parts$subject_var, formula_parts$visit_var)]+ #' This is used in [augment.mmrm()]. |
|
| 124 | -296x | +
- is_duplicated <- duplicated(subject_visit_data)+ #' |
|
| 125 | -296x | +
- if (any(is_duplicated)) {
+ #' @param x (`mmrm`)\cr fit. |
|
| 126 | -1x | +
- stop(+ #' @param newdata (`data.frame`)\cr data to predict. |
|
| 127 | -1x | +
- "time points have to be unique for each subject, detected following duplicates in data:\n",+ #' @param se_fit (`flag`)\cr whether to return standard error of prediction, |
|
| 128 | -1x | +
- paste(utils::capture.output(print(subject_visit_data[is_duplicated, ])), collapse = "\n")+ #' can only be used when `interval` is not "none". |
|
| 129 |
- )+ #' @param interval (`string`)\cr type of interval. |
||
| 130 |
- }+ #' @param ... passed to [predict.mmrm_tmb()]. |
||
| 131 | -295x | +
- order(data[[formula_parts$subject_var]], data[[formula_parts$visit_var]])+ #' |
|
| 132 |
- }+ #' @return The `newdata` as a `tibble` with additional columns `.fitted`, |
||
| 133 | -311x | +
- if (identical(formula_parts$is_spatial, FALSE)) {
+ #' `.lower`, `.upper` (if interval is not `none`) and `.se.fit` (if `se_fit` |
|
| 134 | -295x | +
- h_confirm_large_levels(length(levels(data[[formula_parts$visit_var]])))+ #' requested). |
|
| 135 |
- }+ #' |
||
| 136 | -310x | +
- data <- data[data_order, ]+ #' @keywords internal |
|
| 137 | -310x | +
- weights <- weights[data_order]+ h_newdata_add_pred <- function(x, |
|
| 138 | -310x | +
- data <- data.frame(data, weights)+ newdata, |
|
| 139 |
- # Weights is always the last column.+ se_fit, |
||
| 140 | -310x | +
- weights_name <- colnames(data)[ncol(data)]+ interval, |
|
| 141 |
- # If `y` is allowed to be NA, then first replace y with 1:n, then replace it with original y.+ ...) {
|
||
| 142 | -310x | +13x |
- if (!allow_na_response) {
+ assert_class(x, "mmrm") |
| 143 | -260x | +13x |
- h_warn_na_action()+ assert_data_frame(newdata) |
| 144 | -+ | 13x |
- }+ assert_flag(se_fit) |
| 145 | -310x | +13x |
- full_frame <- eval(+ assert_string(interval) |
| 146 | -310x | +13x |
- bquote(stats::model.frame(+ if (interval == "none") {
|
| 147 | -310x | +7x |
- formula_parts$full_formula,+ assert_false(se_fit) |
| 148 | -310x | +
- data = data,+ } |
|
| 149 | -310x | +
- weights = .(as.symbol(weights_name)),+ |
|
| 150 | -310x | +12x |
- na.action = "na.pass",+ tbl <- h_df_to_tibble(newdata) |
| 151 | -310x | +12x |
- xlev = xlev+ pred_results <- predict( |
| 152 | -+ | 12x |
- ))+ x, |
| 153 | -+ | 12x |
- )+ newdata = newdata, |
| 154 | -310x | +12x |
- if (drop_levels) {
+ na.action = stats::na.pass, |
| 155 | -262x | +12x |
- full_frame <- h_drop_levels(full_frame, formula_parts$subject_var, formula_parts$visit_var, names(xlev))+ se.fit = se_fit, |
| 156 | -+ | 12x |
- }+ interval = interval, |
| 157 | -310x | +
- has_response <- !identical(attr(attr(full_frame, "terms"), "response"), 0L)+ ... |
|
| 158 | -310x | +
- keep_ind <- if (allow_na_response && has_response) {
+ ) |
|
| 159 | -+ | 12x |
- # Note that response is always the first column if there is response.+ if (interval == "none") {
|
| 160 | -50x | +6x |
- stats::complete.cases(full_frame[, -1L, drop = FALSE])+ assert_numeric(pred_results) |
| 161 | -+ | 6x |
- } else {
+ tbl$.fitted <- unname(pred_results) |
| 162 | -260x | +
- stats::complete.cases(full_frame)+ } else {
|
|
| 163 | -+ | 6x |
- }+ assert_matrix(pred_results) |
| 164 | -310x | +6x |
- full_frame <- full_frame[keep_ind, ]+ tbl$.fitted <- unname(pred_results[, "fit"]) |
| 165 | -310x | +6x |
- if (drop_visit_levels && !formula_parts$is_spatial && h_extra_levels(full_frame[[formula_parts$visit_var]])) {
+ tbl$.lower <- unname(pred_results[, "lwr"]) |
| 166 | -3x | +6x |
- visit_vec <- full_frame[[formula_parts$visit_var]]+ tbl$.upper <- unname(pred_results[, "upr"]) |
| 167 | -3x | +
- old_levels <- levels(visit_vec)+ } |
|
| 168 | -3x | +12x |
- full_frame[[formula_parts$visit_var]] <- droplevels(visit_vec)+ if (se_fit) {
|
| 169 | -3x | +5x |
- new_levels <- levels(full_frame[[formula_parts$visit_var]])+ tbl$.se.fit <- unname(pred_results[, "se"]) |
| 170 | -3x | +
- dropped <- setdiff(old_levels, new_levels)+ } |
|
| 171 | -3x | +12x |
- message(+ tbl |
| 172 | -3x | +
- "In ", formula_parts$visit_var, " there are dropped visits: ", toString(dropped),+ } |
|
| 173 | -3x | +
- ".\n Additional attributes including contrasts are lost.\n",+ |
|
| 174 | -3x | +
- "To avoid this behavior, make sure use `drop_visit_levels = FALSE`."+ #' Coerce a Data Frame to a `tibble` |
|
| 175 |
- )+ #' |
||
| 176 |
- }+ #' This is used in [h_newdata_add_pred()]. |
||
| 177 | -310x | +
- is_factor_col <- vapply(full_frame, is.factor, FUN.VALUE = TRUE)+ #' |
|
| 178 | -310x | +
- is_factor_col <- intersect(names(is_factor_col)[is_factor_col], all.vars(formula_parts$model_formula))+ #' @details This is only a thin wrapper around [tibble::as_tibble()], except |
|
| 179 | -310x | +
- x_matrix <- stats::model.matrix(+ #' giving a useful error message and it checks for `rownames` and adds them |
|
| 180 | -310x | +
- formula_parts$model_formula,+ #' as a new column `.rownames` if they are not just a numeric sequence as |
|
| 181 | -310x | +
- data = full_frame,+ #' per the [tibble::has_rownames()] decision. |
|
| 182 | -310x | +
- contrasts.arg = h_default_value(contrasts, lapply(full_frame[is_factor_col], contrasts))+ #' |
|
| 183 |
- )+ #' @param data (`data.frame`)\cr what to coerce. |
||
| 184 | -309x | +
- x_cols_aliased <- stats::setNames(rep(FALSE, ncol(x_matrix)), nm = colnames(x_matrix))+ #' |
|
| 185 | -309x | +
- qr_x_mat <- qr(x_matrix)+ #' @return The `data` as a `tibble`, potentially with a `.rownames` column. |
|
| 186 | -309x | +
- if (qr_x_mat$rank < ncol(x_matrix)) {
+ #' |
|
| 187 | -23x | +
- cols_to_drop <- utils::tail(qr_x_mat$pivot, ncol(x_matrix) - qr_x_mat$rank)+ #' @keywords internal |
|
| 188 | -23x | +
- if (identical(singular, "error")) {
+ h_df_to_tibble <- function(data) {
|
|
| 189 | -1x | +15x |
- stop(+ tryCatch(tbl <- tibble::as_tibble(data), error = function(cnd) {
|
| 190 | 1x |
- "design matrix only has rank ", qr_x_mat$rank, " and ", length(cols_to_drop),+ stop("Could not coerce data to `tibble`. Try explicitly passing a",
|
|
| 191 | 1x |
- " columns (", toString(colnames(x_matrix)[cols_to_drop]), ") could be dropped",
+ "dataset to either the `data` or `newdata` argument.", |
|
| 192 | 1x |
- " to achieve full rank ", ncol(x_matrix), " by using `accept_singular = TRUE`"+ call. = FALSE |
|
| 193 |
- )+ ) |
||
| 194 | -22x | +
- } else if (identical(singular, "drop")) {
+ }) |
|
| 195 | -11x | +14x |
- assign_attr <- attr(x_matrix, "assign")+ if (tibble::has_rownames(data)) {
|
| 196 | -11x | +5x |
- contrasts_attr <- attr(x_matrix, "contrasts")+ tbl <- tibble::add_column(tbl, .rownames = rownames(data), .before = TRUE) |
| 197 | -11x | +
- x_matrix <- x_matrix[, -cols_to_drop, drop = FALSE]+ } |
|
| 198 | -11x | +14x |
- x_cols_aliased[cols_to_drop] <- TRUE+ tbl |
| 199 | -11x | +
- attr(x_matrix, "assign") <- assign_attr[-cols_to_drop]+ } |
|
| 200 | -11x | +
| 1 | +
- attr(x_matrix, "contrasts") <- contrasts_attr+ #' Support for `emmeans` |
|||
| 201 | +2 |
- }+ #' |
||
| 202 | +3 |
- }+ #' @description `r lifecycle::badge("stable")`
|
||
| 203 | -308x | +|||
| 4 | +
- y_vector <- if (has_response) {
+ #' |
|||
| 204 | -308x | +|||
| 5 | +
- as.numeric(stats::model.response(full_frame))+ #' This package includes methods that allow `mmrm` objects to be used |
|||
| 205 | +6 |
- } else {
+ #' with the `emmeans` package. `emmeans` computes estimated marginal means |
||
| 206 | -! | +|||
| 7 | +
- rep(NA_real_, nrow(full_frame))+ #' (also called least-square means) for the coefficients of the MMRM. |
|||
| 207 | +8 |
- }+ #' We can also e.g. obtain differences between groups by applying |
||
| 208 | -308x | +|||
| 9 | +
- weights_vector <- as.numeric(stats::model.weights(full_frame))+ #' [`pairs()`][emmeans::pairs.emmGrid()] on the object returned |
|||
| 209 | -308x | +|||
| 10 | +
- n_subjects <- length(unique(full_frame[[formula_parts$subject_var]]))+ #' by [emmeans::emmeans()]. |
|||
| 210 | -308x | +|||
| 11 | +
- subject_zero_inds <- which(!duplicated(full_frame[[formula_parts$subject_var]])) - 1L+ #' |
|||
| 211 | -308x | +|||
| 12 | +
- subject_n_visits <- c(utils::tail(subject_zero_inds, -1L), nrow(full_frame)) - subject_zero_inds+ #' @examples |
|||
| 212 | +13 |
- # It is possible that `subject_var` is factor with more levels (and this does not affect fit)+ #' fit <- mmrm( |
||
| 213 | +14 |
- # so no check is needed for `subject_visits`.+ #' formula = FEV1 ~ RACE + SEX + ARMCD * AVISIT + us(AVISIT | USUBJID), |
||
| 214 | -308x | +|||
| 15 | +
- assert_true(all(subject_n_visits > 0))+ #' data = fev_data |
|||
| 215 | -308x | +|||
| 16 | +
- if (!is.null(formula_parts$group_var)) {
+ #' ) |
|||
| 216 | -41x | +|||
| 17 | +
- assert_factor(data[[formula_parts$group_var]])+ #' if (require(emmeans)) {
|
|||
| 217 | -41x | +|||
| 18 | +
- subject_groups <- full_frame[[formula_parts$group_var]][subject_zero_inds + 1L]+ #' emmeans(fit, ~ ARMCD | AVISIT) |
|||
| 218 | -41x | +|||
| 19 | +
- n_groups <- nlevels(subject_groups)+ #' pairs(emmeans(fit, ~ ARMCD | AVISIT), reverse = TRUE) |
|||
| 219 | +20 |
- } else {
+ #' } |
||
| 220 | -267x | +|||
| 21 | +
- subject_groups <- factor(rep(0L, n_subjects))+ #' @name emmeans_support |
|||
| 221 | -267x | +|||
| 22 | +
- n_groups <- 1L+ NULL |
|||
| 222 | +23 |
- }+ |
||
| 223 | -308x | +|||
| 24 | +
- coordinates <- full_frame[, formula_parts$visit_var, drop = FALSE]+ #' Returns a `data.frame` for `emmeans` Purposes |
|||
| 224 | -308x | +|||
| 25 | +
- if (formula_parts$is_spatial) {
+ #' |
|||
| 225 | -16x | +|||
| 26 | +
- lapply(coordinates, assert_numeric)+ #' @seealso See [emmeans::recover_data()] for background. |
|||
| 226 | -16x | +|||
| 27 | +
- coordinates_matrix <- as.matrix(coordinates)+ #' @keywords internal |
|||
| 227 | -16x | +|||
| 28 | +
- n_visits <- max(subject_n_visits)+ #' @noRd |
|||
| 228 | +29 |
- } else {
+ recover_data.mmrm <- function(object, ...) { # nolint
|
||
| 229 | -292x | +30 | +13x |
- assert(identical(ncol(coordinates), 1L))+ fun_call <- stats::getCall(object) |
| 230 | -292x | +|||
| 31 | +
- assert_factor(coordinates[[1L]])+ # subject_var is excluded because it should not contain fixed effect. |
|||
| 231 | -292x | +|||
| 32 | +
- coordinates_matrix <- as.matrix(as.integer(coordinates[[1L]]) - 1, ncol = 1)+ # visit_var is not excluded because emmeans can provide marginal mean |
|||
| 232 | -292x | +|||
| 33 | +
- n_visits <- nlevels(coordinates[[1L]])+ # by each visit if visit_var is not spatial. |
|||
| 233 | -292x | -
- assert_true(all(subject_n_visits <= n_visits))- |
- ||
| 234 | -- |
- }- |
- ||
| 235 | -308x | -
- structure(- |
- ||
| 236 | -308x | -
- list(- |
- ||
| 237 | -308x | -
- full_frame = full_frame,- |
- ||
| 238 | -308x | -
- data = data,- |
- ||
| 239 | -308x | -
- x_matrix = x_matrix,- |
- ||
| 240 | -308x | +34 | +13x |
- x_cols_aliased = x_cols_aliased,+ model_frame <- stats::model.frame( |
| 241 | -308x | +35 | +13x |
- coordinates = coordinates_matrix,+ object, |
| 242 | -308x | +36 | +13x |
- y_vector = y_vector,+ include = c( |
| 243 | -308x | +37 | +13x |
- weights_vector = weights_vector,+ if (!object$formula_parts$is_spatial) "visit_var" else NULL, |
| 244 | -308x | +38 | +13x |
- n_visits = n_visits,+ "response_var", "group_var" |
| 245 | -308x | +|||
| 39 | +
- n_subjects = n_subjects,+ ) |
|||
| 246 | -308x | +|||
| 40 | +
- subject_zero_inds = subject_zero_inds,+ ) |
|||
| 247 | -308x | +41 | +13x |
- subject_n_visits = subject_n_visits,+ model_terms <- stats::delete.response(stats::terms(model_frame)) |
| 248 | -308x | +42 | +13x |
- cov_type = formula_parts$cov_type,+ emmeans::recover_data( |
| 249 | -308x | +43 | +13x |
- is_spatial_int = as.integer(formula_parts$is_spatial),+ fun_call, |
| 250 | -308x | +44 | +13x |
- reml = as.integer(reml),+ trms = model_terms, |
| 251 | -308x | +45 | +13x |
- subject_groups = subject_groups,+ na.action = "na.omit", |
| 252 | -308x | +46 | +13x |
- n_groups = n_groups+ frame = model_frame, |
| 253 | +47 |
- ),- |
- ||
| 254 | -308x | -
- class = "mmrm_tmb_data"+ ... |
||
| 255 | +48 |
) |
||
| 256 | +49 |
} |
||
| 257 | +50 | |||
| 258 | +51 |
- #' Start Parameters for `TMB` Fit+ #' Returns a List of Model Details for `emmeans` Purposes |
||
| 259 | +52 |
#' |
||
| 260 | -- |
- #' @param formula_parts (`mmrm_tmb_formula_parts`)\cr produced by- |
- ||
| 261 | +53 |
- #' [h_mmrm_tmb_formula_parts()].+ #' @seealso See [emmeans::emm_basis()] for background. |
||
| 262 | +54 |
- #' @param tmb_data (`mmrm_tmb_data`)\cr produced by [h_mmrm_tmb_data()].+ #' @keywords internal |
||
| 263 | +55 |
- #' @param start (`numeric` or `NULL`)\cr optional start values for variance+ #' @noRd |
||
| 264 | +56 |
- #' parameters.+ emm_basis.mmrm <- function(object, # nolint |
||
| 265 | +57 |
- #' @param n_groups (`int`)\cr number of groups.+ trms, |
||
| 266 | +58 |
- #' @return List with element `theta` containing the start values for the variance+ xlev, |
||
| 267 | +59 |
- #' parameters.+ grid, |
||
| 268 | +60 |
- #'+ ...) {
|
||
| 269 | -+ | |||
| 61 | +13x |
- #' @keywords internal+ model_frame <- stats::model.frame(trms, grid, na.action = stats::na.pass, xlev = xlev) |
||
| 270 | -+ | |||
| 62 | +13x |
- h_mmrm_tmb_parameters <- function(formula_parts,+ contrasts <- component(object, "contrasts") |
||
| 271 | -+ | |||
| 63 | +13x |
- tmb_data,+ model_mat <- stats::model.matrix(trms, model_frame, contrasts.arg = contrasts) |
||
| 272 | -+ | |||
| 64 | +13x |
- start,+ beta_hat <- component(object, "beta_est") |
||
| 273 | -+ | |||
| 65 | +13x |
- n_groups = 1L) {
+ nbasis <- if (length(beta_hat) < ncol(model_mat)) {
|
||
| 274 | -265x | +66 | +6x |
- assert_class(formula_parts, "mmrm_tmb_formula_parts")+ kept <- match(names(beta_hat), colnames(model_mat)) |
| 275 | -265x | +67 | +6x |
- assert_class(tmb_data, "mmrm_tmb_data")+ beta_hat <- NA * model_mat[1L, ] |
| 276 | -+ | |||
| 68 | +6x |
-
+ beta_hat[kept] <- component(object, "beta_est") |
||
| 277 | -265x | +69 | +6x |
- m <- tmb_data$n_visits+ orig_model_mat <- stats::model.matrix( |
| 278 | -265x | +70 | +6x |
- start_value0 <- std_start(formula_parts$cov_type, m, n_groups)+ trms, |
| 279 | -265x | +71 | +6x |
- theta_dim <- length(start_value0)+ stats::model.frame( |
| 280 | -265x | +72 | +6x |
- start_values <- if (is.null(start)) {
+ object, |
| 281 | -15x | +73 | +6x |
- start_value0+ include = c( |
| 282 | -265x | +74 | +6x |
- } else if (test_function(start)) {
+ if (!object$formula_parts$is_spatial) "visit_var" else NULL, |
| 283 | -233x | +75 | +6x |
- do.call(start, utils::modifyList(formula_parts, tmb_data))+ "response_var", "group_var" |
| 284 | +76 |
- } else {
- |
- ||
| 285 | -17x | -
- start+ ) |
||
| 286 | +77 |
- }- |
- ||
| 287 | -264x | -
- assert_numeric(start_values, len = theta_dim, any.missing = FALSE, finite = TRUE)+ ), |
||
| 288 | -262x | +78 | +6x |
- list(theta = start_values)+ contrasts.arg = contrasts |
| 289 | +79 |
- }+ ) |
||
| 290 | -+ | |||
| 80 | +6x |
-
+ estimability::nonest.basis(orig_model_mat) |
||
| 291 | +81 |
- #' Asserting Sane Start Values for `TMB` Fit+ } else {
|
||
| 292 | -+ | |||
| 82 | +7x |
- #'+ estimability::all.estble |
||
| 293 | +83 |
- #' @param tmb_object (`list`)\cr created with [TMB::MakeADFun()].+ } |
||
| 294 | -+ | |||
| 84 | +13x |
- #'+ dfargs <- list(object = object) |
||
| 295 | -+ | |||
| 85 | +13x |
- #' @return Nothing, only used for assertions.+ dffun <- function(k, dfargs) {
|
||
| 296 | -+ | |||
| 86 | +113x |
- #'+ mmrm::df_md(dfargs$object, contrast = k)$denom_df |
||
| 297 | +87 |
- #' @keywords internal+ } |
||
| 298 | -+ | |||
| 88 | +13x |
- h_mmrm_tmb_assert_start <- function(tmb_object) {
+ list( |
||
| 299 | -249x | +89 | +13x |
- assert_list(tmb_object)+ X = model_mat, |
| 300 | -249x | +90 | +13x |
- assert_subset(c("fn", "gr", "par"), names(tmb_object))
+ bhat = beta_hat, |
| 301 | -+ | |||
| 91 | +13x |
-
+ nbasis = nbasis, |
||
| 302 | -249x | +92 | +13x |
- if (is.na(tmb_object$fn(tmb_object$par))) {
+ V = component(object, "beta_vcov"), |
| 303 | -1x | +93 | +13x |
- stop("negative log-likelihood is NaN at starting parameter values")
+ dffun = dffun, |
| 304 | -+ | |||
| 94 | +13x |
- }+ dfargs = dfargs |
||
| 305 | -248x | +|||
| 95 | +
- if (any(is.na(tmb_object$gr(tmb_object$par)))) {
+ ) |
|||
| 306 | -1x | +|||
| 96 | +
- stop("some elements of gradient are NaN at starting parameter values")
+ } |
| 307 | +1 |
- }+ #' Obtain Kenward-Roger Adjustment Components |
||
| 308 | +2 |
- }+ #' |
||
| 309 | +3 |
-
+ #' @description Obtains the components needed downstream for the computation of Kenward-Roger degrees of freedom. |
||
| 310 | +4 |
- #' Checking the `TMB` Optimization Result+ #' Used in [mmrm()] fitting if method is "Kenward-Roger". |
||
| 311 | +5 |
#' |
||
| 312 | +6 |
- #' @param tmb_opt (`list`)\cr optimization result.+ #' @param tmb_data (`mmrm_tmb_data`)\cr produced by [h_mmrm_tmb_data()]. |
||
| 313 | +7 |
- #' @param mmrm_tmb (`mmrm_tmb`)\cr result from [h_mmrm_tmb_fit()].+ #' @param theta (`numeric`)\cr theta estimate. |
||
| 314 | +8 |
#' |
||
| 315 | +9 |
- #' @return Nothing, only used to generate warnings in case that the model+ #' @details the function returns a named list, \eqn{P}, \eqn{Q} and \eqn{R}, which corresponds to the
|
||
| 316 | +10 |
- #' did not converge.+ #' paper in 1997. The matrices are stacked in columns so that \eqn{P}, \eqn{Q} and \eqn{R} has the same
|
||
| 317 | +11 |
- #'+ #' column number(number of beta parameters). The number of rows, is dependent on |
||
| 318 | +12 |
- #' @keywords internal+ #' the total number of theta and number of groups, if the fit is a grouped mmrm. |
||
| 319 | +13 |
- h_mmrm_tmb_check_conv <- function(tmb_opt, mmrm_tmb) {
+ #' For \eqn{P} matrix, it is stacked sequentially. For \eqn{Q} and \eqn{R} matrix, it is stacked so
|
||
| 320 | -245x | +|||
| 14 | +
- assert_list(tmb_opt)+ #' 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.
|
|||
| 321 | -245x | +|||
| 15 | +
- assert_subset(c("par", "objective", "convergence", "message"), names(tmb_opt))
+ #' \eqn{Q} and \eqn{R} only contains intra-group results and inter-group results should be all zero matrices
|
|||
| 322 | -245x | +|||
| 16 | +
- assert_class(mmrm_tmb, "mmrm_tmb")+ #' so they are not stacked in the result. |
|||
| 323 | +17 |
-
+ #' |
||
| 324 | -245x | +|||
| 18 | +
- if (!is.null(tmb_opt$convergence) && tmb_opt$convergence != 0) {
+ #' @return Named list with elements: |
|||
| 325 | -3x | +|||
| 19 | +
- warning("Model convergence problem: ", tmb_opt$message, ".")
+ #' - `P`: `matrix` of \eqn{P} component.
|
|||
| 326 | -3x | +|||
| 20 | +
- return()+ #' - `Q`: `matrix` of \eqn{Q} component.
|
|||
| 327 | +21 |
- }+ #' - `R`: `matrix` of \eqn{R} component.
|
||
| 328 | -242x | +|||
| 22 | +
- theta_vcov <- mmrm_tmb$theta_vcov+ #' |
|||
| 329 | -242x | +|||
| 23 | +
- if (is(theta_vcov, "try-error")) {
+ #' @keywords internal |
|||
| 330 | -3x | +|||
| 24 | +
- warning("Model convergence problem: hessian is singular, theta_vcov not available.")
+ h_get_kr_comp <- function(tmb_data, theta) {
|
|||
| 331 | -3x | +25 | +47x |
- return()+ assert_class(tmb_data, "mmrm_tmb_data") |
| 332 | -+ | |||
| 26 | +47x |
- }+ assert_class(theta, "numeric") |
||
| 333 | -239x | +27 | +47x |
- if (!all(is.finite(theta_vcov))) {
+ .Call(`_mmrm_get_pqr`, PACKAGE = "mmrm", tmb_data, theta) |
| 334 | -3x | +|||
| 28 | +
- warning("Model convergence problem: theta_vcov contains non-finite values.")
+ } |
|||
| 335 | -3x | +|||
| 29 | +
- return()+ |
|||
| 336 | +30 |
- }+ #' Calculation of Kenward-Roger Degrees of Freedom for Multi-Dimensional Contrast |
||
| 337 | -236x | +|||
| 31 | +
- eigen_vals <- eigen(theta_vcov, only.values = TRUE)$values+ #' |
|||
| 338 | -236x | +|||
| 32 | +
- if (mode(eigen_vals) == "complex" || any(eigen_vals <= 0)) {
+ #' @description Used in [df_md()] if method is "Kenward-Roger" or "Kenward-Roger-Linear". |
|||
| 339 | +33 |
- # Note: complex eigen values signal that the matrix is not symmetric, therefore not positive definite.+ #' |
||
| 340 | -3x | +|||
| 34 | +
- warning("Model convergence problem: theta_vcov is not positive definite.")
+ #' @inheritParams h_df_md_sat |
|||
| 341 | -3x | +|||
| 35 | +
- return()+ #' @inherit h_df_md_sat return |
|||
| 342 | +36 |
- }+ #' @keywords internal+ |
+ ||
| 37 | ++ |
+ h_df_md_kr <- function(object, contrast) {
|
||
| 343 | -233x | +38 | +6x |
- qr_rank <- qr(theta_vcov)$rank+ assert_class(object, "mmrm") |
| 344 | -233x | +39 | +6x |
- if (qr_rank < ncol(theta_vcov)) {
+ assert_matrix(contrast, mode = "numeric", any.missing = FALSE, ncols = length(component(object, "beta_est"))) |
| 345 | -1x | +40 | +6x |
- warning("Model convergence problem: theta_vcov is numerically singular.")
+ if (component(object, "reml") != 1) {
+ |
+
| 41 | +! | +
+ stop("Kenward-Roger is only for REML")
|
||
| 346 | +42 |
} |
||
| 347 | -+ | |||
| 43 | +6x |
- }+ kr_comp <- object$kr_comp |
||
| 348 | -+ | |||
| 44 | +6x |
-
+ w <- component(object, "theta_vcov") |
||
| 349 | -+ | |||
| 45 | +6x |
- #' Extract covariance matrix from `TMB` report and input data+ v_adj <- object$beta_vcov_adj |
||
| 350 | -+ | |||
| 46 | +6x |
- #'+ df <- h_kr_df(v0 = object$beta_vcov, l = contrast, w = w, p = kr_comp$P) |
||
| 351 | +47 |
- #' This helper does some simple post-processing to extract covariance matrix or named+ |
||
| 352 | -+ | |||
| 48 | +6x |
- #' list of covariance matrices if the fitting is using grouped covariance matrices.+ h_test_md(object, contrast, df = df$m, f_stat_factor = df$lambda) |
||
| 353 | +49 |
- #'+ } |
||
| 354 | +50 |
- #' @param tmb_report (`list`)\cr report created with [TMB::MakeADFun()] report function.+ |
||
| 355 | +51 |
- #' @param tmb_data (`mmrm_tmb_data`)\cr produced by [h_mmrm_tmb_data()].+ #' Calculation of Kenward-Roger Degrees of Freedom for One-Dimensional Contrast |
||
| 356 | +52 |
- #' @param visit_var (`character`)\cr character vector of the visit variable+ #' |
||
| 357 | +53 |
- #' @param is_spatial (`flag`)\cr indicator whether the covariance structure is spatial.+ #' @description Used in [df_1d()] if method is |
||
| 358 | +54 |
- #' @return Return a simple covariance matrix if there is no grouping, or a named+ #' "Kenward-Roger" or "Kenward-Roger-Linear". |
||
| 359 | +55 |
- #' list of estimated grouped covariance matrices,+ #' |
||
| 360 | +56 |
- #' with its name equal to the group levels.+ #' @inheritParams h_df_1d_sat |
||
| 361 | +57 |
- #'+ #' @inherit h_df_1d_sat return |
||
| 362 | +58 |
#' @keywords internal |
||
| 363 | +59 |
- h_mmrm_tmb_extract_cov <- function(tmb_report, tmb_data, visit_var, is_spatial) {
+ h_df_1d_kr <- function(object, contrast) {
|
||
| 364 | -241x | +60 | +21x |
- d <- dim(tmb_report$covariance_lower_chol)+ assert_class(object, "mmrm") |
| 365 | -241x | +61 | +21x |
- visit_names <- if (!is_spatial) {
+ assert_numeric(contrast, len = length(component(object, "beta_est"))) |
| 366 | -228x | -
- levels(tmb_data$full_frame[[visit_var]])- |
- ||
| 367 | -+ | 62 | +21x |
- } else {
+ if (component(object, "reml") != 1) {
|
| 368 | -13x | +|||
| 63 | +! |
- c(0, 1)+ stop("Kenward-Roger is only for REML!")
|
||
| 369 | +64 |
} |
||
| 370 | -241x | +|||
| 65 | +
- cov <- lapply(+ |
|||
| 371 | -241x | +66 | +21x |
- seq_len(d[1] / d[2]),+ df <- h_kr_df( |
| 372 | -241x | +67 | +21x |
- function(i) {
+ v0 = object$beta_vcov, |
| 373 | -278x | +68 | +21x |
- ret <- tcrossprod(tmb_report$covariance_lower_chol[seq(1 + (i - 1) * d[2], i * d[2]), ])+ l = matrix(contrast, nrow = 1), |
| 374 | -278x | +69 | +21x |
- dimnames(ret) <- list(visit_names, visit_names)+ w = component(object, "theta_vcov"), |
| 375 | -278x | -
- return(ret)- |
- ||
| 376 | -+ | 70 | +21x |
- }+ p = object$kr_comp$P |
| 377 | +71 |
) |
||
| 378 | -241x | -
- if (identical(tmb_data$n_groups, 1L)) {
- |
- ||
| 379 | -204x | -
- cov <- cov[[1]]- |
- ||
| 380 | -- |
- } else {
- |
- ||
| 381 | -37x | -
- names(cov) <- levels(tmb_data$subject_groups)- |
- ||
| 382 | +72 |
- }+ |
||
| 383 | -241x | +73 | +21x |
- return(cov)+ h_test_1d(object, contrast, df$m) |
| 384 | +74 |
} |
||
| 385 | +75 | |||
| 386 | +76 |
- #' Build `TMB` Fit Result List+ #' Obtain the Adjusted Kenward-Roger degrees of freedom |
||
| 387 | +77 |
#' |
||
| 388 | +78 |
- #' This helper does some simple post-processing of the `TMB` object and+ #' @description Obtains the adjusted Kenward-Roger degrees of freedom and F statistic scale parameter. |
||
| 389 | +79 |
- #' optimization results, including setting names, inverting matrices etc.+ #' Used in [h_df_md_kr()] or [h_df_1d_kr]. |
||
| 390 | +80 |
#' |
||
| 391 | -- |
- #' @param tmb_object (`list`)\cr created with [TMB::MakeADFun()].- |
- ||
| 392 | +81 |
- #' @param tmb_opt (`list`)\cr optimization result.+ #' @param v0 (`matrix`)\cr unadjusted covariance matrix. |
||
| 393 | +82 |
- #' @param formula_parts (`mmrm_tmb_formula_parts`)\cr produced by+ #' @param l (`matrix`)\cr linear combination matrix. |
||
| 394 | +83 |
- #' [h_mmrm_tmb_formula_parts()].+ #' @param w (`matrix`)\cr hessian matrix. |
||
| 395 | +84 |
- #' @param tmb_data (`mmrm_tmb_data`)\cr produced by [h_mmrm_tmb_data()].+ #' @param p (`matrix`)\cr P matrix from [h_get_kr_comp()]. |
||
| 396 | +85 |
#' |
||
| 397 | +86 |
- #' @return List of class `mmrm_tmb` with:+ #' @return Named list with elements: |
||
| 398 | +87 |
- #' - `cov`: estimated covariance matrix, or named list of estimated group specific covariance matrices.+ #' - `m`: `numeric` degrees of freedom. |
||
| 399 | +88 |
- #' - `beta_est`: vector of coefficient estimates.+ #' - `lambda`: `numeric` F statistic scale parameter. |
||
| 400 | +89 |
- #' - `beta_vcov`: Variance-covariance matrix for coefficient estimates.+ #' |
||
| 401 | +90 |
- #' - `beta_vcov_inv_L`: Lower triangular matrix `L` of the inverse variance-covariance matrix decomposition.+ #' @keywords internal |
||
| 402 | +91 |
- #' - `beta_vcov_inv_D`: vector of diagonal matrix `D` of the inverse variance-covariance matrix decomposition.+ h_kr_df <- function(v0, l, w, p) {
|
||
| 403 | -+ | |||
| 92 | +28x |
- #' - `theta_est`: vector of variance parameter estimates.+ n_beta <- ncol(v0) |
||
| 404 | -+ | |||
| 93 | +28x |
- #' - `theta_vcov`: variance-covariance matrix for variance parameter estimates.+ assert_matrix(v0, ncols = n_beta, nrows = n_beta) |
||
| 405 | -+ | |||
| 94 | +28x |
- #' - `neg_log_lik`: obtained negative log-likelihood.+ assert_matrix(l, ncols = n_beta) |
||
| 406 | -+ | |||
| 95 | +28x |
- #' - `formula_parts`: input.+ n_theta <- ncol(w) |
||
| 407 | -+ | |||
| 96 | +28x |
- #' - `data`: input.+ assert_matrix(w, ncols = n_theta, nrows = n_theta) |
||
| 408 | -+ | |||
| 97 | +28x |
- #' - `weights`: input.+ n_visits <- ncol(p) |
||
| 409 | -+ | |||
| 98 | +28x |
- #' - `reml`: input as a flag.+ assert_matrix(p, nrows = n_visits * n_theta) |
||
| 410 | +99 |
- #' - `opt_details`: list with optimization details including convergence code.+ # see vignettes/kenward.Rmd#279 |
||
| 411 | -- |
- #' - `tmb_object`: original `TMB` object created with [TMB::MakeADFun()].- |
- ||
| 412 | -- |
- #' - `tmb_data`: input.- |
- ||
| 413 | -- |
- #'- |
- ||
| 414 | -- |
- #' @details Instead of inverting or decomposing `beta_vcov`, it can be more efficient to use its robust- |
- ||
| 415 | -- |
- #' Cholesky decomposition `LDL^T`, therefore we return the corresponding two components `L` and `D`- |
- ||
| 416 | -- |
- #' as well since they have been available on the `C++` side already.- |
- ||
| 417 | -- |
- #'- |
- ||
| 418 | -- |
- #' @keywords internal- |
- ||
| 419 | -- |
- h_mmrm_tmb_fit <- function(tmb_object,- |
- ||
| 420 | -- |
- tmb_opt,- |
- ||
| 421 | -+ | |||
| 100 | +28x |
- formula_parts,+ slvol <- solve(h_quad_form_mat(l, v0)) |
||
| 422 | -+ | |||
| 101 | +28x |
- tmb_data) {
+ m <- h_quad_form_mat(t(l), slvol) |
||
| 423 | -239x | +102 | +28x |
- assert_list(tmb_object)+ nl <- nrow(l) |
| 424 | -239x | +103 | +28x |
- assert_subset(c("fn", "gr", "par", "he"), names(tmb_object))
+ mv0 <- m %*% v0 |
| 425 | -239x | +104 | +28x |
- assert_list(tmb_opt)+ pl <- lapply(seq_len(nrow(p) / ncol(p)), function(x) {
|
| 426 | -239x | +105 | +108x |
- assert_subset(c("par", "objective", "convergence", "message"), names(tmb_opt))
+ ii <- (x - 1) * ncol(p) + 1 |
| 427 | -239x | +106 | +108x |
- assert_class(formula_parts, "mmrm_tmb_formula_parts")+ jj <- x * ncol(p) |
| 428 | -239x | +107 | +108x |
- assert_class(tmb_data, "mmrm_tmb_data")+ p[ii:jj, ] |
| 429 | +108 |
-
+ }) |
||
| 430 | -239x | +109 | +28x |
- tmb_report <- tmb_object$report(par = tmb_opt$par)+ mv0pv0 <- lapply(pl, function(x) {
|
| 431 | -239x | +110 | +108x |
- x_matrix_cols <- colnames(tmb_data$x_matrix)+ mv0 %*% x %*% v0 |
| 432 | -239x | +|||
| 111 | +
- cov <- h_mmrm_tmb_extract_cov(tmb_report, tmb_data, formula_parts$visit_var, formula_parts$is_spatial)+ }) |
|||
| 433 | -239x | +112 | +28x |
- beta_est <- tmb_report$beta+ a1 <- 0 |
| 434 | -239x | +113 | +28x |
- names(beta_est) <- x_matrix_cols+ a2 <- 0 |
| 435 | -239x | +|||
| 114 | +
- beta_vcov <- tmb_report$beta_vcov+ # see vignettes/kenward.Rmd#283 |
|||
| 436 | -239x | +115 | +28x |
- dimnames(beta_vcov) <- list(x_matrix_cols, x_matrix_cols)+ for (i in seq_len(length(pl))) {
|
| 437 | -239x | +116 | +108x |
- beta_vcov_inv_L <- tmb_report$XtWX_L # nolint+ for (j in seq_len(length(pl))) {
|
| 438 | -239x | +117 | +592x |
- beta_vcov_inv_D <- tmb_report$XtWX_D # nolint+ a1 <- a1 + w[i, j] * h_tr(mv0pv0[[i]]) * h_tr(mv0pv0[[j]]) |
| 439 | -239x | +118 | +592x |
- theta_est <- tmb_opt$par+ a2 <- a2 + w[i, j] * h_tr(mv0pv0[[i]] %*% mv0pv0[[j]]) |
| 440 | -239x | +|||
| 119 | +
- names(theta_est) <- NULL+ } |
|||
| 441 | -239x | +|||
| 120 | +
- theta_vcov <- try(solve(tmb_object$he(tmb_opt$par)), silent = TRUE)+ } |
|||
| 442 | -239x | +121 | +28x |
- opt_details_names <- setdiff(+ b <- 1 / (2 * nl) * (a1 + 6 * a2) |
| 443 | -239x | +122 | +28x |
- names(tmb_opt),+ e <- 1 + a2 / nl |
| 444 | -239x | +123 | +28x |
- c("par", "objective")
+ e_star <- 1 / (1 - a2 / nl) |
| 445 | -+ | |||
| 124 | +28x |
- )+ g <- ((nl + 1) * a1 - (nl + 4) * a2) / ((nl + 2) * a2) |
||
| 446 | -239x | +125 | +28x |
- structure(+ denom <- (3 * nl + 2 - 2 * g) |
| 447 | -239x | +126 | +28x |
- list(+ c1 <- g / denom |
| 448 | -239x | +127 | +28x |
- cov = cov,+ c2 <- (nl - g) / denom |
| 449 | -239x | +128 | +28x |
- beta_est = beta_est,+ c3 <- (nl + 2 - g) / denom |
| 450 | -239x | +129 | +28x |
- beta_vcov = beta_vcov,+ v_star <- 2 / nl * (1 + c1 * b) / (1 - c2 * b)^2 / (1 - c3 * b) |
| 451 | -239x | +130 | +28x |
- beta_vcov_inv_L = beta_vcov_inv_L,+ rho <- v_star / (2 * e_star^2) |
| 452 | -239x | +131 | +28x |
- beta_vcov_inv_D = beta_vcov_inv_D,+ m <- 4 + (nl + 2) / (nl * rho - 1) |
| 453 | -239x | +132 | +28x |
- theta_est = theta_est,+ lambda <- m / (e_star * (m - 2)) |
| 454 | -239x | +133 | +28x |
- theta_vcov = theta_vcov,+ list(m = m, lambda = lambda) |
| 455 | -239x | +|||
| 134 | +
- neg_log_lik = tmb_opt$objective,+ } |
|||
| 456 | -239x | +|||
| 135 | +
- formula_parts = formula_parts,+ |
|||
| 457 | -239x | +|||
| 136 | +
- data = tmb_data$data,+ #' Obtain the Adjusted Covariance Matrix |
|||
| 458 | -239x | +|||
| 137 | +
- weights = tmb_data$weights_vector,+ #' |
|||
| 459 | -239x | +|||
| 138 | +
- reml = as.logical(tmb_data$reml),+ #' @description Obtains the Kenward-Roger adjusted covariance matrix for the |
|||
| 460 | -239x | +|||
| 139 | +
- opt_details = tmb_opt[opt_details_names],+ #' coefficient estimates. |
|||
| 461 | -239x | +|||
| 140 | +
- tmb_object = tmb_object,+ #' Used in [mmrm()] fitting if method is "Kenward-Roger" or "Kenward-Roger-Linear". |
|||
| 462 | -239x | +|||
| 141 | +
- tmb_data = tmb_data+ #' |
|||
| 463 | +142 |
- ),+ #' @param v (`matrix`)\cr unadjusted covariance matrix. |
||
| 464 | -239x | +|||
| 143 | +
- class = "mmrm_tmb"+ #' @param w (`matrix`)\cr hessian matrix. |
|||
| 465 | +144 |
- )+ #' @param p (`matrix`)\cr P matrix from [h_get_kr_comp()]. |
||
| 466 | +145 |
- }+ #' @param q (`matrix`)\cr Q matrix from [h_get_kr_comp()]. |
||
| 467 | +146 |
-
+ #' @param r (`matrix`)\cr R matrix from [h_get_kr_comp()]. |
||
| 468 | +147 |
- #' Low-Level Fitting Function for MMRM+ #' @param linear (`flag`)\cr whether to use linear Kenward-Roger approximation. |
||
| 469 | +148 |
#' |
||
| 470 | +149 |
- #' @description `r lifecycle::badge("stable")`
+ #' @return The matrix of adjusted covariance matrix. |
||
| 471 | +150 |
#' |
||
| 472 | +151 |
- #' This is the low-level function to fit an MMRM. Note that this does not+ #' @keywords internal |
||
| 473 | +152 |
- #' try different optimizers or adds Jacobian information etc. in contrast to+ h_var_adj <- function(v, w, p, q, r, linear = FALSE) {
|
||
| 474 | -+ | |||
| 153 | +49x |
- #' [mmrm()].+ assert_flag(linear) |
||
| 475 | -+ | |||
| 154 | +49x |
- #'+ n_beta <- ncol(v) |
||
| 476 | -+ | |||
| 155 | +49x |
- #' @param formula (`formula`)\cr model formula with exactly one special term+ assert_matrix(v, nrows = n_beta) |
||
| 477 | -+ | |||
| 156 | +49x |
- #' specifying the visits within subjects, see details.+ n_theta <- ncol(w) |
||
| 478 | -+ | |||
| 157 | +49x |
- #' @param data (`data.frame`)\cr input data containing the variables used in+ assert_matrix(w, nrows = n_theta) |
||
| 479 | -+ | |||
| 158 | +49x |
- #' `formula`.+ n_visits <- ncol(p) |
||
| 480 | -+ | |||
| 159 | +49x |
- #' @param weights (`vector`)\cr input vector containing the weights.+ theta_per_group <- nrow(q) / nrow(p) |
||
| 481 | -+ | |||
| 160 | +49x |
- #' @inheritParams h_mmrm_tmb_data+ n_groups <- n_theta / theta_per_group |
||
| 482 | -+ | |||
| 161 | +49x |
- #' @param covariance (`cov_struct`)\cr A covariance structure type definition,+ assert_matrix(p, nrows = n_theta * n_visits) |
||
| 483 | -+ | |||
| 162 | +49x |
- #' or value that can be coerced to a covariance structure using+ assert_matrix(q, nrows = theta_per_group^2 * n_groups * n_visits, ncols = n_visits) |
||
| 484 | -+ | |||
| 163 | +49x |
- #' [as.cov_struct()]. If no value is provided, a structure is derived from+ assert_matrix(r, nrows = theta_per_group^2 * n_groups * n_visits, ncols = n_visits) |
||
| 485 | -+ | |||
| 164 | +49x |
- #' the provided formula.+ if (linear) {
|
||
| 486 | -+ | |||
| 165 | +13x |
- #' @param control (`mmrm_control`)\cr list of control options produced by+ r <- matrix(0, nrow = nrow(r), ncol = ncol(r)) |
||
| 487 | +166 |
- #' [mmrm_control()].+ } |
||
| 488 | +167 |
- #' @inheritParams fit_single_optimizer+ |
||
| 489 | +168 |
- #'+ # see vignettes/kenward.Rmd#131 |
||
| 490 | -+ | |||
| 169 | +49x |
- #' @return List of class `mmrm_tmb`, see [h_mmrm_tmb_fit()] for details.+ ret <- v |
||
| 491 | -+ | |||
| 170 | +49x |
- #' In addition, it contains elements `call` and `optimizer`.+ for (i in seq_len(n_theta)) {
|
||
| 492 | -+ | |||
| 171 | +264x |
- #'+ for (j in seq_len(n_theta)) {
|
||
| 493 | -+ | |||
| 172 | +2164x |
- #' @details+ gi <- ceiling(i / theta_per_group) |
||
| 494 | -+ | |||
| 173 | +2164x |
- #' The `formula` typically looks like:+ gj <- ceiling(j / theta_per_group)+ |
+ ||
| 174 | +2164x | +
+ iid <- (i - 1) * n_beta + 1+ |
+ ||
| 175 | +2164x | +
+ jid <- (j - 1) * n_beta + 1 |
||
| 495 | -+ | |||
| 176 | +2164x |
- #'+ ii <- i - (gi - 1) * theta_per_group |
||
| 496 | -+ | |||
| 177 | +2164x |
- #' `FEV1 ~ RACE + SEX + ARMCD * AVISIT + us(AVISIT | USUBJID)`+ jj <- j - (gi - 1) * theta_per_group |
||
| 497 | -+ | |||
| 178 | +2164x |
- #'+ ijid <- ((ii - 1) * theta_per_group + jj - 1) * n_beta + (gi - 1) * n_beta * theta_per_group^2 + 1 |
||
| 498 | -+ | |||
| 179 | +2164x |
- #' which specifies response and covariates as usual, and exactly one special term+ if (gi != gj) {
|
||
| 499 | -+ | |||
| 180 | +592x |
- #' defines which covariance structure is used and what are the visit and+ ret <- ret + 2 * w[i, j] * v %*% (-p[iid:(iid + n_beta - 1), ] %*% v %*% p[jid:(jid + n_beta - 1), ]) %*% v |
||
| 500 | +181 |
- #' subject variables.+ } else {
|
||
| 501 | -+ | |||
| 182 | +1572x |
- #'+ ret <- ret + 2 * w[i, j] * v %*% ( |
||
| 502 | -+ | |||
| 183 | +1572x |
- #' Always use only the first optimizer if multiple optimizers are provided.+ q[ijid:(ijid + n_beta - 1), ] - |
||
| 503 | -+ | |||
| 184 | +1572x |
- #'+ p[iid:(iid + n_beta - 1), ] %*% v %*% p[jid:(jid + n_beta - 1), ] - |
||
| 504 | -+ | |||
| 185 | +1572x |
- #' @export+ 1 / 4 * r[ijid:(ijid + n_beta - 1), ] |
||
| 505 | -+ | |||
| 186 | +1572x |
- #'+ ) %*% v |
||
| 506 | +187 |
- #' @examples+ } |
||
| 507 | +188 |
- #' formula <- FEV1 ~ RACE + SEX + ARMCD * AVISIT + us(AVISIT | USUBJID)+ } |
||
| 508 | +189 |
- #' data <- fev_data+ } |
||
| 509 | -+ | |||
| 190 | +49x |
- #' system.time(result <- fit_mmrm(formula, data, rep(1, nrow(fev_data))))+ ret |
||
| 510 | +191 |
- fit_mmrm <- function(formula,+ } |
| 511 | +1 |
- data,+ #' Register `mmrm` For Use With `car::Anova` |
||
| 512 | +2 |
- weights,+ #' |
||
| 513 | +3 |
- reml = TRUE,+ #' @inheritParams base::requireNamespace |
||
| 514 | +4 |
- covariance = NULL,+ #' @return A logical value indicating whether registration was successful. |
||
| 515 | +5 |
- tmb_data,+ #' |
||
| 516 | +6 |
- formula_parts,+ #' @keywords internal |
||
| 517 | +7 |
- control = mmrm_control()) {
+ car_add_mmrm <- function(quietly = FALSE) {
|
||
| 518 | -252x | +8 | +1x |
- if (missing(formula_parts) || missing(tmb_data)) {
+ if (!requireNamespace("car", quietly = quietly)) {
|
| 519 | -67x | +|||
| 9 | +! |
- covariance <- h_reconcile_cov_struct(formula, covariance)+ return(FALSE) |
||
| 520 | -65x | +|||
| 10 | +
- formula_parts <- h_mmrm_tmb_formula_parts(formula, covariance)+ } |
|||
| 521 | -+ | |||
| 11 | +1x |
-
+ envir <- asNamespace("mmrm")
|
||
| 522 | -65x | +12 | +1x |
- if (!formula_parts$is_spatial && !is.factor(data[[formula_parts$visit_var]])) {
+ h_register_s3("car", "Anova", "mmrm", envir)
|
| 523 | +13 | 1x |
- stop("Time variable must be a factor for non-spatial covariance structures")
+ TRUE |
|
| 524 | +14 |
- }+ } |
||
| 525 | +15 | |||
| 526 | -64x | +|||
| 16 | +
- assert_class(control, "mmrm_control")+ |
|||
| 527 | -64x | +|||
| 17 | +
- assert_list(control$optimizers, min.len = 1)+ #' Obtain Contrast for Specified Effect |
|||
| 528 | -64x | +|||
| 18 | +
- assert_numeric(weights, any.missing = FALSE)+ #' |
|||
| 529 | -64x | +|||
| 19 | +
- assert_true(all(weights > 0))+ #' This is support function to obtain contrast matrix for type II/III testing. |
|||
| 530 | -64x | +|||
| 20 | +
- tmb_data <- h_mmrm_tmb_data(+ #' |
|||
| 531 | -64x | +|||
| 21 | +
- formula_parts, data, weights, reml,+ #' @param object (`mmrm`)\cr the fitted MMRM. |
|||
| 532 | -64x | +|||
| 22 | +
- singular = if (control$accept_singular) "drop" else "error", drop_visit_levels = control$drop_visit_levels+ #' @param effect (`string`) the name of the effect. |
|||
| 533 | +23 |
- )+ #' @param type (`string`) type of test, "II", "III", '2', or '3'. |
||
| 534 | +24 |
- } else {
+ #' @param tol (`numeric`) threshold blow which values are treated as 0. |
||
| 535 | -185x | +|||
| 25 | +
- assert_class(tmb_data, "mmrm_tmb_data")+ #' |
|||
| 536 | -185x | +|||
| 26 | +
- assert_class(formula_parts, "mmrm_tmb_formula_parts")+ #' @return A `matrix` of the contrast. |
|||
| 537 | +27 |
- }+ #' |
||
| 538 | -249x | +|||
| 28 | +
- tmb_parameters <- h_mmrm_tmb_parameters(formula_parts, tmb_data, start = control$start, n_groups = tmb_data$n_groups)+ #' @keywords internal |
|||
| 539 | +29 |
-
+ h_get_contrast <- function(object, effect, type = c("II", "III", "2", "3"), tol = sqrt(.Machine$double.eps)) {
|
||
| 540 | -246x | +30 | +45x |
- tmb_object <- TMB::MakeADFun(+ assert_class(object, "mmrm") |
| 541 | -246x | +31 | +45x |
- data = tmb_data,+ assert_string(effect) |
| 542 | -246x | +32 | +45x |
- parameters = tmb_parameters,+ assert_double(tol, finite = TRUE, len = 1L) |
| 543 | -246x | +33 | +45x |
- hessian = TRUE,+ type <- match.arg(type) |
| 544 | -246x | +34 | +45x |
- DLL = "mmrm",+ mx <- component(object, "x_matrix") |
| 545 | -246x | +35 | +45x |
- silent = TRUE+ asg <- attr(mx, "assign") |
| 546 | -+ | |||
| 36 | +45x |
- )+ formula <- object$formula_parts$model_formula |
||
| 547 | -246x | +37 | +45x |
- h_mmrm_tmb_assert_start(tmb_object)+ tms <- terms(formula) |
| 548 | -246x | +38 | +45x |
- used_optimizer <- control$optimizers[[1L]]+ fcts <- attr(tms, "factors")[-1L, , drop = FALSE] # Discard the response. |
| 549 | -246x | +39 | +45x |
- used_optimizer_name <- names(control$optimizers)[1L]+ ods <- attr(tms, "order") |
| 550 | -246x | +40 | +45x |
- args <- with(+ assert_subset(effect, colnames(fcts)) |
| 551 | -246x | +41 | +45x |
- tmb_object,+ idx <- which(effect == colnames(fcts)) |
| 552 | -246x | +42 | +45x |
- c(+ cols <- which(asg == idx) |
| 553 | -246x | +43 | +45x |
- list(par, fn, gr),+ xlev <- component(object, "xlev") |
| 554 | -246x | +44 | +45x |
- attr(used_optimizer, "args")+ contains_intercept <- (!0 %in% asg) && h_first_contain_categorical(effect, fcts, names(xlev)) |
| 555 | -+ | |||
| 45 | +45x |
- )+ coef_rows <- length(cols) - as.integer(contains_intercept) |
||
| 556 | -+ | |||
| 46 | +45x |
- )+ l_mx <- matrix(0, nrow = coef_rows, ncol = length(asg)) |
||
| 557 | -246x | +47 | +45x |
- if (identical(attr(used_optimizer, "use_hessian"), TRUE)) {
+ if (coef_rows == 0L) {
|
| 558 | -8x | +48 | +1x |
- args$hessian <- tmb_object$he+ return(l_mx) |
| 559 | +49 |
} |
||
| 560 | -246x | -
- tmb_opt <- do.call(- |
- ||
| 561 | -246x | +50 | +44x |
- what = used_optimizer,+ if (contains_intercept) {
|
| 562 | -246x | -
- args = args- |
- ||
| 563 | -+ | 51 | +4x |
- )+ l_mx[, cols] <- cbind(-1, diag(rep(1, coef_rows))) |
| 564 | +52 |
- # Ensure negative log likelihood is stored in `objective` element of list.- |
- ||
| 565 | -237x | -
- if ("value" %in% names(tmb_opt)) {
- |
- ||
| 566 | -227x | -
- tmb_opt$objective <- tmb_opt$value+ } else {
|
||
| 567 | -227x | +53 | +40x |
- tmb_opt$value <- NULL+ l_mx[, cols] <- diag(rep(1, coef_rows)) |
| 568 | +54 |
} |
||
| 569 | -237x | +55 | +44x |
- fit <- h_mmrm_tmb_fit(tmb_object, tmb_opt, formula_parts, tmb_data)+ for (i in setdiff(seq_len(ncol(fcts)), idx)) {
|
| 570 | -237x | +56 | +120x |
- h_mmrm_tmb_check_conv(tmb_opt, fit)+ additional_vars <- names(which(fcts[, i] > fcts[, idx])) |
| 571 | -237x | +57 | +120x |
- fit$call <- match.call()+ additional_numeric <- any(!additional_vars %in% names(xlev)) |
| 572 | -237x | +58 | +120x |
- fit$call$formula <- formula_parts$formula+ current_col <- which(asg == i) |
| 573 | -237x | +59 | +120x |
- fit$optimizer <- used_optimizer_name+ if (ods[i] >= ods[idx] && all(fcts[, i] >= fcts[, idx]) && !additional_numeric) {
|
| 574 | -237x | +60 | +24x |
- fit+ sub_mat <- switch(type, |
| 575 | -+ | |||
| 61 | +24x |
- }+ "2" = , |
| 1 | -+ | |||
| 62 | +24x |
- #' Dynamic Registration for Package Interoperability+ "II" = {
|
||
| 2 | -+ | |||
| 63 | +8x |
- #'+ x1 <- mx[, cols, drop = FALSE] |
||
| 3 | -+ | |||
| 64 | +8x |
- #' @seealso See `vignette("xtending", package = "emmeans")` for background.
+ x0 <- mx[, -c(cols, current_col), drop = FALSE] |
||
| 4 | -+ | |||
| 65 | +8x |
- #' @keywords internal+ x2 <- mx[, current_col, drop = FALSE] |
||
| 5 | -+ | |||
| 66 | +8x |
- #' @noRd+ m <- diag(rep(1, nrow(x0))) - x0 %*% solve(t(x0) %*% x0) %*% t(x0) |
||
| 6 | -+ | |||
| 67 | +8x |
- .onLoad <- function(libname, pkgname) { # nolint
+ ret <- solve(t(x1) %*% m %*% x1) %*% t(x1) %*% m %*% x2 |
||
| 7 | -! | +|||
| 68 | +8x |
- if (utils::packageVersion("TMB") < "1.9.15") {
+ if (contains_intercept) {
|
||
| 8 | -! | +|||
| 69 | +1x |
- warning("TMB version 1.9.15 or higher is required for reproducible model fits", call. = FALSE)
+ ret[-1, ] - ret[1, ] |
||
| 9 | +70 |
- }+ } else {
+ |
+ ||
| 71 | +7x | +
+ ret |
||
| 10 | +72 |
-
+ } |
||
| 11 | -! | +|||
| 73 | +
- register_on_load(+ }, |
|||
| 12 | -! | +|||
| 74 | +24x |
- "emmeans", c("1.6", NA),
+ "3" = , |
||
| 13 | -! | +|||
| 75 | +24x |
- callback = function() emmeans::.emm_register("mmrm", pkgname),
+ "III" = {
|
||
| 14 | -! | +|||
| 76 | +16x |
- message = "mmrm() registered as emmeans extension"+ lvls <- h_obtain_lvls(effect, additional_vars, xlev) |
||
| 15 | -+ | |||
| 77 | +16x |
- )+ t_levels <- lvls$total |
||
| 16 | -+ | |||
| 78 | +16x |
-
+ nms_base <- colnames(mx)[cols] |
||
| 17 | -! | +|||
| 79 | +16x |
- register_on_load(+ nms <- colnames(mx)[current_col] |
||
| 18 | -! | +|||
| 80 | +16x |
- "parsnip", c("1.1.0", NA),
+ nms_base_split <- strsplit(nms_base, ":") |
||
| 19 | -! | +|||
| 81 | +16x |
- callback = parsnip_add_mmrm,+ nms_split <- strsplit(nms, ":") |
||
| 20 | -! | +|||
| 82 | +16x |
- message = emit_tidymodels_register_msg+ base_idx <- h_get_index(nms_split, nms_base_split) |
||
| 21 | -+ | |||
| 83 | +16x |
- )+ mt <- l_mx[, cols, drop = FALSE] / t_levels |
||
| 22 | -! | +|||
| 84 | +16x |
- register_on_load(+ ret <- mt[, base_idx, drop = FALSE] |
||
| 23 | -! | +|||
| 85 | +
- "car", c("3.1.2", NA),
+ # if there is extra levels, replace it with -1/t_levels |
|||
| 24 | -! | +|||
| 86 | +16x |
- callback = car_add_mmrm,+ ret[is.na(ret)] <- -1 / t_levels |
||
| 25 | -! | +|||
| 87 | +16x |
- message = "mmrm() registered as car::Anova extension"+ ret |
||
| 26 | +88 |
- )+ } |
||
| 27 | +89 |
- }+ ) |
||
| 28 | -+ | |||
| 90 | +24x |
-
+ l_mx[, current_col] <- sub_mat |
||
| 29 | +91 |
- #' Helper Function for Registering Functionality With Suggests Packages+ } |
||
| 30 | +92 |
- #'+ } |
||
| 31 | -+ | |||
| 93 | +44x |
- #' @inheritParams check_package_version+ l_mx[abs(l_mx) < tol] <- 0+ |
+ ||
| 94 | +44x | +
+ l_mx |
||
| 32 | +95 |
- #'+ } |
||
| 33 | +96 |
- #' @param callback (`function(...) ANY`)\cr a callback to execute upon package+ |
||
| 34 | +97 |
- #' load. Note that no arguments are passed to this function. Any necessary+ #' Conduct type II/III hypothesis testing on the MMRM fit results. |
||
| 35 | +98 |
- #' data must be provided upon construction.+ #' |
||
| 36 | +99 |
- #'+ #' @param mod (`mmrm`)\cr the fitted MMRM. |
||
| 37 | +100 |
- #' @param message (`NULL` or `string`)\cr an optional message to print after+ #' @param ... not used. |
||
| 38 | +101 |
- #' the callback is executed upon successful registration.+ #' @inheritParams h_get_contrast |
||
| 39 | +102 |
#' |
||
| 40 | +103 |
- #' @return A logical (invisibly) indicating whether registration was successful.+ #' @details |
||
| 41 | +104 |
- #' If not, a onLoad hook was set for the next time the package is loaded.+ #' `Anova` will return `anova` object with one row per variable and columns |
||
| 42 | +105 |
- #'+ #' `Num Df`(numerator degrees of freedom), `Denom Df`(denominator degrees of freedom), |
||
| 43 | +106 |
- #' @keywords internal+ #' `F Statistic` and `Pr(>=F)`. |
||
| 44 | +107 |
- register_on_load <- function(pkg,+ #' |
||
| 45 | +108 |
- ver = c(NA_character_, NA_character_),+ #' @keywords internal |
||
| 46 | +109 |
- callback,+ # Please do not load `car` and then create the documentation. The Rd file will be different. |
||
| 47 | +110 |
- message = NULL) {
+ Anova.mmrm <- function(mod, type = c("II", "III", "2", "3"), tol = sqrt(.Machine$double.eps), ...) { # nolint
|
||
| 48 | -4x | +111 | +9x |
- if (isNamespaceLoaded(pkg) && check_package_version(pkg, ver)) {
+ assert_double(tol, finite = TRUE, len = 1L) |
| 49 | -3x | +112 | +9x |
- callback()+ type <- match.arg(type) |
| 50 | -2x | +113 | +9x |
- if (is.character(message)) packageStartupMessage(message)+ vars <- colnames(attr(terms(mod$formula_parts$model_formula), "factors")) |
| 51 | -1x | +114 | +9x |
- if (is.function(message)) packageStartupMessage(message())+ ret <- lapply( |
| 52 | -3x | +115 | +9x |
- return(invisible(TRUE))+ vars, |
| 53 | -+ | |||
| 116 | +9x |
- }+ function(x) df_md(mod, h_get_contrast(mod, x, type, tol)) |
||
| 54 | +117 |
-
+ ) |
||
| 55 | -1x | +118 | +9x |
- setHook(+ ret_df <- do.call(rbind.data.frame, ret) |
| 56 | -1x | +119 | +9x |
- packageEvent(pkg, event = "onLoad"),+ row.names(ret_df) <- vars |
| 57 | -1x | +120 | +9x |
- action = "append",+ colnames(ret_df) <- c("Num Df", "Denom Df", "F Statistic", "Pr(>=F)")
|
| 58 | -1x | +121 | +9x |
- function(...) {
+ class(ret_df) <- c("anova", "data.frame")
|
| 59 | -! | +|||
| 122 | +9x |
- register_on_load(+ attr(ret_df, "heading") <- sprintf( |
||
| 60 | -! | +|||
| 123 | +9x |
- pkg = pkg,+ "Analysis of Fixed Effect Table (Type %s F tests)", |
||
| 61 | -! | +|||
| 124 | +9x |
- ver = ver,+ switch(type, |
||
| 62 | -! | +|||
| 125 | +9x |
- callback = callback,+ "2" = , |
||
| 63 | -! | +|||
| 126 | +9x |
- message = message+ "II" = "II", |
||
| 64 | -+ | |||
| 127 | +9x |
- )+ "3" = , |
||
| 65 | -+ | |||
| 128 | +9x |
- }+ "III" = "III" |
||
| 66 | +129 |
- )+ ) |
||
| 67 | +130 |
-
+ ) |
||
| 68 | -1x | +131 | +9x |
- invisible(FALSE)+ ret_df |
| 69 | +132 |
} |
||
| 70 | +133 | |||
| 71 | +134 |
- #' Check Suggested Dependency Against Version Requirements+ |
||
| 72 | +135 |
- #'+ #' Obtain Levels Prior and Posterior |
||
| 73 | +136 |
- #' @param pkg (`string`)\cr package name.+ #' @param var (`string`) name of the effect. |
||
| 74 | +137 |
- #' @param ver (`character`)\cr of length 2 whose elements can be provided to+ #' @param additional_vars (`character`) names of additional variables. |
||
| 75 | +138 |
- #' [numeric_version()], representing a minimum and maximum (inclusive) version+ #' @param xlev (`list`) named list of character levels. |
||
| 76 | +139 |
- #' requirement for interoperability. When `NA`, no version requirement is+ #' @param factors (`matrix`) the factor matrix. |
||
| 77 | +140 |
- #' imposed. Defaults to no version requirement.+ #' @keywords internal |
||
| 78 | +141 |
- #'+ h_obtain_lvls <- function(var, additional_vars, xlev, factors) {
|
||
| 79 | -+ | |||
| 142 | +18x |
- #' @return A logical (invisibly) indicating whether the loaded package meets+ assert_string(var) |
||
| 80 | -+ | |||
| 143 | +18x |
- #' the version requirements. A warning is emitted otherwise.+ assert_character(additional_vars) |
||
| 81 | -+ | |||
| 144 | +18x |
- #'+ assert_list(xlev, types = "character") |
||
| 82 | -+ | |||
| 145 | +18x |
- #' @keywords internal+ nms <- names(xlev) |
||
| 83 | -+ | |||
| 146 | +18x |
- check_package_version <- function(pkg, ver = c(NA_character_, NA_character_)) {
+ assert_subset(additional_vars, nms) |
||
| 84 | -7x | +147 | +18x |
- assert_character(ver, len = 2L)+ if (var %in% nms) {
|
| 85 | -6x | +148 | +14x |
- pkg_ver <- utils::packageVersion(pkg)+ prior_vars <- intersect(nms[seq_len(match(var, nms) - 1)], additional_vars) |
| 86 | -6x | +149 | +14x |
- ver <- numeric_version(ver, strict = FALSE)+ prior_lvls <- vapply(xlev[prior_vars], length, FUN.VALUE = 1L) |
| 87 | -+ | |||
| 150 | +14x |
-
+ post_vars <- intersect(nms[seq(match(var, nms) + 1, length(nms))], additional_vars) |
||
| 88 | -6x | +151 | +14x |
- warn_version <- function(pkg, pkg_ver, ver) {
+ post_lvls <- vapply(xlev[post_vars], length, FUN.VALUE = 1L) |
| 89 | -2x | +152 | +14x |
- ver_na <- is.na(ver)+ total_lvls <- prod(prior_lvls) * prod(post_lvls) |
| 90 | -2x | +|||
| 153 | +
- warning(sprintf(+ } else {
|
|||
| 91 | -2x | +154 | +4x |
- "Cannot register mmrm for use with %s (v%s). Version %s required.",+ prior_lvls <- vapply(xlev[additional_vars], length, FUN.VALUE = 1L) |
| 92 | -2x | +155 | +4x |
- pkg, pkg_ver,+ post_lvls <- 2L |
| 93 | -2x | +156 | +4x |
- if (!any(ver_na)) {
+ total_lvls <- prod(prior_lvls) |
| 94 | -! | +|||
| 157 | +
- sprintf("%s to %s", ver[1], ver[2])
+ } |
|||
| 95 | -2x | +158 | +18x |
- } else if (ver_na[2]) {
+ list( |
| 96 | -1x | +159 | +18x |
- paste0(">= ", ver[1])
+ prior = prior_lvls, |
| 97 | -2x | +160 | +18x |
- } else if (ver_na[1]) {
+ post = post_lvls, |
| 98 | -1x | +161 | +18x |
- paste0("<= ", ver[2])
+ total = total_lvls |
| 99 | +162 |
- }+ ) |
||
| 100 | +163 |
- ))+ } |
||
| 101 | +164 |
- }+ |
||
| 102 | +165 |
-
+ #' Check if the Effect is the First Categorical Effect |
||
| 103 | -6x | +|||
| 166 | +
- if (identical(pkg_ver < ver[1], TRUE) || identical(pkg_ver > ver[2], TRUE)) {
+ #' @param effect (`string`) name of the effect. |
|||
| 104 | -2x | +|||
| 167 | +
- warn_version(pkg, pkg_ver, ver)+ #' @param categorical (`character`) names of the categorical values. |
|||
| 105 | -2x | +|||
| 168 | +
- return(invisible(FALSE))+ #' @param factors (`matrix`) the factor matrix. |
|||
| 106 | +169 |
- }+ #' @keywords internal |
||
| 107 | +170 |
-
+ h_first_contain_categorical <- function(effect, factors, categorical) {
|
||
| 108 | -4x | +171 | +9x |
- invisible(TRUE)+ assert_string(effect) |
| 109 | -+ | |||
| 172 | +9x |
- }+ assert_matrix(factors) |
||
| 110 | -+ | |||
| 173 | +9x |
-
+ assert_character(categorical) |
||
| 111 | -+ | |||
| 174 | +9x |
- #' Format a Message to Emit When Tidymodels is Loaded+ mt <- match(effect, colnames(factors)) |
||
| 112 | -+ | |||
| 175 | +9x |
- #'+ varnms <- row.names(factors) |
||
| 113 | +176 |
- #' @return A character message to emit. Either a ansi-formatted cli output if+ # if the effect is not categorical in any value, return FALSE |
||
| 114 | -+ | |||
| 177 | +9x |
- #' package 'cli' is available or a plain-text message otherwise.+ if (!any(varnms[factors[, mt] > 0] %in% categorical)) {
+ |
+ ||
| 178 | +2x | +
+ return(FALSE) |
||
| 115 | +179 |
- #'+ } |
||
| 116 | +180 |
- #' @keywords internal+ # keep only categorical rows that is in front of the current factor+ |
+ ||
| 181 | +7x | +
+ factors <- factors[row.names(factors) %in% categorical, seq_len(mt - 1L), drop = FALSE] |
||
| 117 | +182 |
- emit_tidymodels_register_msg <- function() {
+ # if previous cols are all numerical, return TRUE |
||
| 118 | -1x | +183 | +7x |
- pkg <- utils::packageName()+ if (ncol(factors) < 1L) {
|
| 119 | -1x | +184 | +4x |
- ver <- utils::packageVersion(pkg)+ return(TRUE) |
| 120 | +185 |
-
+ } |
||
| 121 | -1x | +186 | +3x |
- if (isTRUE(getOption("tidymodels.quiet"))) {
+ col_ind <- apply(factors, 2, prod) |
| 122 | -! | +|||
| 187 | +
- return()+ # if any of the previous cols are categorical, return FALSE |
|||
| 123 | -+ | |||
| 188 | +3x |
- }+ return(!any(col_ind > 0)) |
||
| 124 | +189 |
-
+ } |
||
| 125 | +190 |
- # if tidymodels is attached, cli packages come as a dependency+ |
||
| 126 | -1x | +|||
| 191 | +
- has_cli <- requireNamespace("cli", quietly = TRUE)
+ #' Test if the First Vector is Subset of the Second Vector |
|||
| 127 | -1x | +|||
| 192 | +
- if (has_cli) {
+ #' @param x (`vector`) the first list. |
|||
| 128 | +193 |
- # unfortunately, cli does not expose many formatting tools for emitting+ #' @param y (`vector`) the second list. |
||
| 129 | +194 |
- # messages (only via conditions to stderr) which can't be suppressed using+ #' @keywords internal |
||
| 130 | +195 |
- # suppressPackageStartupMessages() so formatting must be done adhoc,+ h_get_index <- function(x, y) {
|
||
| 131 | -+ | |||
| 196 | +18x |
- # similar to how it's done in {tidymodels} R/attach.R
+ assert_list(x) |
||
| 132 | -1x | +197 | +18x |
- paste0(+ assert_list(y) |
| 133 | -1x | +198 | +18x |
- cli::rule(+ vapply( |
| 134 | -1x | +199 | +18x |
- left = cli::style_bold("Model Registration"),
+ x, |
| 135 | -1x | +200 | +18x |
- right = paste(pkg, ver)+ \(i) {
|
| 136 | -+ | |||
| 201 | +68x |
- ),+ r <- vapply(y, \(j) test_subset(j, i), FUN.VALUE = TRUE) |
||
| 137 | -1x | +202 | +68x |
- "\n",+ if (sum(r) == 1L) {
|
| 138 | -1x | +203 | +65x |
- cli::col_green(cli::symbol$tick), " ",+ which(r)+ |
+
| 204 | ++ |
+ } else {
|
||
| 139 | -1x | +205 | +18x |
- cli::col_blue("mmrm"), "::", cli::col_green("mmrm()")
+ NA_integer_ |
| 140 | +206 |
- )+ } |
||
| 141 | +207 |
- } else {
+ }, |
||
| 142 | -! | +|||
| 208 | +18x |
- paste0(pkg, "::mmrm() registered for use with tidymodels")+ FUN.VALUE = 1L |
||
| 143 | +209 |
- }+ ) |
||
| 144 | +210 |
}@@ -18208,14 +17716,14 @@ mmrm coverage - 97.05% |
| 1 |
- #' Register `mmrm` For Use With `car::Anova`+ #' Covariance Type Database |
||
| 3 |
- #' @inheritParams base::requireNamespace+ #' An internal constant for covariance type information. |
||
| 4 |
- #' @return A logical value indicating whether registration was successful.+ #' |
||
| 5 |
- #'+ #' @format A data frame with 5 variables and one record per covariance type: |
||
| 6 |
- #' @keywords internal+ #' |
||
| 7 |
- car_add_mmrm <- function(quietly = FALSE) {
+ #' \describe{
|
||
| 8 | -1x | +
- if (!requireNamespace("car", quietly = quietly)) {
+ #' \item{name}{
|
|
| 9 | -! | +
- return(FALSE)+ #' The long-form name of the covariance structure type |
|
| 10 |
- }+ #' } |
||
| 11 | -1x | +
- envir <- asNamespace("mmrm")
+ #' \item{abbr}{
|
|
| 12 | -1x | +
- h_register_s3("car", "Anova", "mmrm", envir)
+ #' The abbreviated name of the covariance structure type |
|
| 13 | -1x | +
- TRUE+ #' } |
|
| 14 |
- }+ #' \item{habbr}{
|
||
| 15 |
-
+ #' The abbreviated name of the heterogeneous version of a covariance |
||
| 16 |
-
+ #' structure type (The abbreviated name (`abbr`) with a trailing `"h"` if |
||
| 17 |
- #' Obtain Contrast for Specified Effect+ #' the structure has a heterogeneous implementation or `NA` otherwise). |
||
| 18 |
- #'+ #' } |
||
| 19 |
- #' This is support function to obtain contrast matrix for type II/III testing.+ #' \item{heterogeneous}{
|
||
| 20 |
- #'+ #' A logical value indicating whether the covariance structure has a |
||
| 21 |
- #' @param object (`mmrm`)\cr the fitted MMRM.+ #' heterogeneous counterpart. |
||
| 22 |
- #' @param effect (`string`) the name of the effect.+ #' } |
||
| 23 |
- #' @param type (`string`) type of test, "II", "III", '2', or '3'.+ #' \item{spatial}{
|
||
| 24 |
- #' @param tol (`numeric`) threshold blow which values are treated as 0.+ #' A logical value indicating whether the covariance structure is spatial. |
||
| 25 |
- #'+ #' } |
||
| 26 |
- #' @return A `matrix` of the contrast.+ #' } |
||
| 29 |
- h_get_contrast <- function(object, effect, type = c("II", "III", "2", "3"), tol = sqrt(.Machine$double.eps)) {
+ COV_TYPES <- local({ # nolint
|
||
| 30 | -45x | +
- assert_class(object, "mmrm")+ type <- function(name, abbr, habbr, heterogeneous, spatial) {
|
|
| 31 | -45x | +
- assert_string(effect)+ args <- as.list(match.call()[-1]) |
|
| 32 | -45x | +
- assert_double(tol, finite = TRUE, len = 1L)+ do.call(data.frame, args) |
|
| 33 | -45x | +
- type <- match.arg(type)+ } |
|
| 34 | -45x | +
- mx <- component(object, "x_matrix")+ |
|
| 35 | -45x | +
- asg <- attr(mx, "assign")+ as.data.frame( |
|
| 36 | -45x | +
- formula <- object$formula_parts$model_formula+ col.names = names(formals(type)), |
|
| 37 | -45x | +
- tms <- terms(formula)+ rbind( |
|
| 38 | -45x | +
- fcts <- attr(tms, "factors")[-1L, , drop = FALSE] # Discard the response.+ type("unstructured", "us", NA, FALSE, FALSE),
|
|
| 39 | -45x | +
- ods <- attr(tms, "order")+ type("Toeplitz", "toep", "toeph", TRUE, FALSE),
|
|
| 40 | -45x | +
- assert_subset(effect, colnames(fcts))+ type("auto-regressive order one", "ar1", "ar1h", TRUE, FALSE),
|
|
| 41 | -45x | +
- idx <- which(effect == colnames(fcts))+ type("ante-dependence", "ad", "adh", TRUE, FALSE),
|
|
| 42 | -45x | +
- cols <- which(asg == idx)+ type("compound symmetry", "cs", "csh", TRUE, FALSE),
|
|
| 43 | -45x | +
- xlev <- component(object, "xlev")+ type("spatial exponential", "sp_exp", NA, FALSE, TRUE)
|
|
| 44 | -45x | +
- contains_intercept <- (!0 %in% asg) && h_first_contain_categorical(effect, fcts, names(xlev))+ ) |
|
| 45 | -45x | +
- coef_rows <- length(cols) - as.integer(contains_intercept)+ ) |
|
| 46 | -45x | +
- l_mx <- matrix(0, nrow = coef_rows, ncol = length(asg))+ }) |
|
| 47 | -45x | +
- if (coef_rows == 0L) {
+
|
|
| 48 | -1x | +
- return(l_mx)+ #' Covariance Types |
|
| 49 |
- }+ #' |
||
| 50 | -44x | +
- if (contains_intercept) {
+ #' @description `r lifecycle::badge("stable")`
|
|
| 51 | -4x | +
- l_mx[, cols] <- cbind(-1, diag(rep(1, coef_rows)))+ #' |
|
| 52 |
- } else {
+ #' @param form (`character`)\cr covariance structure type name form. One or |
||
| 53 | -40x | +
- l_mx[, cols] <- diag(rep(1, coef_rows))+ #' more of `"name"`, `"abbr"` (abbreviation), or `"habbr"` (heterogeneous |
|
| 54 |
- }+ #' abbreviation). |
||
| 55 | -44x | +
- for (i in setdiff(seq_len(ncol(fcts)), idx)) {
+ #' @param filter (`character`)\cr covariance structure type filter. One or |
|
| 56 | -120x | +
- additional_vars <- names(which(fcts[, i] > fcts[, idx]))+ #' more of `"heterogeneous"` or `"spatial"`. |
|
| 57 | -120x | +
- additional_numeric <- any(!additional_vars %in% names(xlev))+ #' |
|
| 58 | -120x | +
- current_col <- which(asg == i)+ #' @return A character vector of accepted covariance structure type names and |
|
| 59 | -120x | +
- if (ods[i] >= ods[idx] && all(fcts[, i] >= fcts[, idx]) && !additional_numeric) {
+ #' abbreviations. |
|
| 60 | -24x | +
- sub_mat <- switch(type,+ #' |
|
| 61 | -24x | +
- "2" = ,+ #' @section Abbreviations for Covariance Structures: |
|
| 62 | -24x | +
- "II" = {
+ #' |
|
| 63 | -8x | +
- x1 <- mx[, cols, drop = FALSE]+ #' ## Common Covariance Structures: |
|
| 64 | -8x | +
- x0 <- mx[, -c(cols, current_col), drop = FALSE]+ #' |
|
| 65 | -8x | +
- x2 <- mx[, current_col, drop = FALSE]+ #' \tabular{clll}{
|
|
| 66 | -8x | +
- m <- diag(rep(1, nrow(x0))) - x0 %*% solve(t(x0) %*% x0) %*% t(x0)+ #' |
|
| 67 | -8x | +
- ret <- solve(t(x1) %*% m %*% x1) %*% t(x1) %*% m %*% x2+ #' \strong{Structure}
|
|
| 68 | -8x | +
- if (contains_intercept) {
+ #' \tab \strong{Description}
|
|
| 69 | -1x | +
- ret[-1, ] - ret[1, ]+ #' \tab \strong{Parameters}
|
|
| 70 |
- } else {
+ #' \tab \strong{\eqn{(i, j)} element}
|
||
| 71 | -7x | +
- ret+ #' \cr |
|
| 72 |
- }+ #' |
||
| 73 |
- },+ #' ad |
||
| 74 | -24x | +
- "3" = ,+ #' \tab Ante-dependence |
|
| 75 | -24x | +
- "III" = {
+ #' \tab \eqn{m}
|
|
| 76 | -16x | +
- lvls <- h_obtain_lvls(effect, additional_vars, xlev)+ #' \tab \eqn{\sigma^{2}\prod_{k=i}^{j-1}\rho_{k}}
|
|
| 77 | -16x | +
- t_levels <- lvls$total+ #' \cr |
|
| 78 | -16x | +
- nms_base <- colnames(mx)[cols]+ #' |
|
| 79 | -16x | +
- nms <- colnames(mx)[current_col]+ #' adh |
|
| 80 | -16x | +
- nms_base_split <- strsplit(nms_base, ":")+ #' \tab Heterogeneous ante-dependence |
|
| 81 | -16x | +
- nms_split <- strsplit(nms, ":")+ #' \tab \eqn{2m-1}
|
|
| 82 | -16x | +
- base_idx <- h_get_index(nms_split, nms_base_split)+ #' \tab \eqn{\sigma_{i}\sigma_{j}\prod_{k=i}^{j-1}\rho_{k}}
|
|
| 83 | -16x | +
- mt <- l_mx[, cols, drop = FALSE] / t_levels+ #' \cr |
|
| 84 | -16x | +
- ret <- mt[, base_idx, drop = FALSE]+ #' |
|
| 85 |
- # if there is extra levels, replace it with -1/t_levels+ #' ar1 |
||
| 86 | -16x | +
- ret[is.na(ret)] <- -1 / t_levels+ #' \tab First-order auto-regressive |
|
| 87 | -16x | +
- ret+ #' \tab \eqn{2}
|
|
| 88 |
- }+ #' \tab \eqn{\sigma^{2}\rho^{\left \vert {i-j} \right \vert}}
|
||
| 89 |
- )+ #' \cr |
||
| 90 | -24x | +
- l_mx[, current_col] <- sub_mat+ #' |
|
| 91 |
- }+ #' ar1h |
||
| 92 |
- }+ #' \tab Heterogeneous first-order auto-regressive |
||
| 93 | -44x | +
- l_mx[abs(l_mx) < tol] <- 0+ #' \tab \eqn{m+1}
|
|
| 94 | -44x | +
- l_mx+ #' \tab \eqn{\sigma_{i}\sigma_{j}\rho^{\left \vert {i-j} \right \vert}}
|
|
| 95 |
- }+ #' \cr |
||
| 96 |
-
+ #' |
||
| 97 |
- #' Conduct type II/III hypothesis testing on the MMRM fit results.+ #' cs |
||
| 98 |
- #'+ #' \tab Compound symmetry |
||
| 99 |
- #' @param mod (`mmrm`)\cr the fitted MMRM.+ #' \tab \eqn{2}
|
||
| 100 |
- #' @param ... not used.+ #' \tab \eqn{\sigma^{2}\left[ \rho I(i \neq j)+I(i=j) \right]}
|
||
| 101 |
- #' @inheritParams h_get_contrast+ #' \cr |
||
| 103 |
- #' @details+ #' csh |
||
| 104 |
- #' `Anova` will return `anova` object with one row per variable and columns+ #' \tab Heterogeneous compound symmetry |
||
| 105 |
- #' `Num Df`(numerator degrees of freedom), `Denom Df`(denominator degrees of freedom),+ #' \tab \eqn{m+1}
|
||
| 106 |
- #' `F Statistic` and `Pr(>=F)`.+ #' \tab \eqn{\sigma_{i}\sigma_{j}\left[ \rho I(i \neq j)+I(i=j) \right]}
|
||
| 107 |
- #'+ #' \cr |
||
| 108 |
- #' @keywords internal+ #' |
||
| 109 |
- # Please do not load `car` and then create the documentation. The Rd file will be different.+ #' toep |
||
| 110 |
- Anova.mmrm <- function(mod, type = c("II", "III", "2", "3"), tol = sqrt(.Machine$double.eps), ...) { # nolint
+ #' \tab Toeplitz |
||
| 111 | -9x | +
- assert_double(tol, finite = TRUE, len = 1L)+ #' \tab \eqn{m}
|
|
| 112 | -9x | +
- type <- match.arg(type)+ #' \tab \eqn{\sigma_{\left \vert {i-j} \right \vert +1}}
|
|
| 113 | -9x | +
- vars <- colnames(attr(terms(mod$formula_parts$model_formula), "factors"))+ #' \cr |
|
| 114 | -9x | +
- ret <- lapply(+ #' |
|
| 115 | -9x | +
- vars,+ #' toeph |
|
| 116 | -9x | +
- function(x) df_md(mod, h_get_contrast(mod, x, type, tol))+ #' \tab Heterogeneous Toeplitz |
|
| 117 |
- )+ #' \tab \eqn{2m-1}
|
||
| 118 | -9x | +
- ret_df <- do.call(rbind.data.frame, ret)+ #' \tab \eqn{\sigma_{i}\sigma_{j}\rho_{\left \vert {i-j} \right \vert}}
|
|
| 119 | -9x | +
- row.names(ret_df) <- vars+ #' \cr |
|
| 120 | -9x | +
- colnames(ret_df) <- c("Num Df", "Denom Df", "F Statistic", "Pr(>=F)")
+ #' |
|
| 121 | -9x | +
- class(ret_df) <- c("anova", "data.frame")
+ #' us |
|
| 122 | -9x | +
- attr(ret_df, "heading") <- sprintf(+ #' \tab Unstructured |
|
| 123 | -9x | +
- "Analysis of Fixed Effect Table (Type %s F tests)",+ #' \tab \eqn{m(m+1)/2}
|
|
| 124 | -9x | +
- switch(type,+ #' \tab \eqn{\sigma_{ij}}
|
|
| 125 | -9x | +
- "2" = ,+ #' |
|
| 126 | -9x | +
- "II" = "II",+ #' } |
|
| 127 | -9x | +
- "3" = ,+ #' |
|
| 128 | -9x | +
- "III" = "III"+ #' 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 | -9x | +
- ret_df+ #' @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. |
||
| 135 |
- #' Obtain Levels Prior and Posterior+ #' |
||
| 136 |
- #' @param var (`string`) name of the effect.+ #' @note For all non-spatial covariance structures, the time variable must |
||
| 137 |
- #' @param additional_vars (`character`) names of additional variables.+ #' be coded as a factor. |
||
| 138 |
- #' @param xlev (`list`) named list of character levels.+ #' |
||
| 139 |
- #' @param factors (`matrix`) the factor matrix.+ #' ## Spatial Covariance structures: |
||
| 140 |
- #' @keywords internal+ #' |
||
| 141 |
- h_obtain_lvls <- function(var, additional_vars, xlev, factors) {
+ #' \tabular{clll}{
|
||
| 142 | -18x | +
- assert_string(var)+ #' |
|
| 143 | -18x | +
- assert_character(additional_vars)+ #' \strong{Structure}
|
|
| 144 | -18x | +
- assert_list(xlev, types = "character")+ #' \tab \strong{Description}
|
|
| 145 | -18x | +
- nms <- names(xlev)+ #' \tab \strong{Parameters}
|
|
| 146 | -18x | +
- assert_subset(additional_vars, nms)+ #' \tab \strong{\eqn{(i, j)} element}
|
|
| 147 | -18x | +
- if (var %in% nms) {
+ #' \cr |
|
| 148 | -14x | +
- prior_vars <- intersect(nms[seq_len(match(var, nms) - 1)], additional_vars)+ #' |
|
| 149 | -14x | +
- prior_lvls <- vapply(xlev[prior_vars], length, FUN.VALUE = 1L)+ #' sp_exp |
|
| 150 | -14x | +
- post_vars <- intersect(nms[seq(match(var, nms) + 1, length(nms))], additional_vars)+ #' \tab spatial exponential |
|
| 151 | -14x | +
- post_lvls <- vapply(xlev[post_vars], length, FUN.VALUE = 1L)+ #' \tab \eqn{2}
|
|
| 152 | -14x | +
- total_lvls <- prod(prior_lvls) * prod(post_lvls)+ #' \tab \eqn{\sigma^{2}\rho^{-d_{ij}}}
|
|
| 153 |
- } else {
+ #' |
||
| 154 | -4x | +
- prior_lvls <- vapply(xlev[additional_vars], length, FUN.VALUE = 1L)+ #' } |
|
| 155 | -4x | +
- post_lvls <- 2L+ #' |
|
| 156 | -4x | +
- total_lvls <- prod(prior_lvls)+ #' where \eqn{d_{ij}} denotes the Euclidean distance between time points
|
|
| 157 |
- }+ #' \eqn{i} and \eqn{j}.
|
||
| 158 | -18x | +
- list(+ #' |
|
| 159 | -18x | +
- prior = prior_lvls,+ #' @family covariance types |
|
| 160 | -18x | +
- post = post_lvls,+ #' @name covariance_types |
|
| 161 | -18x | +
- total = total_lvls+ #' @export |
|
| 162 |
- )+ cov_types <- function( |
||
| 163 |
- }+ form = c("name", "abbr", "habbr"),
|
||
| 164 |
-
+ filter = c("heterogeneous", "spatial")) {
|
||
| 165 | -+ | 1666x |
- #' Check if the Effect is the First Categorical Effect+ form <- match.arg(form, several.ok = TRUE) |
| 166 | -+ | 1666x |
- #' @param effect (`string`) name of the effect.+ filter <- if (missing(filter)) c() else match.arg(filter, several.ok = TRUE) |
| 167 | -+ | 1666x |
- #' @param categorical (`character`) names of the categorical values.+ df <- COV_TYPES[form][rowSums(!COV_TYPES[filter]) == 0, ] |
| 168 | -+ | 1666x |
- #' @param factors (`matrix`) the factor matrix.+ Filter(Negate(is.na), unlist(t(df), use.names = FALSE)) |
| 169 |
- #' @keywords internal+ } |
||
| 170 |
- h_first_contain_categorical <- function(effect, factors, categorical) {
+
|
||
| 171 | -9x | +
- assert_string(effect)+ #' Retrieve Associated Abbreviated Covariance Structure Type Name |
|
| 172 | -9x | +
- assert_matrix(factors)+ #' |
|
| 173 | -9x | +
- assert_character(categorical)+ #' @param type (`string`)\cr either a full name or abbreviate covariance |
|
| 174 | -9x | +
- mt <- match(effect, colnames(factors))+ #' structure type name to collapse into an abbreviated type. |
|
| 175 | -9x | +
- varnms <- row.names(factors)+ #' |
|
| 176 |
- # if the effect is not categorical in any value, return FALSE+ #' @return The corresponding abbreviated covariance type name. |
||
| 177 | -9x | +
- if (!any(varnms[factors[, mt] > 0] %in% categorical)) {
+ #' |
|
| 178 | -2x | +
- return(FALSE)+ #' @keywords internal |
|
| 179 |
- }+ cov_type_abbr <- function(type) {
|
||
| 180 | -+ | 299x |
- # keep only categorical rows that is in front of the current factor+ row <- which(COV_TYPES == type, arr.ind = TRUE)[, 1] |
| 181 | -7x | +299x |
- factors <- factors[row.names(factors) %in% categorical, seq_len(mt - 1L), drop = FALSE]+ COV_TYPES$abbr[row] |
| 182 |
- # if previous cols are all numerical, return TRUE+ } |
||
| 183 | -7x | +
- if (ncol(factors) < 1L) {
+
|
|
| 184 | -4x | +
- return(TRUE)+ #' Retrieve Associated Full Covariance Structure Type Name |
|
| 185 |
- }+ #' |
||
| 186 | -3x | +
- col_ind <- apply(factors, 2, prod)+ #' @param type (`string`)\cr either a full name or abbreviate covariance |
|
| 187 |
- # if any of the previous cols are categorical, return FALSE+ #' structure type name to convert to a long-form type. |
||
| 188 | -3x | +
- return(!any(col_ind > 0))+ #' |
|
| 189 |
- }+ #' @return The corresponding abbreviated covariance type name. |
||
| 190 |
-
+ #' |
||
| 191 |
- #' Test if the First Vector is Subset of the Second Vector+ #' @keywords internal |
||
| 192 |
- #' @param x (`vector`) the first list.+ cov_type_name <- function(type) {
|
||
| 193 | -+ | 6x |
- #' @param y (`vector`) the second list.+ row <- which(COV_TYPES == type, arr.ind = TRUE)[, 1] |
| 194 | -+ | 6x |
- #' @keywords internal+ COV_TYPES$name[row] |
| 195 |
- h_get_index <- function(x, y) {
+ } |
||
| 196 | -18x | +
- assert_list(x)+ |
|
| 197 | -18x | +
- assert_list(y)+ #' Produce A Covariance Identifier Passing to TMB |
|
| 198 | -18x | +
- vapply(+ #' |
|
| 199 | -18x | +
- x,+ #' @param cov (`cov_struct`)\cr a covariance structure object. |
|
| 200 | -18x | +
- \(i) {
+ #' |
|
| 201 | -68x | +
- r <- vapply(y, \(j) test_subset(j, i), FUN.VALUE = TRUE)+ #' @return A string used for method dispatch when passed to TMB. |
|
| 202 | -68x | +
- if (sum(r) == 1L) {
+ #' |
|
| 203 | -65x | +
- which(r)+ #' @keywords internal |
|
| 204 |
- } else {
+ tmb_cov_type <- function(cov) {
|
||
| 205 | -18x | +266x |
- NA_integer_+ paste0(cov$type, if (cov$heterogeneous) "h") |
| 206 |
- }+ } |
||
| 207 |
- },+ |
||
| 208 | -18x | +
- FUN.VALUE = 1L+ #' Define a Covariance Structure |
|
| 209 |
- )+ #' |
||
| 210 |
- }+ #' @description `r lifecycle::badge("stable")`
|
| 1 | +211 |
- #' Obtain Kenward-Roger Adjustment Components+ #' |
||
| 2 | +212 |
- #'+ #' @param type (`string`)\cr the name of the covariance structure type to use. |
||
| 3 | +213 |
- #' @description Obtains the components needed downstream for the computation of Kenward-Roger degrees of freedom.+ #' For available options, see `cov_types()`. If a type abbreviation is used |
||
| 4 | +214 |
- #' Used in [mmrm()] fitting if method is "Kenward-Roger".+ #' that implies heterogeneity (e.g. `cph`) and no value is provided to |
||
| 5 | +215 |
- #'+ #' `heterogeneous`, then the heterogeneity is derived from the type name. |
||
| 6 | +216 |
- #' @param tmb_data (`mmrm_tmb_data`)\cr produced by [h_mmrm_tmb_data()].+ #' @param visits (`character`)\cr a vector of variable names to use for the |
||
| 7 | +217 |
- #' @param theta (`numeric`)\cr theta estimate.+ #' longitudinal terms of the covariance structure. Multiple terms are only |
||
| 8 | +218 |
- #'+ #' permitted for the `"spatial"` covariance type. |
||
| 9 | +219 |
- #' @details the function returns a named list, \eqn{P}, \eqn{Q} and \eqn{R}, which corresponds to the
+ #' @param subject (`string`)\cr the name of the variable that encodes a subject |
||
| 10 | +220 |
- #' paper in 1997. The matrices are stacked in columns so that \eqn{P}, \eqn{Q} and \eqn{R} has the same
+ #' identifier. |
||
| 11 | +221 |
- #' column number(number of beta parameters). The number of rows, is dependent on+ #' @param group (`string`)\cr optionally, the name of the variable that encodes |
||
| 12 | +222 |
- #' the total number of theta and number of groups, if the fit is a grouped mmrm.+ #' a grouping variable for subjects. |
||
| 13 | +223 |
- #' For \eqn{P} matrix, it is stacked sequentially. For \eqn{Q} and \eqn{R} matrix, it is stacked so
+ #' @param heterogeneous (`flag`)\cr |
||
| 14 | +224 |
- #' 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 | +225 |
- #' \eqn{Q} and \eqn{R} only contains intra-group results and inter-group results should be all zero matrices
+ #' @return A `cov_struct` object. |
||
| 16 | +226 |
- #' so they are not stacked in the result.+ #' |
||
| 17 | +227 |
- #'+ #' @examples |
||
| 18 | +228 |
- #' @return Named list with elements:+ #' cov_struct("csh", "AVISITN", "USUBJID")
|
||
| 19 | +229 |
- #' - `P`: `matrix` of \eqn{P} component.
+ #' cov_struct("spatial", c("VISITA", "VISITB"), group = "GRP", subject = "SBJ")
|
||
| 20 | +230 |
- #' - `Q`: `matrix` of \eqn{Q} component.
+ #' |
||
| 21 | +231 |
- #' - `R`: `matrix` of \eqn{R} component.
+ #' @family covariance types |
||
| 22 | +232 |
- #'+ #' @export |
||
| 23 | +233 |
- #' @keywords internal+ cov_struct <- function( |
||
| 24 | +234 |
- h_get_kr_comp <- function(tmb_data, theta) {
+ type = cov_types(), visits, subject, group = character(),+ |
+ ||
| 235 | ++ |
+ heterogeneous = FALSE) {
+ |
+ ||
| 236 | ++ |
+ # if heterogeneous isn't provided, derive from provided type |
||
| 25 | -47x | +237 | +296x |
- assert_class(tmb_data, "mmrm_tmb_data")+ if (missing(heterogeneous)) {
|
| 26 | -47x | +238 | +294x |
- assert_class(theta, "numeric")+ heterogeneous <- switch(type, |
| 27 | -47x | +239 | +294x |
- .Call(`_mmrm_get_pqr`, PACKAGE = "mmrm", tmb_data, theta)+ toeph = , |
| 28 | -+ | |||
| 240 | +294x |
- }+ ar1h = , |
||
| 29 | -+ | |||
| 241 | +294x |
-
+ adh = , |
||
| 30 | -+ | |||
| 242 | +294x |
- #' Calculation of Kenward-Roger Degrees of Freedom for Multi-Dimensional Contrast+ csh = TRUE, |
||
| 31 | -+ | |||
| 243 | +294x |
- #'+ heterogeneous |
||
| 32 | +244 |
- #' @description Used in [df_md()] if method is "Kenward-Roger" or "Kenward-Roger-Linear".+ ) |
||
| 33 | +245 |
- #'+ } |
||
| 34 | +246 |
- #' @inheritParams h_df_md_sat+ |
||
| 35 | +247 |
- #' @inherit h_df_md_sat return+ # coerce all type options into abbreviated form |
||
| 36 | -+ | |||
| 248 | +296x |
- #' @keywords internal+ type <- match.arg(type)+ |
+ ||
| 249 | +295x | +
+ type <- cov_type_abbr(type) |
||
| 37 | +250 |
- h_df_md_kr <- function(object, contrast) {
+
|
||
| 38 | -6x | +251 | +295x |
- assert_class(object, "mmrm")+ x <- structure( |
| 39 | -6x | +252 | +295x |
- assert_matrix(contrast, mode = "numeric", any.missing = FALSE, ncols = length(component(object, "beta_est")))+ list( |
| 40 | -6x | +253 | +295x |
- if (component(object, "reml") != 1) {
+ type = type, |
| 41 | -! | +|||
| 254 | +295x |
- stop("Kenward-Roger is only for REML")
+ heterogeneous = heterogeneous, |
||
| 42 | -+ | |||
| 255 | +295x |
- }+ visits = visits, |
||
| 43 | -6x | +256 | +295x |
- kr_comp <- object$kr_comp+ subject = subject, |
| 44 | -6x | +257 | +295x |
- w <- component(object, "theta_vcov")+ group = group+ |
+
| 258 | ++ |
+ ), |
||
| 45 | -6x | +259 | +295x |
- v_adj <- object$beta_vcov_adj+ class = c("cov_struct", "mmrm_cov_struct", "list")
|
| 46 | -6x | +|||
| 260 | +
- df <- h_kr_df(v0 = object$beta_vcov, l = contrast, w = w, p = kr_comp$P)+ ) |
|||
| 47 | +261 | |||
| 48 | -6x | +262 | +295x |
- h_test_md(object, contrast, df = df$m, f_stat_factor = df$lambda)+ validate_cov_struct(x) |
| 49 | +263 |
} |
||
| 50 | +264 | |||
| 51 | +265 |
- #' Calculation of Kenward-Roger Degrees of Freedom for One-Dimensional Contrast+ #' Reconcile Possible Covariance Structure Inputs |
||
| 52 | +266 |
#' |
||
| 53 | +267 |
- #' @description Used in [df_1d()] if method is+ #' @inheritParams mmrm |
||
| 54 | +268 |
- #' "Kenward-Roger" or "Kenward-Roger-Linear".+ #' |
||
| 55 | +269 |
- #'+ #' @return The value `covariance` if it's provided or a covariance structure |
||
| 56 | +270 |
- #' @inheritParams h_df_1d_sat+ #' derived from the provided `formula` otherwise. An error is raised of both |
||
| 57 | +271 |
- #' @inherit h_df_1d_sat return+ #' are provided. |
||
| 58 | +272 |
- #' @keywords internal+ #' |
||
| 59 | +273 |
- h_df_1d_kr <- function(object, contrast) {
+ #' @keywords internal |
||
| 60 | -21x | +|||
| 274 | +
- assert_class(object, "mmrm")+ h_reconcile_cov_struct <- function(formula = NULL, covariance = NULL) {
|
|||
| 61 | -21x | +275 | +238x |
- assert_numeric(contrast, len = length(component(object, "beta_est")))+ assert_multi_class(covariance, c("formula", "cov_struct"), null.ok = TRUE)
|
| 62 | -21x | +276 | +238x |
- if (component(object, "reml") != 1) {
+ assert_formula(formula, null.ok = FALSE) |
| 63 | -! | +|||
| 277 | +238x |
- stop("Kenward-Roger is only for REML!")
+ if (inherits(covariance, "formula")) {
|
||
| 64 | -+ | |||
| 278 | +4x |
- }+ covariance <- as.cov_struct(covariance) |
||
| 65 | +279 |
-
+ } |
||
| 66 | -21x | +280 | +238x |
- df <- h_kr_df(+ if (!is.null(covariance) && length(h_extract_covariance_terms(formula)) > 0) {
|
| 67 | -21x | +281 | +2x |
- v0 = object$beta_vcov,+ stop(paste0( |
| 68 | -21x | +282 | +2x |
- l = matrix(contrast, nrow = 1),+ "Redundant covariance structure definition in `formula` and ", |
| 69 | -21x | +283 | +2x |
- w = component(object, "theta_vcov"),+ "`covariance` arguments" |
| 70 | -21x | +|||
| 284 | +
- p = object$kr_comp$P+ )) |
|||
| 71 | +285 |
- )+ } |
||
| 72 | +286 | |||
| 73 | -21x | +287 | +236x |
- h_test_1d(object, contrast, df$m)+ if (!is.null(covariance)) {
|
| 74 | -+ | |||
| 288 | +5x |
- }+ return(covariance) |
||
| 75 | +289 |
-
+ } |
||
| 76 | +290 |
- #' Obtain the Adjusted Kenward-Roger degrees of freedom+ |
||
| 77 | -+ | |||
| 291 | +231x |
- #'+ as.cov_struct(formula, warn_partial = FALSE) |
||
| 78 | +292 |
- #' @description Obtains the adjusted Kenward-Roger degrees of freedom and F statistic scale parameter.+ } |
||
| 79 | +293 |
- #' Used in [h_df_md_kr()] or [h_df_1d_kr].+ |
||
| 80 | +294 |
- #'+ #' Validate Covariance Structure Data |
||
| 81 | +295 |
- #' @param v0 (`matrix`)\cr unadjusted covariance matrix.+ #' |
||
| 82 | +296 |
- #' @param l (`matrix`)\cr linear combination matrix.+ #' Run checks against relational integrity of covariance definition |
||
| 83 | +297 |
- #' @param w (`matrix`)\cr hessian matrix.+ #' |
||
| 84 | +298 |
- #' @param p (`matrix`)\cr P matrix from [h_get_kr_comp()].+ #' @param x (`cov_struct`)\cr a covariance structure object. |
||
| 85 | +299 |
#' |
||
| 86 | +300 |
- #' @return Named list with elements:+ #' @return `x` if successful, or an error is thrown otherwise. |
||
| 87 | +301 |
- #' - `m`: `numeric` degrees of freedom.+ #' |
||
| 88 | +302 |
- #' - `lambda`: `numeric` F statistic scale parameter.+ #' @keywords internal |
||
| 89 | +303 |
- #'+ validate_cov_struct <- function(x) {
|
||
| 90 | -+ | |||
| 304 | +295x |
- #' @keywords internal+ checks <- checkmate::makeAssertCollection() |
||
| 91 | +305 |
- h_kr_df <- function(v0, l, w, p) {
+
|
||
| 92 | -28x | +306 | +295x |
- n_beta <- ncol(v0)+ with(x, {
|
| 93 | -28x | +307 | +295x |
- assert_matrix(v0, ncols = n_beta, nrows = n_beta)+ assert_character(subject, len = 1, add = checks) |
| 94 | -28x | +308 | +295x |
- assert_matrix(l, ncols = n_beta)+ assert_logical(heterogeneous, len = 1, add = checks) |
| 95 | -28x | +|||
| 309 | +
- n_theta <- ncol(w)+ |
|||
| 96 | -28x | +310 | +295x |
- assert_matrix(w, ncols = n_theta, nrows = n_theta)+ if (length(group) > 1 || length(visits) < 1) {
|
| 97 | -28x | +311 | +4x |
- n_visits <- ncol(p)+ checks$push( |
| 98 | -28x | +312 | +4x |
- assert_matrix(p, nrows = n_visits * n_theta)+ "Covariance structure must be of the form `time | (group /) subject`" |
| 99 | +313 |
- # see vignettes/kenward.Rmd#279+ ) |
||
| 100 | -28x | +|||
| 314 | +
- slvol <- solve(h_quad_form_mat(l, v0))+ } |
|||
| 101 | -28x | +|||
| 315 | +
- m <- h_quad_form_mat(t(l), slvol)+ |
|||
| 102 | -28x | +316 | +295x |
- nl <- nrow(l)+ if (!type %in% cov_types(filter = "spatial") && length(visits) > 1) {
|
| 103 | -28x | +317 | +2x |
- mv0 <- m %*% v0+ checks$push(paste( |
| 104 | -28x | +318 | +2x |
- pl <- lapply(seq_len(nrow(p) / ncol(p)), function(x) {
+ "Non-spatial covariance structures must have a single longitudinal", |
| 105 | -108x | +319 | +2x |
- ii <- (x - 1) * ncol(p) + 1+ "variable" |
| 106 | -108x | +|||
| 320 | +
- jj <- x * ncol(p)+ )) |
|||
| 107 | -108x | +|||
| 321 | +
- p[ii:jj, ]+ } |
|||
| 108 | +322 |
}) |
||
| 323 | ++ | + + | +||
| 109 | -28x | +324 | +295x |
- mv0pv0 <- lapply(pl, function(x) {
+ reportAssertions(checks) |
| 110 | -108x | +325 | +289x |
- mv0 %*% x %*% v0+ x |
| 111 | +326 |
- })+ } |
||
| 112 | -28x | +|||
| 327 | +
- a1 <- 0+ |
|||
| 113 | -28x | +|||
| 328 | +
- a2 <- 0+ #' Format Covariance Structure Object |
|||
| 114 | +329 |
- # see vignettes/kenward.Rmd#283+ #' |
||
| 115 | -28x | +|||
| 330 | +
- for (i in seq_len(length(pl))) {
+ #' @param x (`cov_struct`)\cr a covariance structure object. |
|||
| 116 | -108x | +|||
| 331 | +
- for (j in seq_len(length(pl))) {
+ #' @param ... Additional arguments unused. |
|||
| 117 | -592x | +|||
| 332 | +
- a1 <- a1 + w[i, j] * h_tr(mv0pv0[[i]]) * h_tr(mv0pv0[[j]])+ #' |
|||
| 118 | -592x | +|||
| 333 | +
- a2 <- a2 + w[i, j] * h_tr(mv0pv0[[i]] %*% mv0pv0[[j]])+ #' @return A formatted string for `x`. |
|||
| 119 | +334 |
- }+ #' |
||
| 120 | +335 |
- }+ #' @export |
||
| 121 | -28x | +|||
| 336 | +
- b <- 1 / (2 * nl) * (a1 + 6 * a2)+ format.cov_struct <- function(x, ...) {
|
|||
| 122 | -28x | +337 | +3x |
- e <- 1 + a2 / nl+ sprintf( |
| 123 | -28x | +338 | +3x |
- e_star <- 1 / (1 - a2 / nl)+ "<covariance structure>\n%s%s:\n\n %s | %s%s\n", |
| 124 | -28x | +339 | +3x |
- g <- ((nl + 1) * a1 - (nl + 4) * a2) / ((nl + 2) * a2)+ if (x$heterogeneous) "heterogeneous " else "", |
| 125 | -28x | +340 | +3x |
- denom <- (3 * nl + 2 - 2 * g)+ cov_type_name(x$type), |
| 126 | -28x | +341 | +3x |
- c1 <- g / denom+ format_symbols(x$visits), |
| 127 | -28x | +342 | +3x |
- c2 <- (nl - g) / denom+ if (length(x$group) > 0) paste0(format_symbols(x$group), " / ") else "", |
| 128 | -28x | +343 | +3x |
- c3 <- (nl + 2 - g) / denom+ format_symbols(x$subject) |
| 129 | -28x | +|||
| 344 | +
- v_star <- 2 / nl * (1 + c1 * b) / (1 - c2 * b)^2 / (1 - c3 * b)+ ) |
|||
| 130 | -28x | +|||
| 345 | +
- rho <- v_star / (2 * e_star^2)+ } |
|||
| 131 | -28x | +|||
| 346 | +
- m <- 4 + (nl + 2) / (nl * rho - 1)+ |
|||
| 132 | -28x | +|||
| 347 | +
- lambda <- m / (e_star * (m - 2))+ #' Print a Covariance Structure Object |
|||
| 133 | -28x | +|||
| 348 | +
- list(m = m, lambda = lambda)+ #'+ |
+ |||
| 349 | ++ |
+ #' @param x (`cov_struct`)\cr a covariance structure object. |
||
| 134 | +350 |
- }+ #' @param ... Additional arguments unused. |
||
| 135 | +351 |
-
+ #' |
||
| 136 | +352 |
- #' Obtain the Adjusted Covariance Matrix+ #' @return `x` invisibly. |
||
| 137 | +353 |
#' |
||
| 138 | +354 |
- #' @description Obtains the Kenward-Roger adjusted covariance matrix for the+ #' @export |
||
| 139 | +355 |
- #' coefficient estimates.+ print.cov_struct <- function(x, ...) {
|
||
| 140 | -+ | |||
| 356 | +3x |
- #' Used in [mmrm()] fitting if method is "Kenward-Roger" or "Kenward-Roger-Linear".+ cat(format(x, ...), "\n")+ |
+ ||
| 357 | +3x | +
+ invisible(x) |
||
| 141 | +358 |
- #'+ } |
||
| 142 | +359 |
- #' @param v (`matrix`)\cr unadjusted covariance matrix.+ |
||
| 143 | +360 |
- #' @param w (`matrix`)\cr hessian matrix.+ #' Coerce into a Covariance Structure Definition |
||
| 144 | +361 |
- #' @param p (`matrix`)\cr P matrix from [h_get_kr_comp()].+ #' |
||
| 145 | +362 |
- #' @param q (`matrix`)\cr Q matrix from [h_get_kr_comp()].+ #' @description `r lifecycle::badge("stable")`
|
||
| 146 | +363 |
- #' @param r (`matrix`)\cr R matrix from [h_get_kr_comp()].+ #' |
||
| 147 | +364 |
- #' @param linear (`flag`)\cr whether to use linear Kenward-Roger approximation.+ #' @details |
||
| 148 | +365 |
- #'+ #' A covariance structure can be parsed from a model definition formula or call. |
||
| 149 | +366 |
- #' @return The matrix of adjusted covariance matrix.+ #' Generally, covariance structures defined using non-standard evaluation take |
||
| 150 | +367 |
- #'+ #' the following form: |
||
| 151 | +368 |
- #' @keywords internal+ #' |
||
| 152 | +369 |
- h_var_adj <- function(v, w, p, q, r, linear = FALSE) {
+ #' ``` |
||
| 153 | -49x | +|||
| 370 | +
- assert_flag(linear)+ #' type( (visit, )* visit | (group /)? subject ) |
|||
| 154 | -49x | +|||
| 371 | +
- n_beta <- ncol(v)+ #' ``` |
|||
| 155 | -49x | +|||
| 372 | +
- assert_matrix(v, nrows = n_beta)+ #' |
|||
| 156 | -49x | +|||
| 373 | +
- n_theta <- ncol(w)+ #' For example, formulas may include terms such as |
|||
| 157 | -49x | +|||
| 374 | +
- assert_matrix(w, nrows = n_theta)+ #' |
|||
| 158 | -49x | +|||
| 375 | +
- n_visits <- ncol(p)+ #' ```r |
|||
| 159 | -49x | +|||
| 376 | +
- theta_per_group <- nrow(q) / nrow(p)+ #' us(time | subject) |
|||
| 160 | -49x | +|||
| 377 | +
- n_groups <- n_theta / theta_per_group+ #' cp(time | group / subject) |
|||
| 161 | -49x | +|||
| 378 | +
- assert_matrix(p, nrows = n_theta * n_visits)+ #' sp_exp(coord1, coord2 | group / subject) |
|||
| 162 | -49x | +|||
| 379 | +
- assert_matrix(q, nrows = theta_per_group^2 * n_groups * n_visits, ncols = n_visits)+ #' ``` |
|||
| 163 | -49x | +|||
| 380 | +
- assert_matrix(r, nrows = theta_per_group^2 * n_groups * n_visits, ncols = n_visits)+ #' |
|||
| 164 | -49x | +|||
| 381 | +
- if (linear) {
+ #' Note that only `sp_exp` (spatial) covariance structures may provide multiple |
|||
| 165 | -13x | +|||
| 382 | +
- r <- matrix(0, nrow = nrow(r), ncol = ncol(r))+ #' coordinates, which identify the Euclidean distance between the time points. |
|||
| 166 | +383 |
- }+ #' |
||
| 167 | +384 |
-
+ #' @param x an object from which to derive a covariance structure. See object |
||
| 168 | +385 |
- # see vignettes/kenward.Rmd#131+ #' specific sections for details. |
||
| 169 | -49x | +|||
| 386 | +
- ret <- v+ #' @param warn_partial (`flag`)\cr whether to emit a warning when parts of the |
|||
| 170 | -49x | +|||
| 387 | +
- for (i in seq_len(n_theta)) {
+ #' formula are disregarded. |
|||
| 171 | -264x | +|||
| 388 | +
- for (j in seq_len(n_theta)) {
+ #' @param ... additional arguments unused. |
|||
| 172 | -2164x | +|||
| 389 | +
- gi <- ceiling(i / theta_per_group)+ #' |
|||
| 173 | -2164x | +|||
| 390 | +
- gj <- ceiling(j / theta_per_group)+ #' @return A [cov_struct()] object. |
|||
| 174 | -2164x | +|||
| 391 | +
- iid <- (i - 1) * n_beta + 1+ #' |
|||
| 175 | -2164x | +|||
| 392 | +
- jid <- (j - 1) * n_beta + 1+ #' @examples |
|||
| 176 | -2164x | +|||
| 393 | +
- ii <- i - (gi - 1) * theta_per_group+ #' # provide a covariance structure as a right-sided formula |
|||
| 177 | -2164x | +|||
| 394 | +
- jj <- j - (gi - 1) * theta_per_group+ #' as.cov_struct(~ csh(visit | group / subject)) |
|||
| 178 | -2164x | +|||
| 395 | +
- ijid <- ((ii - 1) * theta_per_group + jj - 1) * n_beta + (gi - 1) * n_beta * theta_per_group^2 + 1+ #' |
|||
| 179 | -2164x | +|||
| 396 | +
- if (gi != gj) {
+ #' # when part of a full formula, suppress warnings using `warn_partial = FALSE` |
|||
| 180 | -592x | +|||
| 397 | +
- ret <- ret + 2 * w[i, j] * v %*% (-p[iid:(iid + n_beta - 1), ] %*% v %*% p[jid:(jid + n_beta - 1), ]) %*% v+ #' as.cov_struct(y ~ x + csh(visit | group / subject), warn_partial = FALSE) |
|||
| 181 | +398 |
- } else {
+ #' |
||
| 182 | -1572x | +|||
| 399 | +
- ret <- ret + 2 * w[i, j] * v %*% (+ #' @family covariance types |
|||
| 183 | -1572x | +|||
| 400 | +
- q[ijid:(ijid + n_beta - 1), ] -+ #' @export |
|||
| 184 | -1572x | +|||
| 401 | +
- p[iid:(iid + n_beta - 1), ] %*% v %*% p[jid:(jid + n_beta - 1), ] -+ as.cov_struct <- function(x, ...) { # nolint
|
|||
| 185 | -1572x | +402 | +278x |
- 1 / 4 * r[ijid:(ijid + n_beta - 1), ]+ UseMethod("as.cov_struct")
|
| 186 | -1572x | +|||
| 403 | +
- ) %*% v+ } |
|||
| 187 | +404 |
- }+ |
||
| 188 | +405 |
- }+ #' @export |
||
| 189 | +406 |
- }+ as.cov_struct.cov_struct <- function(x, ...) {
|
||
| 190 | -49x | +|||
| 407 | +! |
- ret+ x |
||
| 191 | +408 |
} |
| 1 | +409 |
- #' Calculation of Degrees of Freedom for One-Dimensional Contrast+ |
||
| 2 | +410 |
- #'+ #' @describeIn as.cov_struct |
||
| 3 | +411 |
- #' @description `r lifecycle::badge("stable")`
+ #' When provided a formula, any specialized functions are assumed to be |
||
| 4 | +412 |
- #' Calculates the estimate, adjusted standard error, degrees of freedom,+ #' covariance structure definitions and must follow the form: |
||
| 5 | +413 |
- #' t statistic and p-value for one-dimensional contrast.+ #' |
||
| 6 | +414 |
- #'+ #' ``` |
||
| 7 | +415 |
- #' @param object (`mmrm`)\cr the MMRM fit.+ #' y ~ xs + type( (visit, )* visit | (group /)? subject ) |
||
| 8 | +416 |
- #' @param contrast (`numeric`)\cr contrast vector. Note that this should not include+ #' ``` |
||
| 9 | +417 |
- #' elements for singular coefficient estimates, i.e. only refer to the+ #' |
||
| 10 | +418 |
- #' actually estimated coefficients.+ #' Any component on the right hand side of a formula is considered when |
||
| 11 | +419 |
- #' @return List with `est`, `se`, `df`, `t_stat` and `p_val`.+ #' searching for a covariance definition. |
||
| 12 | +420 |
- #' @export+ #' |
||
| 13 | +421 |
- #'+ #' @export |
||
| 14 | +422 |
- #' @examples+ as.cov_struct.formula <- function(x, warn_partial = TRUE, ...) {
|
||
| 15 | -+ | |||
| 423 | +278x |
- #' object <- mmrm(+ x_calls <- h_extract_covariance_terms(x) |
||
| 16 | +424 |
- #' formula = FEV1 ~ RACE + SEX + ARMCD * AVISIT + us(AVISIT | USUBJID),+ |
||
| 17 | -+ | |||
| 425 | +278x |
- #' data = fev_data+ if (length(x_calls) < 1) {
|
||
| 18 | -+ | |||
| 426 | +4x |
- #' )+ stop( |
||
| 19 | -+ | |||
| 427 | +4x |
- #' contrast <- numeric(length(object$beta_est))+ "Covariance structure must be specified in formula. ", |
||
| 20 | -+ | |||
| 428 | +4x |
- #' contrast[3] <- 1+ "Possible covariance structures include: ", |
||
| 21 | -+ | |||
| 429 | +4x |
- #' df_1d(object, contrast)+ paste0(cov_types(c("abbr", "habbr")), collapse = ", ")
|
||
| 22 | +430 |
- df_1d <- function(object, contrast) {
+ ) |
||
| 23 | -338x | +|||
| 431 | +
- assert_class(object, "mmrm")+ } |
|||
| 24 | -338x | +|||
| 432 | +
- assert_numeric(contrast, len = length(component(object, "beta_est")), any.missing = FALSE)+ |
|||
| 25 | -338x | +433 | +274x |
- contrast <- as.vector(contrast)+ if (length(x_calls) > 1) {
|
| 26 | -338x | +434 | +1x |
- switch(object$method,+ cov_struct_types <- as.character(lapply(x_calls, `[[`, 1L)) |
| 27 | -318x | +435 | +1x |
- "Satterthwaite" = h_df_1d_sat(object, contrast),+ stop( |
| 28 | -19x | +436 | +1x |
- "Kenward-Roger" = h_df_1d_kr(object, contrast),+ "Only one covariance structure can be specified. ", |
| 29 | -! | +|||
| 437 | +1x |
- "Residual" = h_df_1d_res(object, contrast),+ "Currently specified covariance structures are: ", |
||
| 30 | +438 | 1x |
- "Between-Within" = h_df_1d_bw(object, contrast),+ paste0(cov_struct_types, collapse = ", ") |
|
| 31 | -! | +|||
| 439 | +
- stop("Unrecognized degrees of freedom method: ", object$method)
+ ) |
|||
| 32 | +440 |
- )+ } |
||
| 33 | +441 |
- }+ |
||
| 34 | +442 |
-
+ # flatten into list of infix operators, calls and names/atomics+ |
+ ||
| 443 | +273x | +
+ x <- flatten_call(x_calls[[1]])+ |
+ ||
| 444 | +273x | +
+ type <- as.character(x[[1]])+ |
+ ||
| 445 | +273x | +
+ x <- drop_elements(x, 1) |
||
| 35 | +446 | |||
| 36 | +447 |
- #' Calculation of Degrees of Freedom for Multi-Dimensional Contrast+ # take visits until "|" |
||
| 37 | -+ | |||
| 448 | +273x |
- #'+ n <- position_symbol(x, "|", nomatch = 0) |
||
| 38 | -+ | |||
| 449 | +273x |
- #' @description `r lifecycle::badge("stable")`
+ visits <- as.character(utils::head(x, max(n - 1, 0))) |
||
| 39 | -+ | |||
| 450 | +273x |
- #' Calculates the estimate, standard error, degrees of freedom,+ x <- drop_elements(x, n) |
||
| 40 | +451 |
- #' t statistic and p-value for one-dimensional contrast, depending on the method+ |
||
| 41 | +452 |
- #' used in [mmrm()].+ # take group until "/" |
||
| 42 | -+ | |||
| 453 | +273x |
- #'+ n <- position_symbol(x, "/", nomatch = 0) |
||
| 43 | -+ | |||
| 454 | +273x |
- #' @param object (`mmrm`)\cr the MMRM fit.+ group <- as.character(utils::head(x, max(n - 1, 0))) |
||
| 44 | -+ | |||
| 455 | +273x |
- #' @param contrast (`matrix`)\cr numeric contrast matrix, if given a `numeric`+ x <- drop_elements(x, n) |
||
| 45 | +456 |
- #' then this is coerced to a row vector. Note that this should not include+ |
||
| 46 | +457 |
- #' elements for singular coefficient estimates, i.e. only refer to the+ # remainder is subject |
||
| 47 | -+ | |||
| 458 | +273x |
- #' actually estimated coefficients.+ subject <- as.character(x) |
||
| 48 | +459 |
- #'+ + |
+ ||
| 460 | +273x | +
+ cov_struct(type = type, visits = visits, group = group, subject = subject) |
||
| 49 | +461 |
- #' @return List with `num_df`, `denom_df`, `f_stat` and `p_val` (2-sided p-value).+ } |
| 50 | +1 |
- #' @export+ #' Obtain List of Jacobian Matrix Entries for Covariance Matrix |
||
| 51 | +2 |
#' |
||
| 52 | +3 |
- #' @examples+ #' @description Obtain the Jacobian matrices given the covariance function and variance parameters. |
||
| 53 | +4 |
- #' object <- mmrm(+ #' |
||
| 54 | +5 |
- #' formula = FEV1 ~ RACE + SEX + ARMCD * AVISIT + us(AVISIT | USUBJID),+ #' @param tmb_data (`mmrm_tmb_data`)\cr produced by [h_mmrm_tmb_data()]. |
||
| 55 | +6 |
- #' data = fev_data+ #' @param theta_est (`numeric`)\cr variance parameters point estimate. |
||
| 56 | +7 |
- #' )+ #' @param beta_vcov (`matrix`)\cr vairance covariance matrix of coefficients. |
||
| 57 | +8 |
- #' contrast <- matrix(data = 0, nrow = 2, ncol = length(object$beta_est))+ #' |
||
| 58 | +9 |
- #' contrast[1, 2] <- contrast[2, 3] <- 1+ #' @return List with one element per variance parameter containing a matrix |
||
| 59 | +10 |
- #' df_md(object, contrast)+ #' of the same dimensions as the covariance matrix. The values are the derivatives |
||
| 60 | +11 |
- df_md <- function(object, contrast) {
+ #' with regards to this variance parameter. |
||
| 61 | -150x | +|||
| 12 | +
- assert_class(object, "mmrm")+ #' |
|||
| 62 | -150x | +|||
| 13 | +
- assert_numeric(contrast, any.missing = FALSE)+ #' @keywords internal |
|||
| 63 | -150x | +|||
| 14 | +
- if (!is.matrix(contrast)) {
+ h_jac_list <- function(tmb_data, |
|||
| 64 | -113x | +|||
| 15 | +
- contrast <- matrix(contrast, ncol = length(contrast))+ theta_est, |
|||
| 65 | +16 |
- }+ beta_vcov) {
|
||
| 66 | -150x | +17 | +82x |
- assert_matrix(contrast, ncols = length(component(object, "beta_est")))+ assert_class(tmb_data, "mmrm_tmb_data") |
| 67 | -150x | +18 | +82x |
- if (nrow(contrast) == 0) {
+ assert_numeric(theta_est) |
| 68 | -1x | +19 | +82x |
- return(+ assert_matrix(beta_vcov) |
| 69 | -1x | +20 | +82x |
- list(+ .Call(`_mmrm_get_jacobian`, PACKAGE = "mmrm", tmb_data, theta_est, beta_vcov) |
| 70 | -1x | +|||
| 21 | +
- num_df = 0,+ } |
|||
| 71 | -1x | +|||
| 22 | +
- denom_df = NA_real_,+ |
|||
| 72 | -1x | +|||
| 23 | +
- f_stat = NA_real_,+ #' Quadratic Form Calculations |
|||
| 73 | -1x | +|||
| 24 | +
- p_val = NA_real_+ #' |
|||
| 74 | +25 |
- )+ #' @description These helpers are mainly for easier readability and slightly better efficiency |
||
| 75 | +26 |
- )+ #' of the quadratic forms used in the Satterthwaite calculations. |
||
| 76 | +27 |
- }+ #' |
||
| 77 | -149x | +|||
| 28 | +
- switch(object$method,+ #' @param center (`matrix`)\cr square numeric matrix with the same dimensions as |
|||
| 78 | -145x | +|||
| 29 | +
- "Satterthwaite" = h_df_md_sat(object, contrast),+ #' `x` as the center of the quadratic form. |
|||
| 79 | -3x | +|||
| 30 | +
- "Kenward-Roger" = h_df_md_kr(object, contrast),+ #' |
|||
| 80 | -! | +|||
| 31 | +
- "Residual" = h_df_md_res(object, contrast),+ #' @name h_quad_form |
|||
| 81 | -1x | +|||
| 32 | +
- "Between-Within" = h_df_md_bw(object, contrast),+ NULL |
|||
| 82 | -! | +|||
| 33 | +
- stop("Unrecognized degrees of freedom method: ", object$method)
+
|
|||
| 83 | +34 |
- )+ #' @describeIn h_quad_form calculates the number `vec %*% center %*% t(vec)` |
||
| 84 | +35 |
- }+ #' as a numeric (not a matrix). |
||
| 85 | +36 |
-
+ #' |
||
| 86 | +37 |
- #' Creating T-Statistic Test Results For One-Dimensional Contrast+ #' @param vec (`numeric`)\cr interpreted as a row vector. |
||
| 87 | +38 |
#' |
||
| 88 | +39 |
- #' @description Creates a list of results for one-dimensional contrasts using+ #' @keywords internal |
||
| 89 | +40 |
- #' a t-test statistic and the given degrees of freedom.+ h_quad_form_vec <- function(vec, center) {
|
||
| 90 | -+ | |||
| 41 | +5607x |
- #'+ vec <- as.vector(vec) |
||
| 91 | -+ | |||
| 42 | +5607x |
- #' @inheritParams df_1d+ assert_numeric(vec, any.missing = FALSE) |
||
| 92 | -+ | |||
| 43 | +5607x |
- #' @param df (`number`)\cr degrees of freedom for the one-dimensional contrast.+ assert_matrix( |
||
| 93 | -+ | |||
| 44 | +5607x |
- #'+ center, |
||
| 94 | -+ | |||
| 45 | +5607x |
- #' @return List with `est`, `se`, `df`, `t_stat` and `p_val` (2-sided p-value).+ mode = "numeric", |
||
| 95 | -+ | |||
| 46 | +5607x |
- #'+ any.missing = FALSE,+ |
+ ||
| 47 | +5607x | +
+ nrows = length(vec),+ |
+ ||
| 48 | +5607x | +
+ ncols = length(vec) |
||
| 96 | +49 |
- #' @keywords internal+ ) |
||
| 97 | +50 |
- h_test_1d <- function(object,+ + |
+ ||
| 51 | +5607x | +
+ sum(vec * (center %*% vec)) |
||
| 98 | +52 |
- contrast,+ } |
||
| 99 | +53 |
- df) {
+
|
||
| 100 | -486x | +|||
| 54 | +
- assert_class(object, "mmrm")+ #' @describeIn h_quad_form calculates the quadratic form `mat %*% center %*% t(mat)` |
|||
| 101 | -486x | +|||
| 55 | +
- assert_numeric(contrast, len = length(component(object, "beta_est")))+ #' as a matrix, the result is square and has dimensions identical to the number |
|||
| 102 | -486x | +|||
| 56 | +
- assert_number(df, lower = .Machine$double.xmin)+ #' of rows in `mat`. |
|||
| 103 | +57 |
-
+ #' |
||
| 104 | -486x | +|||
| 58 | +
- est <- sum(contrast * component(object, "beta_est"))+ #' @param mat (`matrix`)\cr numeric matrix to be multiplied left and right of |
|||
| 105 | -486x | +|||
| 59 | +
- var <- h_quad_form_vec(contrast, component(object, "beta_vcov"))+ #' `center`, therefore needs to have as many columns as there are rows and columns |
|||
| 106 | -486x | +|||
| 60 | +
- se <- sqrt(var)+ #' in `center`. |
|||
| 107 | -486x | +|||
| 61 | +
- t_stat <- est / se+ #' |
|||
| 108 | -486x | +|||
| 62 | +
- p_val <- 2 * stats::pt(q = abs(t_stat), df = df, lower.tail = FALSE)+ #' @keywords internal |
|||
| 109 | +63 |
-
+ h_quad_form_mat <- function(mat, center) {
|
||
| 110 | -486x | +64 | +119x |
- list(+ assert_matrix(mat, mode = "numeric", any.missing = FALSE, min.cols = 1L) |
| 111 | -486x | +65 | +119x |
- est = est,+ assert_matrix( |
| 112 | -486x | +66 | +119x |
- se = se,+ center, |
| 113 | -486x | +67 | +119x |
- df = df,+ mode = "numeric", |
| 114 | -486x | +68 | +119x |
- t_stat = t_stat,+ any.missing = FALSE, |
| 115 | -486x | +69 | +119x |
- p_val = p_val+ nrows = ncol(center), |
| 116 | -+ | |||
| 70 | +119x |
- )+ ncols = ncol(center) |
||
| 117 | +71 |
- }+ ) |
||
| 118 | -+ | |||
| 72 | +119x |
-
+ mat %*% tcrossprod(center, mat) |
||
| 119 | +73 |
- #' Creating F-Statistic Test Results For Multi-Dimensional Contrast+ } |
||
| 120 | +74 |
- #'+ |
||
| 121 | +75 |
- #' @description Creates a list of results for multi-dimensional contrasts using+ #' Computation of a Gradient Given Jacobian and Contrast Vector |
||
| 122 | +76 |
- #' an F-test statistic and the given degrees of freedom.+ #' |
||
| 123 | +77 |
- #'+ #' @description Computes the gradient of a linear combination of `beta` given the Jacobian matrix and |
||
| 124 | +78 |
- #' @inheritParams df_md+ #' variance parameters. |
||
| 125 | +79 |
- #' @param contrast (`matrix`)\cr numeric contrast matrix.+ #' |
||
| 126 | +80 |
- #' @param df (`number`)\cr denominator degrees of freedom for the multi-dimensional contrast.+ #' @param jac_list (`list`)\cr Jacobian list produced e.g. by [h_jac_list()]. |
||
| 127 | +81 |
- #' @param f_stat_factor (`number`)\cr optional scaling factor on top of the standard F-statistic.+ #' @param contrast (`numeric`)\cr contrast vector, which needs to have the |
||
| 128 | +82 |
- #'+ #' same number of elements as there are rows and columns in each element of |
||
| 129 | +83 |
- #' @return List with `num_df`, `denom_df`, `f_stat` and `p_val` (2-sided p-value).+ #' `jac_list`. |
||
| 130 | +84 |
#' |
||
| 131 | +85 |
- #' @keywords internal+ #' @return Numeric vector which contains the quadratic forms of each element of |
||
| 132 | +86 |
- h_test_md <- function(object,+ #' `jac_list` with the `contrast` vector. |
||
| 133 | +87 |
- contrast,+ #' |
||
| 134 | +88 |
- df,+ #' @keywords internal |
||
| 135 | +89 |
- f_stat_factor = 1) {
- |
- ||
| 136 | -15x | -
- assert_class(object, "mmrm")- |
- ||
| 137 | -15x | -
- assert_matrix(contrast, ncols = length(component(object, "beta_est")))- |
- ||
| 138 | -15x | -
- num_df <- nrow(contrast)+ h_gradient <- function(jac_list, contrast) {
|
||
| 139 | -15x | +90 | +491x |
- assert_number(df, lower = .Machine$double.xmin)+ assert_list(jac_list) |
| 140 | -15x | +91 | +491x |
- assert_number(f_stat_factor, lower = .Machine$double.xmin)+ assert_numeric(contrast) |
| 141 | +92 | |||
| 142 | -15x | -
- prec_contrast <- solve(h_quad_form_mat(contrast, component(object, "beta_vcov")))- |
- ||
| 143 | -15x | -
- contrast_est <- component(object, "beta_est") %*% t(contrast)- |
- ||
| 144 | -15x | -
- f_statistic <- as.numeric(f_stat_factor / num_df * h_quad_form_mat(contrast_est, prec_contrast))- |
- ||
| 145 | -15x | +93 | +491x |
- p_val <- stats::pf(+ vapply( |
| 146 | -15x | +94 | +491x |
- q = f_statistic,+ jac_list, |
| 147 | -15x | +95 | +491x |
- df1 = num_df,+ h_quad_form_vec, |
| 148 | -15x | +96 | +491x |
- df2 = df,+ vec = contrast, |
| 149 | -15x | +97 | +491x |
- lower.tail = FALSE+ numeric(1L) |
| 150 | +98 |
) |
||
| 151 | +99 | - - | -||
| 152 | -15x | -
- list(- |
- ||
| 153 | -15x | -
- num_df = num_df,- |
- ||
| 154 | -15x | -
- denom_df = df,- |
- ||
| 155 | -15x | -
- f_stat = f_statistic,- |
- ||
| 156 | -15x | -
- p_val = p_val+ } |
||
| 157 | +100 |
- )+ |
||
| 158 | +101 |
- }+ #' Calculation of Satterthwaite Degrees of Freedom for One-Dimensional Contrast |
| 1 | +102 |
- #' Covariance Type Database+ #' |
|
| 2 | +103 |
- #'+ #' @description Used in [df_1d()] if method is |
|
| 3 | +104 |
- #' An internal constant for covariance type information.+ #' "Satterthwaite". |
|
| 4 | +105 |
#' |
|
| 5 | +106 |
- #' @format A data frame with 5 variables and one record per covariance type:+ #' @param object (`mmrm`)\cr the MMRM fit. |
|
| 6 | +107 |
- #'+ #' @param contrast (`numeric`)\cr contrast vector. Note that this should not include |
|
| 7 | +108 |
- #' \describe{
+ #' elements for singular coefficient estimates, i.e. only refer to the |
|
| 8 | +109 |
- #' \item{name}{
+ #' actually estimated coefficients. |
|
| 9 | +110 |
- #' The long-form name of the covariance structure type+ #' |
|
| 10 | +111 |
- #' }+ #' @return List with `est`, `se`, `df`, `t_stat` and `p_val`. |
|
| 11 | +112 |
- #' \item{abbr}{
+ #' @keywords internal |
|
| 12 | +113 |
- #' The abbreviated name of the covariance structure type+ h_df_1d_sat <- function(object, contrast) {
|
|
| 13 | -+ | ||
| 114 | +456x |
- #' }+ assert_class(object, "mmrm") |
|
| 14 | -+ | ||
| 115 | +456x |
- #' \item{habbr}{
+ contrast <- as.numeric(contrast) |
|
| 15 | -+ | ||
| 116 | +456x |
- #' The abbreviated name of the heterogeneous version of a covariance+ assert_numeric(contrast, len = length(component(object, "beta_est"))) |
|
| 16 | +117 |
- #' structure type (The abbreviated name (`abbr`) with a trailing `"h"` if+ |
|
| 17 | -+ | ||
| 118 | +456x |
- #' the structure has a heterogeneous implementation or `NA` otherwise).+ df <- if (identical(object$vcov, "Asymptotic")) {
|
|
| 18 | -+ | ||
| 119 | +444x |
- #' }+ grad <- h_gradient(component(object, "jac_list"), contrast) |
|
| 19 | -+ | ||
| 120 | +444x |
- #' \item{heterogeneous}{
+ v_num <- 2 * h_quad_form_vec(contrast, component(object, "beta_vcov"))^2 |
|
| 20 | -+ | ||
| 121 | +444x |
- #' A logical value indicating whether the covariance structure has a+ v_denom <- h_quad_form_vec(grad, component(object, "theta_vcov")) |
|
| 21 | -+ | ||
| 122 | +444x |
- #' heterogeneous counterpart.+ v_num / v_denom |
|
| 22 | -+ | ||
| 123 | +456x |
- #' }+ } else if (object$vcov %in% c("Empirical", "Empirical-Jackknife", "Empirical-Bias-Reduced")) {
|
|
| 23 | -+ | ||
| 124 | +12x |
- #' \item{spatial}{
+ contrast_matrix <- Matrix::.bdiag(rep(list(matrix(contrast, nrow = 1)), component(object, "n_subjects"))) |
|
| 24 | -+ | ||
| 125 | +12x |
- #' A logical value indicating whether the covariance structure is spatial.+ contrast_matrix <- as.matrix(contrast_matrix) |
|
| 25 | -+ | ||
| 126 | +12x |
- #' }+ g_matrix <- h_quad_form_mat(contrast_matrix, object$empirical_df_mat) |
|
| 26 | -+ | ||
| 127 | +12x |
- #' }+ h_tr(g_matrix)^2 / sum(g_matrix^2) |
|
| 27 | +128 |
- #'+ } |
|
| 28 | +129 |
- #' @keywords internal+ + |
+ |
| 130 | +456x | +
+ h_test_1d(object, contrast, df) |
|
| 29 | +131 |
- COV_TYPES <- local({ # nolint
+ } |
|
| 30 | +132 |
- type <- function(name, abbr, habbr, heterogeneous, spatial) {
+
|
|
| 31 | +133 |
- args <- as.list(match.call()[-1])+ #' Calculating Denominator Degrees of Freedom for the Multi-Dimensional Case |
|
| 32 | +134 |
- do.call(data.frame, args)+ #' |
|
| 33 | +135 |
- }+ #' @description Calculates the degrees of freedom for multi-dimensional contrast. |
|
| 34 | +136 |
-
+ #' |
|
| 35 | +137 |
- as.data.frame(+ #' @param t_stat_df (`numeric`)\cr `n` t-statistic derived degrees of freedom. |
|
| 36 | +138 |
- col.names = names(formals(type)),+ #' |
|
| 37 | +139 |
- rbind(+ #' @return Usually the calculation is returning `2 * E / (E - n)` where |
|
| 38 | +140 |
- type("unstructured", "us", NA, FALSE, FALSE),
+ #' `E` is the sum of `t / (t - 2)` over all `t_stat_df` values `t`. |
|
| 39 | +141 |
- type("Toeplitz", "toep", "toeph", TRUE, FALSE),
+ #' |
|
| 40 | +142 |
- type("auto-regressive order one", "ar1", "ar1h", TRUE, FALSE),
+ #' @note If the input values are two similar to each other then just the average |
|
| 41 | +143 |
- type("ante-dependence", "ad", "adh", TRUE, FALSE),
+ #' of them is returned. If any of the inputs is not larger than 2 then 2 is |
|
| 42 | +144 |
- type("compound symmetry", "cs", "csh", TRUE, FALSE),
+ #' returned. |
|
| 43 | +145 |
- type("spatial exponential", "sp_exp", NA, FALSE, TRUE)
+ #' |
|
| 44 | +146 |
- )+ #' @keywords internal |
|
| 45 | +147 |
- )+ h_md_denom_df <- function(t_stat_df) {
|
|
| 46 | -+ | ||
| 148 | +24x |
- })+ assert_numeric(t_stat_df, min.len = 1L, lower = .Machine$double.xmin, any.missing = FALSE) |
|
| 47 | +149 | ||
| 48 | -+ | ||
| 150 | +24x |
- #' Covariance Types+ if (test_scalar(t_stat_df)) {
|
|
| 49 | -+ | ||
| 151 | +1x |
- #'+ t_stat_df |
|
| 50 | -+ | ||
| 152 | +23x |
- #' @description `r lifecycle::badge("stable")`
+ } else if (all(abs(diff(t_stat_df)) < sqrt(.Machine$double.eps))) {
|
|
| 51 | -+ | ||
| 153 | +1x |
- #'+ mean(t_stat_df) |
|
| 52 | -+ | ||
| 154 | +22x |
- #' @param form (`character`)\cr covariance structure type name form. One or+ } else if (any(t_stat_df <= 2)) {
|
|
| 53 | -+ | ||
| 155 | +2x |
- #' more of `"name"`, `"abbr"` (abbreviation), or `"habbr"` (heterogeneous+ 2 |
|
| 54 | +156 |
- #' abbreviation).+ } else {
|
|
| 55 | -+ | ||
| 157 | +20x |
- #' @param filter (`character`)\cr covariance structure type filter. One or+ e <- sum(t_stat_df / (t_stat_df - 2)) |
|
| 56 | -+ | ||
| 158 | +20x |
- #' more of `"heterogeneous"` or `"spatial"`.+ 2 * e / (e - (length(t_stat_df))) |
|
| 57 | +159 |
- #'+ } |
|
| 58 | +160 |
- #' @return A character vector of accepted covariance structure type names and+ } |
|
| 59 | +161 |
- #' abbreviations.+ |
|
| 60 | +162 |
- #'+ #' Creating F-Statistic Results from One-Dimensional Contrast |
|
| 61 | +163 |
- #' @section Abbreviations for Covariance Structures:+ #' |
|
| 62 | +164 |
- #'+ #' @description Creates multi-dimensional result from one-dimensional contrast from [df_1d()]. |
|
| 63 | +165 |
- #' ## Common Covariance Structures:+ #' |
|
| 64 | +166 |
- #'+ #' @param object (`mmrm`)\cr model fit. |
|
| 65 | +167 |
- #' \tabular{clll}{
+ #' @param contrast (`numeric`)\cr one-dimensional contrast. |
|
| 66 | +168 |
#' |
|
| 67 | +169 |
- #' \strong{Structure}
+ #' @return The one-dimensional degrees of freedom are calculated and then |
|
| 68 | +170 |
- #' \tab \strong{Description}
+ #' based on that the p-value is calculated. |
|
| 69 | +171 |
- #' \tab \strong{Parameters}
+ #' |
|
| 70 | +172 |
- #' \tab \strong{\eqn{(i, j)} element}
+ #' @keywords internal |
|
| 71 | +173 |
- #' \cr+ h_df_md_from_1d <- function(object, contrast) {
|
|
| 72 | -+ | ||
| 174 | +134x |
- #'+ res_1d <- h_df_1d_sat(object, contrast) |
|
| 73 | -+ | ||
| 175 | +134x |
- #' ad+ list( |
|
| 74 | -+ | ||
| 176 | +134x |
- #' \tab Ante-dependence+ num_df = 1, |
|
| 75 | -+ | ||
| 177 | +134x |
- #' \tab \eqn{m}
+ denom_df = res_1d$df, |
|
| 76 | -+ | ||
| 178 | +134x |
- #' \tab \eqn{\sigma^{2}\prod_{k=i}^{j-1}\rho_{k}}
+ f_stat = res_1d$t_stat^2, |
|
| 77 | -+ | ||
| 179 | +134x |
- #' \cr+ p_val = stats::pf(q = res_1d$t_stat^2, df1 = 1, df2 = res_1d$df, lower.tail = FALSE) |
|
| 78 | +180 |
- #'+ ) |
|
| 79 | +181 |
- #' adh+ } |
|
| 80 | +182 |
- #' \tab Heterogeneous ante-dependence+ |
|
| 81 | +183 |
- #' \tab \eqn{2m-1}
+ #' Calculation of Satterthwaite Degrees of Freedom for Multi-Dimensional Contrast |
|
| 82 | +184 |
- #' \tab \eqn{\sigma_{i}\sigma_{j}\prod_{k=i}^{j-1}\rho_{k}}
+ #' |
|
| 83 | +185 |
- #' \cr+ #' @description Used in [df_md()] if method is "Satterthwaite". |
|
| 84 | +186 |
#' |
|
| 85 | +187 |
- #' ar1+ #' @param object (`mmrm`)\cr the MMRM fit. |
|
| 86 | +188 |
- #' \tab First-order auto-regressive+ #' @param contrast (`matrix`)\cr numeric contrast matrix, if given a `numeric` |
|
| 87 | +189 |
- #' \tab \eqn{2}
+ #' then this is coerced to a row vector. Note that this should not include |
|
| 88 | +190 |
- #' \tab \eqn{\sigma^{2}\rho^{\left \vert {i-j} \right \vert}}
+ #' elements for singular coefficient estimates, i.e. only refer to the |
|
| 89 | +191 |
- #' \cr+ #' actually estimated coefficients. |
|
| 90 | +192 |
#' |
|
| 91 | +193 |
- #' ar1h+ #' @return List with `num_df`, `denom_df`, `f_stat` and `p_val` (2-sided p-value). |
|
| 92 | +194 |
- #' \tab Heterogeneous first-order auto-regressive+ #' @keywords internal |
|
| 93 | +195 |
- #' \tab \eqn{m+1}
+ h_df_md_sat <- function(object, contrast) {
|
|
| 94 | -+ | ||
| 196 | +151x |
- #' \tab \eqn{\sigma_{i}\sigma_{j}\rho^{\left \vert {i-j} \right \vert}}
+ assert_class(object, "mmrm") |
|
| 95 | -+ | ||
| 197 | +151x |
- #' \cr+ assert_matrix(contrast, mode = "numeric", any.missing = FALSE, ncols = length(component(object, "beta_est"))) |
|
| 96 | +198 |
- #'+ # Early return if we are in the one-dimensional case. |
|
| 97 | -+ | ||
| 199 | +151x |
- #' cs+ if (identical(nrow(contrast), 1L)) {
|
|
| 98 | -+ | ||
| 200 | +132x |
- #' \tab Compound symmetry+ return(h_df_md_from_1d(object, contrast)) |
|
| 99 | +201 |
- #' \tab \eqn{2}
+ } |
|
| 100 | +202 |
- #' \tab \eqn{\sigma^{2}\left[ \rho I(i \neq j)+I(i=j) \right]}
+
|
|
| 101 | -+ | ||
| 203 | +19x |
- #' \cr+ contrast_cov <- h_quad_form_mat(contrast, component(object, "beta_vcov")) |
|
| 102 | -+ | ||
| 204 | +19x |
- #'+ eigen_cont_cov <- eigen(contrast_cov) |
|
| 103 | -+ | ||
| 205 | +19x |
- #' csh+ eigen_cont_cov_vctrs <- eigen_cont_cov$vectors |
|
| 104 | -+ | ||
| 206 | +19x |
- #' \tab Heterogeneous compound symmetry+ eigen_cont_cov_vals <- eigen_cont_cov$values |
|
| 105 | +207 |
- #' \tab \eqn{m+1}
+
|
|
| 106 | -+ | ||
| 208 | +19x |
- #' \tab \eqn{\sigma_{i}\sigma_{j}\left[ \rho I(i \neq j)+I(i=j) \right]}
+ eps <- sqrt(.Machine$double.eps) |
|
| 107 | -+ | ||
| 209 | +19x |
- #' \cr+ tol <- max(eps * eigen_cont_cov_vals[1], 0) |
|
| 108 | -+ | ||
| 210 | +19x |
- #'+ rank_cont_cov <- sum(eigen_cont_cov_vals > tol) |
|
| 109 | -+ | ||
| 211 | +19x |
- #' toep+ assert_number(rank_cont_cov, lower = .Machine$double.xmin) |
|
| 110 | -+ | ||
| 212 | +19x |
- #' \tab Toeplitz+ rank_seq <- seq_len(rank_cont_cov) |
|
| 111 | -+ | ||
| 213 | +19x |
- #' \tab \eqn{m}
+ vctrs_cont_prod <- crossprod(eigen_cont_cov_vctrs, contrast)[rank_seq, , drop = FALSE] |
|
| 112 | +214 |
- #' \tab \eqn{\sigma_{\left \vert {i-j} \right \vert +1}}
+
|
|
| 113 | +215 |
- #' \cr+ # Early return if rank 1. |
|
| 114 | -+ | ||
| 216 | +19x |
- #'+ if (identical(rank_cont_cov, 1L)) {
|
|
| 115 | -+ | ||
| 217 | +1x |
- #' toeph+ return(h_df_md_from_1d(object, vctrs_cont_prod)) |
|
| 116 | +218 |
- #' \tab Heterogeneous Toeplitz+ } |
|
| 117 | +219 |
- #' \tab \eqn{2m-1}
+
|
|
| 118 | -+ | ||
| 220 | +18x |
- #' \tab \eqn{\sigma_{i}\sigma_{j}\rho_{\left \vert {i-j} \right \vert}}
+ t_squared_nums <- drop(vctrs_cont_prod %*% object$beta_est)^2 |
|
| 119 | -+ | ||
| 221 | +18x |
- #' \cr+ t_squared_denoms <- eigen_cont_cov_vals[rank_seq] |
|
| 120 | -+ | ||
| 222 | +18x |
- #'+ t_squared <- t_squared_nums / t_squared_denoms |
|
| 121 | -+ | ||
| 223 | +18x |
- #' us+ f_stat <- sum(t_squared) / rank_cont_cov |
|
| 122 | -+ | ||
| 224 | +18x |
- #' \tab Unstructured+ t_stat_df_nums <- 2 * eigen_cont_cov_vals^2 |
|
| 123 | -+ | ||
| 225 | +18x |
- #' \tab \eqn{m(m+1)/2}
+ t_stat_df <- if (identical(object$vcov, "Asymptotic")) {
|
|
| 124 | -+ | ||
| 226 | +18x |
- #' \tab \eqn{\sigma_{ij}}
+ grads_vctrs_cont_prod <- lapply( |
|
| 125 | -+ | ||
| 227 | +18x |
- #'+ rank_seq, |
|
| 126 | -+ | ||
| 228 | +18x |
- #' }+ function(m) h_gradient(component(object, "jac_list"), contrast = vctrs_cont_prod[m, ]) |
|
| 127 | +229 |
- #'+ )+ |
+ |
| 230 | +18x | +
+ t_stat_df_denoms <- vapply(+ |
+ |
| 231 | +18x | +
+ grads_vctrs_cont_prod,+ |
+ |
| 232 | +18x | +
+ h_quad_form_vec, |
|
| 128 | -+ | ||
| 233 | +18x |
- #' where \eqn{i} and \eqn{j} denote \eqn{i}-th and \eqn{j}-th time points,
+ center = component(object, "theta_vcov"), |
|
| 129 | -+ | ||
| 234 | +18x |
- #' respectively, out of total \eqn{m} time points, \eqn{1 \leq i, j \leq m}.
+ numeric(1) |
|
| 130 | +235 |
- #'+ ) |
|
| 131 | -+ | ||
| 236 | +18x |
- #' @note The **ante-dependence** covariance structure in this package refers to+ t_stat_df_nums / t_stat_df_denoms |
|
| 132 | +237 |
- #' homogeneous ante-dependence, while the ante-dependence covariance structure+ } else {
|
|
| 133 | -+ | ||
| 238 | +! |
- #' from SAS `PROC MIXED` refers to heterogeneous ante-dependence and the+ vapply( |
|
| 134 | -+ | ||
| 239 | +! |
- #' homogeneous version is not available in SAS.+ rank_seq, |
|
| 135 | -+ | ||
| 240 | +! |
- #'+ function(m) {
|
|
| 136 | -+ | ||
| 241 | +! |
- #' @note For all non-spatial covariance structures, the time variable must+ contrast_matrix <- Matrix::.bdiag( |
|
| 137 | -+ | ||
| 242 | +! |
- #' be coded as a factor.+ rep(list(vctrs_cont_prod[m, , drop = FALSE]), component(object, "n_subjects")) |
|
| 138 | +243 |
- #'+ ) |
|
| 139 | -+ | ||
| 244 | +! |
- #' ## Spatial Covariance structures:+ contrast_matrix <- as.matrix(contrast_matrix) |
|
| 140 | -+ | ||
| 245 | +! |
- #'+ g_matrix <- h_quad_form_mat(contrast_matrix, object$empirical_df_mat) |
|
| 141 | -+ | ||
| 246 | +! |
- #' \tabular{clll}{
+ h_tr(g_matrix)^2 / sum(g_matrix^2) |
|
| 142 | +247 |
- #'+ }, |
|
| 143 | -+ | ||
| 248 | +! |
- #' \strong{Structure}
+ FUN.VALUE = 0 |
|
| 144 | +249 |
- #' \tab \strong{Description}
+ ) |
|
| 145 | +250 |
- #' \tab \strong{Parameters}
+ } |
|
| 146 | -+ | ||
| 251 | +18x |
- #' \tab \strong{\eqn{(i, j)} element}
+ denom_df <- h_md_denom_df(t_stat_df) |
|
| 147 | +252 |
- #' \cr+ |
|
| 148 | -+ | ||
| 253 | +18x |
- #'+ list( |
|
| 149 | -+ | ||
| 254 | +18x |
- #' sp_exp+ num_df = rank_cont_cov, |
|
| 150 | -+ | ||
| 255 | +18x |
- #' \tab spatial exponential+ denom_df = denom_df, |
|
| 151 | -+ | ||
| 256 | +18x |
- #' \tab \eqn{2}
+ f_stat = f_stat, |
|
| 152 | -+ | ||
| 257 | +18x |
- #' \tab \eqn{\sigma^{2}\rho^{-d_{ij}}}
+ p_val = stats::pf(q = f_stat, df1 = rank_cont_cov, df2 = denom_df, lower.tail = FALSE) |
|
| 153 | +258 |
- #'+ ) |
|
| 154 | +259 |
- #' }+ } |
| 155 | +1 |
- #'+ #' Component Access for `mmrm_tmb` Objects |
||
| 156 | +2 |
- #' where \eqn{d_{ij}} denotes the Euclidean distance between time points
+ #' |
||
| 157 | +3 |
- #' \eqn{i} and \eqn{j}.
+ #' @description `r lifecycle::badge("stable")`
|
||
| 158 | +4 |
#' |
||
| 159 | +5 |
- #' @family covariance types+ #' @param object (`mmrm_tmb`)\cr the fitted MMRM. |
||
| 160 | +6 |
- #' @name covariance_types+ #' @param name (`character`)\cr the component(s) to be retrieved. |
||
| 161 | +7 |
- #' @export+ #' @return The corresponding component of the object, see details. |
||
| 162 | +8 |
- cov_types <- function(+ #' |
||
| 163 | +9 |
- form = c("name", "abbr", "habbr"),
+ #' @details Available `component()` names are as follows: |
||
| 164 | +10 |
- filter = c("heterogeneous", "spatial")) {
- |
- ||
| 165 | -1666x | -
- form <- match.arg(form, several.ok = TRUE)- |
- ||
| 166 | -1666x | -
- filter <- if (missing(filter)) c() else match.arg(filter, several.ok = TRUE)- |
- ||
| 167 | -1666x | -
- df <- COV_TYPES[form][rowSums(!COV_TYPES[filter]) == 0, ]- |
- ||
| 168 | -1666x | -
- Filter(Negate(is.na), unlist(t(df), use.names = FALSE))+ #' - `call`: low-level function call which generated the model. |
||
| 169 | +11 |
- }+ #' - `formula`: model formula. |
||
| 170 | +12 |
-
+ #' - `dataset`: data set name. |
||
| 171 | +13 |
- #' Retrieve Associated Abbreviated Covariance Structure Type Name+ #' - `cov_type`: covariance structure type. |
||
| 172 | +14 |
- #'+ #' - `n_theta`: number of parameters. |
||
| 173 | +15 |
- #' @param type (`string`)\cr either a full name or abbreviate covariance+ #' - `n_subjects`: number of subjects. |
||
| 174 | +16 |
- #' structure type name to collapse into an abbreviated type.+ #' - `n_timepoints`: number of modeled time points. |
||
| 175 | +17 |
- #'+ #' - `n_obs`: total number of observations. |
||
| 176 | +18 |
- #' @return The corresponding abbreviated covariance type name.+ #' - `reml`: was REML used (ML was used if `FALSE`). |
||
| 177 | +19 |
- #'+ #' - `neg_log_lik`: negative log likelihood. |
||
| 178 | +20 |
- #' @keywords internal+ #' - `convergence`: convergence code from optimizer. |
||
| 179 | +21 |
- cov_type_abbr <- function(type) {
- |
- ||
| 180 | -299x | -
- row <- which(COV_TYPES == type, arr.ind = TRUE)[, 1]- |
- ||
| 181 | -299x | -
- COV_TYPES$abbr[row]+ #' - `conv_message`: message accompanying the convergence code. |
||
| 182 | +22 |
- }+ #' - `evaluations`: number of function evaluations for optimization. |
||
| 183 | +23 |
-
+ #' - `method`: Adjustment method which was used (for `mmrm` objects), |
||
| 184 | +24 |
- #' Retrieve Associated Full Covariance Structure Type Name+ #' otherwise `NULL` (for `mmrm_tmb` objects). |
||
| 185 | +25 |
- #'+ #' - `beta_vcov`: estimated variance-covariance matrix of coefficients |
||
| 186 | +26 |
- #' @param type (`string`)\cr either a full name or abbreviate covariance+ #' (excluding aliased coefficients). When Kenward-Roger/Empirical adjusted |
||
| 187 | +27 |
- #' structure type name to convert to a long-form type.+ #' coefficients covariance matrix is used, the adjusted covariance matrix is returned (to still obtain the |
||
| 188 | +28 |
- #'+ #' original asymptotic covariance matrix use `object$beta_vcov`). |
||
| 189 | +29 |
- #' @return The corresponding abbreviated covariance type name.+ #' - `beta_vcov_complete`: estimated variance-covariance matrix including |
||
| 190 | +30 |
- #'+ #' aliased coefficients with entries set to `NA`. |
||
| 191 | +31 |
- #' @keywords internal+ #' - `varcor`: estimated covariance matrix for residuals. If there are multiple |
||
| 192 | +32 |
- cov_type_name <- function(type) {
- |
- ||
| 193 | -6x | -
- row <- which(COV_TYPES == type, arr.ind = TRUE)[, 1]- |
- ||
| 194 | -6x | -
- COV_TYPES$name[row]+ #' groups, a named list of estimated covariance matrices for residuals will be |
||
| 195 | +33 |
- }+ #' returned. The names are the group levels. |
||
| 196 | +34 |
-
+ #' - `theta_est`: estimated variance parameters. |
||
| 197 | +35 |
- #' Produce A Covariance Identifier Passing to TMB+ #' - `beta_est`: estimated coefficients (excluding aliased coefficients). |
||
| 198 | +36 |
- #'+ #' - `beta_est_complete`: estimated coefficients including aliased coefficients |
||
| 199 | +37 |
- #' @param cov (`cov_struct`)\cr a covariance structure object.+ #' set to `NA`. |
||
| 200 | +38 |
- #'+ #' - `beta_aliased`: whether each coefficient was aliased (i.e. cannot be estimated) |
||
| 201 | +39 |
- #' @return A string used for method dispatch when passed to TMB.+ #' or not. |
||
| 202 | +40 |
- #'+ #' - `theta_vcov`: estimated variance-covariance matrix of variance parameters. |
||
| 203 | +41 |
- #' @keywords internal+ #' - `x_matrix`: design matrix used (excluding aliased columns). |
||
| 204 | +42 |
- tmb_cov_type <- function(cov) {
- |
- ||
| 205 | -266x | -
- paste0(cov$type, if (cov$heterogeneous) "h")+ #' - `xlev`: a named list of character vectors giving the full set of levels to be assumed for each factor. |
||
| 206 | +43 |
- }+ #' - `contrasts`: a list of contrasts used for each factor. |
||
| 207 | +44 |
-
+ #' - `y_vector`: response vector used. |
||
| 208 | +45 |
- #' Define a Covariance Structure+ #' - `jac_list`: Jacobian, see [h_jac_list()] for details. |
||
| 209 | +46 |
- #'+ #' - `full_frame`: `data.frame` with `n` rows containing all variables needed in the model. |
||
| 210 | +47 |
- #' @description `r lifecycle::badge("stable")`
+ #' |
||
| 211 | +48 |
- #'+ #' @seealso In the `lme4` package there is a similar function `getME()`. |
||
| 212 | +49 |
- #' @param type (`string`)\cr the name of the covariance structure type to use.+ #' |
||
| 213 | +50 |
- #' For available options, see `cov_types()`. If a type abbreviation is used+ #' @examples |
||
| 214 | +51 |
- #' that implies heterogeneity (e.g. `cph`) and no value is provided to+ #' fit <- mmrm( |
||
| 215 | +52 |
- #' `heterogeneous`, then the heterogeneity is derived from the type name.+ #' formula = FEV1 ~ RACE + SEX + ARMCD * AVISIT + us(AVISIT | USUBJID), |
||
| 216 | +53 |
- #' @param visits (`character`)\cr a vector of variable names to use for the+ #' data = fev_data |
||
| 217 | +54 |
- #' longitudinal terms of the covariance structure. Multiple terms are only+ #' ) |
||
| 218 | +55 |
- #' permitted for the `"spatial"` covariance type.+ #' # Get all available components. |
||
| 219 | +56 |
- #' @param subject (`string`)\cr the name of the variable that encodes a subject+ #' component(fit) |
||
| 220 | +57 |
- #' identifier.+ #' # Get convergence code and message. |
||
| 221 | +58 |
- #' @param group (`string`)\cr optionally, the name of the variable that encodes+ #' component(fit, c("convergence", "conv_message"))
|
||
| 222 | +59 |
- #' a grouping variable for subjects.+ #' # Get modeled formula as a string. |
||
| 223 | +60 |
- #' @param heterogeneous (`flag`)\cr+ #' component(fit, c("formula"))
|
||
| 224 | +61 |
#' |
||
| 225 | +62 |
- #' @return A `cov_struct` object.+ #' @export |
||
| 226 | +63 |
- #'+ component <- function(object, |
||
| 227 | +64 |
- #' @examples+ name = c( |
||
| 228 | +65 |
- #' cov_struct("csh", "AVISITN", "USUBJID")
+ "cov_type", "subject_var", "n_theta", "n_subjects", "n_timepoints", |
||
| 229 | +66 |
- #' cov_struct("spatial", c("VISITA", "VISITB"), group = "GRP", subject = "SBJ")
+ "n_obs", "beta_vcov", "beta_vcov_complete", |
||
| 230 | +67 |
- #'+ "varcor", "formula", "dataset", "n_groups", |
||
| 231 | +68 |
- #' @family covariance types+ "reml", "convergence", "evaluations", "method", "optimizer", |
||
| 232 | +69 |
- #' @export+ "conv_message", "call", "theta_est", |
||
| 233 | +70 |
- cov_struct <- function(+ "beta_est", "beta_est_complete", "beta_aliased", |
||
| 234 | +71 |
- type = cov_types(), visits, subject, group = character(),+ "x_matrix", "y_vector", "neg_log_lik", "jac_list", "theta_vcov", |
||
| 235 | +72 |
- heterogeneous = FALSE) {
+ "full_frame", "xlev", "contrasts" |
||
| 236 | +73 |
- # if heterogeneous isn't provided, derive from provided type+ )) {
|
||
| 237 | -296x | +74 | +5115x |
- if (missing(heterogeneous)) {
+ assert_class(object, "mmrm_tmb") |
| 238 | -294x | +75 | +5115x |
- heterogeneous <- switch(type,+ name <- match.arg(name, several.ok = TRUE) |
| 239 | -294x | +|||
| 76 | +
- toeph = ,+ |
|||
| 240 | -294x | +77 | +5115x |
- ar1h = ,+ list_components <- sapply( |
| 241 | -294x | +78 | +5115x |
- adh = ,+ X = name, |
| 242 | -294x | +79 | +5115x |
- csh = TRUE,+ FUN = switch, |
| 243 | -294x | +80 | +5115x |
- heterogeneous+ "call" = object$call, |
| 244 | +81 |
- )+ # Strings. |
||
| 245 | -+ | |||
| 82 | +5115x |
- }+ "cov_type" = object$formula_parts$cov_type, |
||
| 246 | -+ | |||
| 83 | +5115x |
-
+ "subject_var" = object$formula_parts$subject_var, |
||
| 247 | -+ | |||
| 84 | +5115x |
- # coerce all type options into abbreviated form+ "formula" = deparse(object$call$formula), |
||
| 248 | -296x | +85 | +5115x |
- type <- match.arg(type)+ "dataset" = object$call$data, |
| 249 | -295x | +86 | +5115x |
- type <- cov_type_abbr(type)+ "reml" = object$reml,+ |
+
| 87 | +5115x | +
+ "conv_message" = object$opt_details$message, |
||
| 250 | +88 |
-
+ # Numeric of length 1. |
||
| 251 | -295x | +89 | +5115x |
- x <- structure(+ "convergence" = object$opt_details$convergence, |
| 252 | -295x | +90 | +5115x |
- list(+ "neg_log_lik" = object$neg_log_lik, |
| 253 | -295x | +91 | +5115x |
- type = type,+ "n_theta" = length(object$theta_est), |
| 254 | -295x | +92 | +5115x |
- heterogeneous = heterogeneous,+ "n_subjects" = object$tmb_data$n_subjects, |
| 255 | -295x | +93 | +5115x |
- visits = visits,+ "n_timepoints" = object$tmb_data$n_visits, |
| 256 | -295x | +94 | +5115x |
- subject = subject,+ "n_obs" = length(object$tmb_data$y_vector), |
| 257 | -295x | +95 | +5115x |
- group = group+ "n_groups" = ifelse(is.list(object$cov), length(object$cov), 1L), |
| 258 | +96 |
- ),+ # Numeric of length > 1. |
||
| 259 | -295x | -
- class = c("cov_struct", "mmrm_cov_struct", "list")
- |
- ||
| 260 | -+ | 97 | +5115x |
- )+ "evaluations" = unlist(ifelse(is.null(object$opt_details$evaluations), |
| 261 | -+ | |||
| 98 | +5115x |
-
+ list(object$opt_details$counts), |
||
| 262 | -295x | +99 | +5115x |
- validate_cov_struct(x)+ list(object$opt_details$evaluations) |
| 263 | +100 |
- }+ )), |
||
| 264 | -+ | |||
| 101 | +5115x |
-
+ "method" = object$method, |
||
| 265 | -+ | |||
| 102 | +5115x |
- #' Reconcile Possible Covariance Structure Inputs+ "optimizer" = object$optimizer, |
||
| 266 | -+ | |||
| 103 | +5115x |
- #'+ "beta_est" = object$beta_est, |
||
| 267 | -+ | |||
| 104 | +5115x |
- #' @inheritParams mmrm+ "beta_est_complete" = |
||
| 268 | -+ | |||
| 105 | +5115x |
- #'+ if (any(object$tmb_data$x_cols_aliased)) {
|
||
| 269 | -+ | |||
| 106 | +8x |
- #' @return The value `covariance` if it's provided or a covariance structure+ stats::setNames( |
||
| 270 | -+ | |||
| 107 | +8x |
- #' derived from the provided `formula` otherwise. An error is raised of both+ object$beta_est[names(object$tmb_data$x_cols_aliased)], |
||
| 271 | -+ | |||
| 108 | +8x |
- #' are provided.+ names(object$tmb_data$x_cols_aliased) |
||
| 272 | +109 |
- #'+ ) |
||
| 273 | +110 |
- #' @keywords internal+ } else {
+ |
+ ||
| 111 | +54x | +
+ object$beta_est |
||
| 274 | +112 |
- h_reconcile_cov_struct <- function(formula = NULL, covariance = NULL) {
+ }, |
||
| 275 | -238x | +113 | +5115x |
- assert_multi_class(covariance, c("formula", "cov_struct"), null.ok = TRUE)
+ "beta_aliased" = object$tmb_data$x_cols_aliased, |
| 276 | -238x | +114 | +5115x |
- assert_formula(formula, null.ok = FALSE)+ "theta_est" = object$theta_est, |
| 277 | -238x | +115 | +5115x |
- if (inherits(covariance, "formula")) {
+ "y_vector" = object$tmb_data$y_vector, |
| 278 | -4x | +116 | +5115x |
- covariance <- as.cov_struct(covariance)+ "jac_list" = object$jac_list, |
| 279 | +117 |
- }- |
- ||
| 280 | -238x | -
- if (!is.null(covariance) && length(h_extract_covariance_terms(formula)) > 0) {
+ # Matrices. |
||
| 281 | -2x | +118 | +5115x |
- stop(paste0(+ "beta_vcov" = |
| 282 | -2x | +119 | +5115x |
- "Redundant covariance structure definition in `formula` and ",+ if (is.null(object$vcov) || identical(object$vcov, "Asymptotic")) {
|
| 283 | -2x | +120 | +985x |
- "`covariance` arguments"+ object$beta_vcov |
| 284 | +121 |
- ))+ } else {
|
||
| 285 | -+ | |||
| 122 | +66x |
- }+ object$beta_vcov_adj |
||
| 286 | +123 |
-
+ }, |
||
| 287 | -236x | +124 | +5115x |
- if (!is.null(covariance)) {
+ "beta_vcov_complete" = |
| 288 | -5x | +125 | +5115x |
- return(covariance)+ if (any(object$tmb_data$x_cols_aliased)) {
|
| 289 | -+ | |||
| 126 | +2x |
- }+ stats::.vcov.aliased( |
||
| 290 | -+ | |||
| 127 | +2x |
-
+ aliased = object$tmb_data$x_cols_aliased, |
||
| 291 | -231x | +128 | +2x |
- as.cov_struct(formula, warn_partial = FALSE)+ vc = component(object, "beta_vcov"), |
| 292 | -+ | |||
| 129 | +2x |
- }+ complete = TRUE |
||
| 293 | +130 |
-
+ ) |
||
| 294 | +131 |
- #' Validate Covariance Structure Data+ } else {
|
||
| 295 | -+ | |||
| 132 | +4x |
- #'+ object$beta_vcov |
||
| 296 | +133 |
- #' Run checks against relational integrity of covariance definition+ }, |
||
| 297 | -+ | |||
| 134 | +5115x |
- #'+ "varcor" = object$cov, |
||
| 298 | -+ | |||
| 135 | +5115x |
- #' @param x (`cov_struct`)\cr a covariance structure object.+ "x_matrix" = object$tmb_data$x_matrix, |
||
| 299 | -+ | |||
| 136 | +5115x |
- #'+ "xlev" = stats::.getXlevels(terms(object), object$tmb_data$full_frame), |
||
| 300 | -+ | |||
| 137 | +5115x |
- #' @return `x` if successful, or an error is thrown otherwise.+ "contrasts" = attr(object$tmb_data$x_matrix, "contrasts"), |
||
| 301 | -+ | |||
| 138 | +5115x |
- #'+ "theta_vcov" = object$theta_vcov, |
||
| 302 | -+ | |||
| 139 | +5115x |
- #' @keywords internal+ "full_frame" = object$tmb_data$full_frame, |
||
| 303 | +140 |
- validate_cov_struct <- function(x) {
+ # If not found. |
||
| 304 | -295x | -
- checks <- checkmate::makeAssertCollection()- |
- ||
| 305 | -+ | 141 | +5115x |
-
+ "..foo.." = |
| 306 | -295x | +142 | +5115x |
- with(x, {
+ stop(sprintf( |
| 307 | -295x | +143 | +5115x |
- assert_character(subject, len = 1, add = checks)+ "component '%s' is not available", |
| 308 | -295x | +144 | +5115x |
- assert_logical(heterogeneous, len = 1, add = checks)+ name, paste0(class(object), collapse = ", ") |
| 309 | +145 |
-
+ )), |
||
| 310 | -295x | +146 | +5115x |
- if (length(group) > 1 || length(visits) < 1) {
+ simplify = FALSE+ |
+
| 147 | ++ |
+ ) |
||
| 311 | -4x | +|||
| 148 | +
- checks$push(+ |
|||
| 312 | -4x | +149 | +23x |
- "Covariance structure must be of the form `time | (group /) subject`"+ if (length(name) == 1) list_components[[1]] else list_components |
| 313 | +150 |
- )+ } |
| 314 | +1 |
- }+ #' Register `mmrm` For Use With `tidymodels` |
||
| 315 | +2 |
-
+ #' |
||
| 316 | -295x | +|||
| 3 | +
- if (!type %in% cov_types(filter = "spatial") && length(visits) > 1) {
+ #' @inheritParams base::requireNamespace |
|||
| 317 | -2x | +|||
| 4 | +
- checks$push(paste(+ #' @return A logical value indicating whether registration was successful. |
|||
| 318 | -2x | +|||
| 5 | +
- "Non-spatial covariance structures must have a single longitudinal",+ #' |
|||
| 319 | -2x | +|||
| 6 | +
- "variable"+ #' @details We can use `parsnip::show_model_info("linear_reg")` to check the
|
|||
| 320 | +7 |
- ))+ #' registration with `parsnip` and thus the wider `tidymodels` ecosystem. |
||
| 321 | +8 |
- }+ #' |
||
| 322 | +9 |
- })+ #' @keywords internal |
||
| 323 | +10 |
-
+ parsnip_add_mmrm <- function(quietly = FALSE) {
|
||
| 324 | -295x | +11 | +1x |
- reportAssertions(checks)+ if (!requireNamespace("parsnip", quietly = quietly)) {
|
| 325 | -289x | +|||
| 12 | +! |
- x+ return(FALSE) |
||
| 326 | +13 |
- }+ } |
||
| 327 | +14 | |||
| 328 | -+ | |||
| 15 | +1x |
- #' Format Covariance Structure Object+ parsnip::set_model_engine( |
||
| 329 | -+ | |||
| 16 | +1x |
- #'+ model = "linear_reg", |
||
| 330 | -+ | |||
| 17 | +1x |
- #' @param x (`cov_struct`)\cr a covariance structure object.+ eng = "mmrm", |
||
| 331 | -+ | |||
| 18 | +1x |
- #' @param ... Additional arguments unused.+ mode = "regression" |
||
| 332 | +19 |
- #'+ ) |
||
| 333 | +20 |
- #' @return A formatted string for `x`.+ |
||
| 334 | -+ | |||
| 21 | +1x |
- #'+ parsnip::set_dependency( |
||
| 335 | -+ | |||
| 22 | +1x |
- #' @export+ pkg = "mmrm", |
||
| 336 | -+ | |||
| 23 | +1x |
- format.cov_struct <- function(x, ...) {
+ model = "linear_reg", |
||
| 337 | -3x | +24 | +1x |
- sprintf(+ eng = "mmrm", |
| 338 | -3x | +25 | +1x |
- "<covariance structure>\n%s%s:\n\n %s | %s%s\n",+ mode = "regression"+ |
+
| 26 | ++ |
+ )+ |
+ ||
| 27 | ++ | + | ||
| 339 | -3x | +28 | +1x |
- if (x$heterogeneous) "heterogeneous " else "",+ parsnip::set_encoding( |
| 340 | -3x | +29 | +1x |
- cov_type_name(x$type),+ model = "linear_reg", |
| 341 | -3x | +30 | +1x |
- format_symbols(x$visits),+ eng = "mmrm", |
| 342 | -3x | +31 | +1x |
- if (length(x$group) > 0) paste0(format_symbols(x$group), " / ") else "",+ mode = "regression", |
| 343 | -3x | +32 | +1x |
- format_symbols(x$subject)+ options = list( |
| 344 | -+ | |||
| 33 | +1x |
- )+ predictor_indicators = "none", |
||
| 345 | -+ | |||
| 34 | +1x |
- }+ compute_intercept = FALSE, |
||
| 346 | -+ | |||
| 35 | +1x |
-
+ remove_intercept = FALSE, |
||
| 347 | -+ | |||
| 36 | +1x |
- #' Print a Covariance Structure Object+ allow_sparse_x = TRUE |
||
| 348 | +37 |
- #'+ ) |
||
| 349 | +38 |
- #' @param x (`cov_struct`)\cr a covariance structure object.+ ) |
||
| 350 | +39 |
- #' @param ... Additional arguments unused.+ |
||
| 351 | -+ | |||
| 40 | +1x |
- #'+ parsnip::set_fit( |
||
| 352 | -+ | |||
| 41 | +1x |
- #' @return `x` invisibly.+ model = "linear_reg", |
||
| 353 | -+ | |||
| 42 | +1x |
- #'+ eng = "mmrm", |
||
| 354 | -+ | |||
| 43 | +1x |
- #' @export+ mode = "regression", |
||
| 355 | -+ | |||
| 44 | +1x |
- print.cov_struct <- function(x, ...) {
+ value = list( |
||
| 356 | -3x | +45 | +1x |
- cat(format(x, ...), "\n")+ interface = "formula", |
| 357 | -3x | +46 | +1x |
- invisible(x)+ protect = c("formula", "data", "weights"),
|
| 358 | -+ | |||
| 47 | +1x |
- }+ data = c(formula = "formula", data = "data", weights = "weights"), |
||
| 359 | -+ | |||
| 48 | +1x |
-
+ func = c(pkg = "mmrm", fun = "mmrm"), |
||
| 360 | -+ | |||
| 49 | +1x |
- #' Coerce into a Covariance Structure Definition+ defaults = list() |
||
| 361 | +50 |
- #'+ ) |
||
| 362 | +51 |
- #' @description `r lifecycle::badge("stable")`
+ ) |
||
| 363 | +52 |
- #'+ |
||
| 364 | -+ | |||
| 53 | +1x |
- #' @details+ parsnip::set_pred( |
||
| 365 | -+ | |||
| 54 | +1x |
- #' A covariance structure can be parsed from a model definition formula or call.+ model = "linear_reg", |
||
| 366 | -+ | |||
| 55 | +1x |
- #' Generally, covariance structures defined using non-standard evaluation take+ eng = "mmrm", |
||
| 367 | -+ | |||
| 56 | +1x |
- #' the following form:+ mode = "regression", |
||
| 368 | -+ | |||
| 57 | +1x |
- #'+ type = "numeric", |
||
| 369 | -+ | |||
| 58 | +1x |
- #' ```+ value = parsnip::pred_value_template( |
||
| 370 | +59 |
- #' type( (visit, )* visit | (group /)? subject )+ # This is boilerplate. |
||
| 371 | -+ | |||
| 60 | +1x |
- #' ```+ func = c(fun = "predict"), |
||
| 372 | -+ | |||
| 61 | +1x |
- #'+ object = quote(object$fit), |
||
| 373 | -+ | |||
| 62 | +1x |
- #' For example, formulas may include terms such as+ newdata = quote(new_data) |
||
| 374 | +63 |
- #'+ ) |
||
| 375 | +64 |
- #' ```r+ ) |
||
| 376 | +65 |
- #' us(time | subject)+ |
||
| 377 | -+ | |||
| 66 | +1x |
- #' cp(time | group / subject)+ parsnip::set_pred( |
||
| 378 | -+ | |||
| 67 | +1x |
- #' sp_exp(coord1, coord2 | group / subject)+ model = "linear_reg", |
||
| 379 | -+ | |||
| 68 | +1x |
- #' ```+ eng = "mmrm", |
||
| 380 | -+ | |||
| 69 | +1x |
- #'+ mode = "regression", |
||
| 381 | +70 |
- #' Note that only `sp_exp` (spatial) covariance structures may provide multiple+ # This type allows to pass arguments via `opts` to `parsnip::predict.model_fit`. |
||
| 382 | -+ | |||
| 71 | +1x |
- #' coordinates, which identify the Euclidean distance between the time points.+ type = "raw", |
||
| 383 | -+ | |||
| 72 | +1x |
- #'+ value = parsnip::pred_value_template( |
||
| 384 | +73 |
- #' @param x an object from which to derive a covariance structure. See object+ # This is boilerplate. |
||
| 385 | -+ | |||
| 74 | +1x |
- #' specific sections for details.+ func = c(fun = "predict"), |
||
| 386 | -+ | |||
| 75 | +1x |
- #' @param warn_partial (`flag`)\cr whether to emit a warning when parts of the+ object = quote(object$fit), |
||
| 387 | -+ | |||
| 76 | +1x |
- #' formula are disregarded.+ newdata = quote(new_data) |
||
| 388 | +77 |
- #' @param ... additional arguments unused.+ # We don't specify additional argument defaults here since otherwise |
||
| 389 | +78 |
- #'+ # the user is not able to change them (they will be fixed). |
||
| 390 | +79 |
- #' @return A [cov_struct()] object.+ ) |
||
| 391 | +80 |
- #'+ ) |
||
| 392 | +81 |
- #' @examples+ |
||
| 393 | -+ | |||
| 82 | +1x |
- #' # provide a covariance structure as a right-sided formula+ TRUE |
||
| 394 | +83 |
- #' as.cov_struct(~ csh(visit | group / subject))+ } |
| 395 | +1 |
- #'+ #' Methods for `mmrm_tmb` Objects |
||
| 396 | +2 |
- #' # 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_tmb`)\cr the fitted MMRM object. |
||
| 400 | +6 |
- #' @export+ #' @param x (`mmrm_tmb`)\cr same as `object`. |
||
| 401 | +7 |
- as.cov_struct <- function(x, ...) { # nolint
- |
- ||
| 402 | -278x | -
- UseMethod("as.cov_struct")
+ #' @param formula (`mmrm_tmb`)\cr same as `object`. |
||
| 403 | +8 |
- }+ #' @param complete (`flag`)\cr whether to include potential non-estimable |
||
| 404 | +9 |
-
+ #' coefficients. |
||
| 405 | +10 |
- #' @export+ #' @param ... mostly not used; |
||
| 406 | +11 |
- as.cov_struct.cov_struct <- function(x, ...) {
+ #' Exception is `model.matrix()` passing `...` to the default method. |
||
| 407 | -! | +|||
| 12 | +
- x+ #' @return Depends on the method, see Functions. |
|||
| 408 | +13 |
- }+ #' |
||
| 409 | +14 |
-
+ #' @name mmrm_tmb_methods |
||
| 410 | +15 |
- #' @describeIn as.cov_struct+ #' |
||
| 411 | +16 |
- #' When provided a formula, any specialized functions are assumed to be+ #' @seealso [`mmrm_methods`], [`mmrm_tidiers`] for additional methods. |
||
| 412 | +17 |
- #' covariance structure definitions and must follow the form:+ #' |
||
| 413 | +18 |
- #'+ #' @examples |
||
| 414 | +19 |
- #' ```+ #' formula <- FEV1 ~ RACE + SEX + ARMCD * AVISIT + us(AVISIT | USUBJID) |
||
| 415 | +20 |
- #' y ~ xs + type( (visit, )* visit | (group /)? subject )+ #' object <- fit_mmrm(formula, fev_data, weights = rep(1, nrow(fev_data))) |
||
| 416 | +21 |
- #' ```+ NULL |
||
| 417 | +22 |
- #'+ |
||
| 418 | +23 |
- #' Any component on the right hand side of a formula is considered when+ #' @describeIn mmrm_tmb_methods obtains the estimated coefficients. |
||
| 419 | +24 |
- #' searching for a covariance definition.+ #' @importFrom stats coef |
||
| 420 | +25 |
- #'+ #' @exportS3Method |
||
| 421 | +26 |
- #' @export+ #' @examples |
||
| 422 | +27 |
- as.cov_struct.formula <- function(x, warn_partial = TRUE, ...) {
+ #' # Estimated coefficients: |
||
| 423 | -278x | +|||
| 28 | +
- x_calls <- h_extract_covariance_terms(x)+ #' coef(object) |
|||
| 424 | +29 |
-
+ coef.mmrm_tmb <- function(object, complete = TRUE, ...) {
|
||
| 425 | -278x | +30 | +58x |
- if (length(x_calls) < 1) {
+ assert_flag(complete) |
| 426 | -4x | +31 | +58x |
- stop(+ nm <- if (complete) "beta_est_complete" else "beta_est" |
| 427 | -4x | +32 | +58x |
- "Covariance structure must be specified in formula. ",+ component(object, name = nm) |
| 428 | -4x | +|||
| 33 | +
- "Possible covariance structures include: ",+ } |
|||
| 429 | -4x | +|||
| 34 | +
- paste0(cov_types(c("abbr", "habbr")), collapse = ", ")
+
|
|||
| 430 | +35 |
- )+ #' @describeIn mmrm_tmb_methods obtains the fitted values. |
||
| 431 | +36 |
- }+ #' @importFrom stats fitted |
||
| 432 | +37 |
-
+ #' @exportS3Method |
||
| 433 | -274x | +|||
| 38 | +
- if (length(x_calls) > 1) {
+ #' @examples |
|||
| 434 | -1x | +|||
| 39 | +
- cov_struct_types <- as.character(lapply(x_calls, `[[`, 1L))+ #' # Fitted values: |
|||
| 435 | -1x | +|||
| 40 | +
- stop(+ #' fitted(object) |
|||
| 436 | -1x | +|||
| 41 | +
- "Only one covariance structure can be specified. ",+ fitted.mmrm_tmb <- function(object, ...) {
|
|||
| 437 | -1x | +42 | +19x |
- "Currently specified covariance structures are: ",+ fitted_col <- component(object, "x_matrix") %*% component(object, "beta_est") |
| 438 | -1x | +43 | +19x |
- paste0(cov_struct_types, collapse = ", ")+ fitted_col[, 1L, drop = TRUE] |
| 439 | +44 |
- )+ } |
||
| 440 | +45 |
- }+ |
||
| 441 | +46 |
-
+ #' @describeIn mmrm_tmb_methods predict conditional means for new data; |
||
| 442 | +47 |
- # flatten into list of infix operators, calls and names/atomics+ #' optionally with standard errors and confidence or prediction intervals. |
||
| 443 | -273x | +|||
| 48 | +
- x <- flatten_call(x_calls[[1]])+ #' Returns a vector of predictions if `se.fit == FALSE` and |
|||
| 444 | -273x | +|||
| 49 | +
- type <- as.character(x[[1]])+ #' `interval == "none"`; otherwise it returns a data.frame with multiple |
|||
| 445 | -273x | +|||
| 50 | +
- x <- drop_elements(x, 1)+ #' columns and one row per input data row. |
|||
| 446 | +51 |
-
+ #' |
||
| 447 | +52 |
- # take visits until "|"+ #' @param newdata (`data.frame`)\cr optional new data, otherwise data from `object` is used. |
||
| 448 | -273x | +|||
| 53 | +
- n <- position_symbol(x, "|", nomatch = 0)+ #' @param se.fit (`flag`)\cr indicator if standard errors are required. |
|||
| 449 | -273x | +|||
| 54 | +
- visits <- as.character(utils::head(x, max(n - 1, 0)))+ #' @param interval (`string`)\cr type of interval calculation. Can be abbreviated. |
|||
| 450 | -273x | +|||
| 55 | +
- x <- drop_elements(x, n)+ #' @param level (`number`)\cr tolerance/confidence level. |
|||
| 451 | +56 |
-
+ #' @param nsim (`count`)\cr number of simulations to use. |
||
| 452 | +57 |
- # take group until "/"+ #' @param conditional (`flag`)\cr indicator if the prediction is conditional on the observation or not. |
||
| 453 | -273x | +|||
| 58 | +
- n <- position_symbol(x, "/", nomatch = 0)+ #' |
|||
| 454 | -273x | +|||
| 59 | +
- group <- as.character(utils::head(x, max(n - 1, 0)))+ #' @importFrom stats predict |
|||
| 455 | -273x | +|||
| 60 | +
- x <- drop_elements(x, n)+ #' @exportS3Method |
|||
| 456 | +61 |
-
+ #' |
||
| 457 | +62 |
- # remainder is subject+ #' @examples |
||
| 458 | -273x | +|||
| 63 | +
- subject <- as.character(x)+ #' predict(object, newdata = fev_data) |
|||
| 459 | +64 |
-
+ predict.mmrm_tmb <- function(object, |
||
| 460 | -273x | +|||
| 65 | +
- cov_struct(type = type, visits = visits, group = group, subject = subject)+ newdata, |
|||
| 461 | +66 |
- }+ se.fit = FALSE, # nolint |
| 1 | +67 |
- #' Support for `emmeans`+ interval = c("none", "confidence", "prediction"),
|
||
| 2 | +68 |
- #'+ level = 0.95, |
||
| 3 | +69 |
- #' @description `r lifecycle::badge("stable")`
+ nsim = 1000L, |
||
| 4 | +70 |
- #'+ conditional = FALSE, |
||
| 5 | +71 |
- #' This package includes methods that allow `mmrm` objects to be used+ ...) {
|
||
| 6 | -+ | |||
| 72 | +45x |
- #' with the `emmeans` package. `emmeans` computes estimated marginal means+ if (missing(newdata)) {
|
||
| 7 | -+ | |||
| 73 | +8x |
- #' (also called least-square means) for the coefficients of the MMRM.+ newdata <- object$data |
||
| 8 | +74 |
- #' We can also e.g. obtain differences between groups by applying+ } |
||
| 9 | -+ | |||
| 75 | +45x |
- #' [`pairs()`][emmeans::pairs.emmGrid()] on the object returned+ assert_data_frame(newdata) |
||
| 10 | -+ | |||
| 76 | +45x |
- #' by [emmeans::emmeans()].+ orig_row_names <- row.names(newdata)+ |
+ ||
| 77 | +45x | +
+ assert_flag(se.fit)+ |
+ ||
| 78 | +45x | +
+ assert_number(level, lower = 0, upper = 1)+ |
+ ||
| 79 | +45x | +
+ assert_count(nsim, positive = TRUE)+ |
+ ||
| 80 | +45x | +
+ assert_flag(conditional)+ |
+ ||
| 81 | +45x | +
+ interval <- match.arg(interval)+ |
+ ||
| 82 | +45x | +
+ formula_parts <- object$formula_parts+ |
+ ||
| 83 | +45x | +
+ if (any(object$tmb_data$x_cols_aliased)) {
|
||
| 11 | -+ | |||
| 84 | +1x |
- #'+ warning( |
||
| 12 | -+ | |||
| 85 | +1x |
- #' @examples+ "In fitted object there are co-linear variables and therefore dropped terms, ", |
||
| 13 | -+ | |||
| 86 | +1x |
- #' fit <- mmrm(+ "and this could lead to incorrect prediction on new data." |
||
| 14 | +87 |
- #' formula = FEV1 ~ RACE + SEX + ARMCD * AVISIT + us(AVISIT | USUBJID),+ ) |
||
| 15 | +88 |
- #' data = fev_data+ } |
||
| 16 | -+ | |||
| 89 | +45x |
- #' )+ colnames <- names(Filter(isFALSE, object$tmb_data$x_cols_aliased)) |
||
| 17 | -+ | |||
| 90 | +45x |
- #' if (require(emmeans)) {
+ if (!conditional && interval %in% c("none", "confidence")) {
|
||
| 18 | +91 |
- #' emmeans(fit, ~ ARMCD | AVISIT)+ # model.matrix always return a complete matrix (no NA allowed) |
||
| 19 | -+ | |||
| 92 | +27x |
- #' pairs(emmeans(fit, ~ ARMCD | AVISIT), reverse = TRUE)+ x_mat <- stats::model.matrix(object, data = newdata, use_response = FALSE)[, colnames, drop = FALSE] |
||
| 20 | -+ | |||
| 93 | +27x |
- #' }+ x_mat_full <- matrix( |
||
| 21 | -+ | |||
| 94 | +27x |
- #' @name emmeans_support+ NA, |
||
| 22 | -+ | |||
| 95 | +27x |
- NULL+ nrow = nrow(newdata), ncol = ncol(x_mat), |
||
| 23 | -+ | |||
| 96 | +27x |
-
+ dimnames = list(row.names(newdata), colnames(x_mat)) |
||
| 24 | +97 |
- #' Returns a `data.frame` for `emmeans` Purposes+ ) |
||
| 25 | -+ | |||
| 98 | +27x |
- #'+ x_mat_full[row.names(x_mat), ] <- x_mat |
||
| 26 | -+ | |||
| 99 | +27x |
- #' @seealso See [emmeans::recover_data()] for background.+ predictions <- (x_mat_full %*% component(object, "beta_est"))[, 1] |
||
| 27 | -+ | |||
| 100 | +27x |
- #' @keywords internal+ predictions_raw <- stats::setNames(rep(NA_real_, nrow(newdata)), row.names(newdata)) |
||
| 28 | -+ | |||
| 101 | +27x |
- #' @noRd+ predictions_raw[names(predictions)] <- predictions |
||
| 29 | -+ | |||
| 102 | +27x |
- recover_data.mmrm <- function(object, ...) { # nolint
+ if (identical(interval, "none")) {
|
||
| 30 | -13x | +103 | +20x |
- fun_call <- stats::getCall(object)+ return(predictions_raw) |
| 31 | +104 |
- # subject_var is excluded because it should not contain fixed effect.+ } |
||
| 32 | -+ | |||
| 105 | +7x |
- # visit_var is not excluded because emmeans can provide marginal mean+ se <- switch(interval, |
||
| 33 | +106 |
- # by each visit if visit_var is not spatial.+ # can be NA if there are aliased cols |
||
| 34 | -13x | +107 | +7x |
- model_frame <- stats::model.frame(+ "confidence" = diag(x_mat_full %*% component(object, "beta_vcov") %*% t(x_mat_full)), |
| 35 | -13x | +108 | +7x |
- object,+ "none" = NA_real_+ |
+
| 109 | ++ |
+ ) |
||
| 36 | -13x | +110 | +7x |
- include = c(+ res <- cbind( |
| 37 | -13x | +111 | +7x |
- if (!object$formula_parts$is_spatial) "visit_var" else NULL,+ fit = predictions, se = se, |
| 38 | -13x | +112 | +7x |
- "response_var", "group_var"+ lwr = predictions - stats::qnorm(1 - level / 2) * se, upr = predictions + stats::qnorm(1 - level / 2) * se |
| 39 | +113 |
) |
||
| 40 | -+ | |||
| 114 | +7x |
- )+ if (!se.fit) {
|
||
| 41 | -13x | +115 | +1x |
- model_terms <- stats::delete.response(stats::terms(model_frame))+ res <- res[, setdiff(colnames(res), "se")] |
| 42 | -13x | +|||
| 116 | +
- emmeans::recover_data(+ } |
|||
| 43 | -13x | +117 | +7x |
- fun_call,+ res_raw <- matrix( |
| 44 | -13x | +118 | +7x |
- trms = model_terms,+ NA_real_, |
| 45 | -13x | +119 | +7x |
- na.action = "na.omit",+ ncol = ncol(res), nrow = nrow(newdata), |
| 46 | -13x | +120 | +7x |
- frame = model_frame,+ dimnames = list(row.names(newdata), colnames(res)) |
| 47 | +121 |
- ...+ ) |
||
| 48 | -+ | |||
| 122 | +7x |
- )+ res_raw[row.names(res), ] <- res |
||
| 49 | -+ | |||
| 123 | +7x |
- }+ return(res_raw) |
||
| 50 | +124 |
-
+ } |
||
| 51 | -+ | |||
| 125 | +18x |
- #' Returns a List of Model Details for `emmeans` Purposes+ tmb_data <- h_mmrm_tmb_data( |
||
| 52 | -+ | |||
| 126 | +18x |
- #'+ formula_parts, newdata, |
||
| 53 | -+ | |||
| 127 | +18x |
- #' @seealso See [emmeans::emm_basis()] for background.+ weights = rep(1, nrow(newdata)), |
||
| 54 | -+ | |||
| 128 | +18x |
- #' @keywords internal+ reml = TRUE, |
||
| 55 | -+ | |||
| 129 | +18x |
- #' @noRd+ singular = "keep", |
||
| 56 | -+ | |||
| 130 | +18x |
- emm_basis.mmrm <- function(object, # nolint+ drop_visit_levels = FALSE, |
||
| 57 | -+ | |||
| 131 | +18x |
- trms,+ allow_na_response = TRUE, |
||
| 58 | -+ | |||
| 132 | +18x |
- xlev,+ drop_levels = FALSE, |
||
| 59 | -+ | |||
| 133 | +18x |
- grid,+ xlev = component(object, "xlev"),+ |
+ ||
| 134 | +18x | +
+ contrasts = component(object, "contrasts") |
||
| 60 | +135 |
- ...) {
+ ) |
||
| 61 | -13x | +136 | +18x |
- model_frame <- stats::model.frame(trms, grid, na.action = stats::na.pass, xlev = xlev)+ tmb_data$x_matrix <- tmb_data$x_matrix[, colnames, drop = FALSE] |
| 62 | -13x | +137 | +18x |
- contrasts <- component(object, "contrasts")+ predictions <- h_get_prediction( |
| 63 | -13x | +138 | +18x |
- model_mat <- stats::model.matrix(trms, model_frame, contrasts.arg = contrasts)+ tmb_data, object$theta_est, object$beta_est, component(object, "beta_vcov") |
| 64 | -13x | +139 | +18x |
- beta_hat <- component(object, "beta_est")+ )$prediction |
| 65 | -13x | +140 | +18x |
- nbasis <- if (length(beta_hat) < ncol(model_mat)) {
+ res <- cbind(fit = rep(NA_real_, nrow(newdata))) |
| 66 | -6x | +141 | +18x |
- kept <- match(names(beta_hat), colnames(model_mat))+ new_order <- match(row.names(tmb_data$full_frame), orig_row_names) |
| 67 | -6x | +142 | +18x |
- beta_hat <- NA * model_mat[1L, ]+ res[new_order, "fit"] <- predictions[, "fit"] |
| 68 | -6x | +143 | +18x |
- beta_hat[kept] <- component(object, "beta_est")+ se <- switch(interval, |
| 69 | -6x | +144 | +18x |
- orig_model_mat <- stats::model.matrix(+ "confidence" = sqrt(predictions[, "conf_var"]), |
| 70 | -6x | +145 | +18x |
- trms,+ "prediction" = sqrt(h_get_prediction_variance(object, nsim, tmb_data)), |
| 71 | -6x | +146 | +18x |
- stats::model.frame(+ "none" = NULL+ |
+
| 147 | ++ |
+ ) |
||
| 72 | -6x | +148 | +18x |
- object,+ if (interval != "none") {
|
| 73 | -6x | +149 | +7x |
- include = c(+ res <- cbind( |
| 74 | -6x | +150 | +7x |
- if (!object$formula_parts$is_spatial) "visit_var" else NULL,+ res, |
| 75 | -6x | +151 | +7x |
- "response_var", "group_var"+ se = NA_real_ |
| 76 | +152 |
- )+ ) |
||
| 77 | -+ | |||
| 153 | +7x |
- ),+ res[new_order, "se"] <- se |
||
| 78 | -6x | +154 | +7x |
- contrasts.arg = contrasts+ alpha <- 1 - level |
| 79 | -+ | |||
| 155 | +7x |
- )+ z <- stats::qnorm(1 - alpha / 2) * res[, "se"] |
||
| 80 | -6x | +156 | +7x |
- estimability::nonest.basis(orig_model_mat)+ res <- cbind( |
| 81 | -+ | |||
| 157 | +7x |
- } else {
+ res, |
||
| 82 | +158 | 7x |
- estimability::all.estble+ lwr = res[, "fit"] - z,+ |
+ |
| 159 | +7x | +
+ upr = res[, "fit"] + z |
||
| 83 | +160 |
- }+ ) |
||
| 84 | -13x | +161 | +7x | +
+ if (!se.fit) {
+ |
+
| 162 | +! |
- dfargs <- list(object = object)+ res <- res[, setdiff(colnames(res), "se")] |
||
| 85 | -13x | +|||
| 163 | +
- dffun <- function(k, dfargs) {
+ } |
|||
| 86 | -113x | +|||
| 164 | +
- mmrm::df_md(dfargs$object, contrast = k)$denom_df+ } |
|||
| 87 | +165 |
- }+ # Use original names. |
||
| 88 | -13x | +166 | +18x |
- list(+ row.names(res) <- orig_row_names |
| 89 | -13x | +167 | +18x |
- X = model_mat,+ if (ncol(res) == 1) {
|
| 90 | -13x | +168 | +11x |
- bhat = beta_hat,+ res <- res[, "fit"] |
| 91 | -13x | +|||
| 169 | +
- nbasis = nbasis,+ } |
|||
| 92 | -13x | +170 | +18x |
- V = component(object, "beta_vcov"),+ return(res) |
| 93 | -13x | +|||
| 171 | +
- dffun = dffun,+ } |
|||
| 94 | -13x | +|||
| 172 | +
- dfargs = dfargs+ |
|||
| 95 | +173 |
- )+ #' Get Prediction |
||
| 96 | +174 |
- }+ #' |
| 1 | +175 |
- #' Obtain List of Jacobian Matrix Entries for Covariance Matrix+ #' @description Get predictions with given `data`, `theta`, `beta`, `beta_vcov`. |
||
| 2 | +176 |
#' |
||
| 3 | +177 |
- #' @description Obtain the Jacobian matrices given the covariance function and variance parameters.+ #' @details See `predict` function in `predict.cpp` which is called internally. |
||
| 4 | +178 |
#' |
||
| 5 | +179 |
- #' @param tmb_data (`mmrm_tmb_data`)\cr produced by [h_mmrm_tmb_data()].+ #' @param tmb_data (`mmrm_tmb_data`)\cr object. |
||
| 6 | +180 |
- #' @param theta_est (`numeric`)\cr variance parameters point estimate.+ #' @param theta (`numeric`)\cr theta value. |
||
| 7 | +181 |
- #' @param beta_vcov (`matrix`)\cr vairance covariance matrix of coefficients.+ #' @param beta (`numeric`)\cr beta value. |
||
| 8 | +182 |
- #'+ #' @param beta_vcov (`matrix`)\cr beta_vcov matrix. |
||
| 9 | +183 |
- #' @return List with one element per variance parameter containing a matrix+ #' |
||
| 10 | +184 |
- #' of the same dimensions as the covariance matrix. The values are the derivatives+ #' @return List with: |
||
| 11 | +185 |
- #' with regards to this variance parameter.+ #' - `prediction`: Matrix with columns `fit`, `conf_var`, and `var`. |
||
| 12 | +186 |
- #'+ #' - `covariance`: List with subject specific covariance matrices. |
||
| 13 | +187 |
- #' @keywords internal+ #' - `index`: List of zero-based subject indices. |
||
| 14 | +188 |
- h_jac_list <- function(tmb_data,+ #' |
||
| 15 | +189 |
- theta_est,+ #' @keywords internal |
||
| 16 | +190 |
- beta_vcov) {
+ h_get_prediction <- function(tmb_data, theta, beta, beta_vcov) {
|
||
| 17 | -82x | +191 | +1696x |
assert_class(tmb_data, "mmrm_tmb_data") |
| 18 | -82x | +192 | +1696x |
- assert_numeric(theta_est)+ assert_numeric(theta) |
| 19 | -82x | +193 | +1696x |
- assert_matrix(beta_vcov)+ n_beta <- ncol(tmb_data$x_matrix) |
| 20 | -82x | +194 | +1696x |
- .Call(`_mmrm_get_jacobian`, PACKAGE = "mmrm", tmb_data, theta_est, beta_vcov)+ assert_numeric(beta, finite = TRUE, any.missing = FALSE, len = n_beta)+ |
+
| 195 | +1696x | +
+ assert_matrix(beta_vcov, mode = "numeric", any.missing = FALSE, nrows = n_beta, ncols = n_beta)+ |
+ ||
| 196 | +1696x | +
+ .Call(`_mmrm_predict`, PACKAGE = "mmrm", tmb_data, theta, beta, beta_vcov) |
||
| 21 | +197 |
} |
||
| 22 | +198 | |||
| 23 | +199 |
- #' Quadratic Form Calculations+ #' Get Prediction Variance |
||
| 24 | +200 |
#' |
||
| 25 | +201 |
- #' @description These helpers are mainly for easier readability and slightly better efficiency+ #' @description Get prediction variance with given fit, `tmb_data` with the Monte Carlo sampling method. |
||
| 26 | +202 |
- #' of the quadratic forms used in the Satterthwaite calculations.+ #' |
||
| 27 | +203 |
- #'+ #' @param object (`mmrm_tmb`)\cr the fitted MMRM. |
||
| 28 | +204 |
- #' @param center (`matrix`)\cr square numeric matrix with the same dimensions as+ #' @param nsim (`count`)\cr number of samples. |
||
| 29 | +205 |
- #' `x` as the center of the quadratic form.+ #' @param tmb_data (`mmrm_tmb_data`)\cr object. |
||
| 30 | +206 |
#' |
||
| 31 | +207 |
- #' @name h_quad_form+ #' @keywords internal |
||
| 32 | +208 |
- NULL+ h_get_prediction_variance <- function(object, nsim, tmb_data) {
|
||
| 33 | -+ | |||
| 209 | +7x |
-
+ assert_class(object, "mmrm_tmb") |
||
| 34 | -+ | |||
| 210 | +7x |
- #' @describeIn h_quad_form calculates the number `vec %*% center %*% t(vec)`+ assert_class(tmb_data, "mmrm_tmb_data") |
||
| 35 | -+ | |||
| 211 | +7x |
- #' as a numeric (not a matrix).+ assert_count(nsim, positive = TRUE) |
||
| 36 | -+ | |||
| 212 | +7x |
- #'+ theta_chol <- chol(object$theta_vcov) |
||
| 37 | -+ | |||
| 213 | +7x |
- #' @param vec (`numeric`)\cr interpreted as a row vector.+ n_theta <- length(object$theta_est) |
||
| 38 | -+ | |||
| 214 | +7x |
- #'+ res <- replicate(nsim, {
|
||
| 39 | -+ | |||
| 215 | +1150x |
- #' @keywords internal+ z <- stats::rnorm(n = n_theta) |
||
| 40 | -+ | |||
| 216 | +1150x |
- h_quad_form_vec <- function(vec, center) {
+ theta_sample <- object$theta_est + z %*% theta_chol |
||
| 41 | -5607x | +217 | +1150x |
- vec <- as.vector(vec)+ cond_beta_results <- object$tmb_object$report(theta_sample) |
| 42 | -5607x | +218 | +1150x |
- assert_numeric(vec, any.missing = FALSE)+ beta_mean <- cond_beta_results$beta |
| 43 | -5607x | +219 | +1150x |
- assert_matrix(+ beta_cov <- cond_beta_results$beta_vcov |
| 44 | -5607x | +220 | +1150x |
- center,+ h_get_prediction(tmb_data, theta_sample, beta_mean, beta_cov)$prediction |
| 45 | -5607x | +|||
| 221 | +
- mode = "numeric",+ }) |
|||
| 46 | -5607x | +222 | +7x |
- any.missing = FALSE,+ mean_of_var <- rowMeans(res[, "var", ]) |
| 47 | -5607x | +223 | +7x |
- nrows = length(vec),+ var_of_mean <- apply(res[, "fit", ], 1, stats::var) |
| 48 | -5607x | +224 | +7x |
- ncols = length(vec)+ mean_of_var + var_of_mean |
| 49 | +225 |
- )+ } |
||
| 50 | +226 | |||
| 51 | -5607x | +|||
| 227 | +
- sum(vec * (center %*% vec))+ #' @describeIn mmrm_tmb_methods obtains the model frame. |
|||
| 52 | +228 |
- }+ #' @param data (`data.frame`)\cr object in which to construct the frame. |
||
| 53 | +229 |
-
+ #' @param include (`character`)\cr names of variable types to include. |
||
| 54 | +230 |
- #' @describeIn h_quad_form calculates the quadratic form `mat %*% center %*% t(mat)`+ #' Must be `NULL` or one or more of `c("subject_var", "visit_var", "group_var", "response_var")`.
|
||
| 55 | +231 |
- #' as a matrix, the result is square and has dimensions identical to the number+ #' @param full (`flag`)\cr indicator whether to return full model frame (deprecated). |
||
| 56 | +232 |
- #' of rows in `mat`.+ #' @param na.action (`string`)\cr na action. |
||
| 57 | +233 |
- #'+ #' @importFrom stats model.frame |
||
| 58 | +234 |
- #' @param mat (`matrix`)\cr numeric matrix to be multiplied left and right of+ #' @exportS3Method |
||
| 59 | +235 |
- #' `center`, therefore needs to have as many columns as there are rows and columns+ #' |
||
| 60 | +236 |
- #' in `center`.+ #' @details |
||
| 61 | +237 |
- #'+ #' `include` argument controls the variables the returned model frame will include. |
||
| 62 | +238 |
- #' @keywords internal+ #' Possible options are "response_var", "subject_var", "visit_var" and "group_var", representing the |
||
| 63 | +239 |
- h_quad_form_mat <- function(mat, center) {
+ #' response variable, subject variable, visit variable or group variable. |
||
| 64 | -119x | +|||
| 240 | +
- assert_matrix(mat, mode = "numeric", any.missing = FALSE, min.cols = 1L)+ #' `character` values in new data will always be factorized according to the data in the fit |
|||
| 65 | -119x | +|||
| 241 | +
- assert_matrix(+ #' to avoid mismatched in levels or issues in `model.matrix`. |
|||
| 66 | -119x | +|||
| 242 | +
- center,+ #' |
|||
| 67 | -119x | +|||
| 243 | +
- mode = "numeric",+ #' @examples |
|||
| 68 | -119x | +|||
| 244 | +
- any.missing = FALSE,+ #' # Model frame: |
|||
| 69 | -119x | +|||
| 245 | +
- nrows = ncol(center),+ #' model.frame(object) |
|||
| 70 | -119x | +|||
| 246 | +
- ncols = ncol(center)+ #' model.frame(object, include = "subject_var") |
|||
| 71 | +247 |
- )+ model.frame.mmrm_tmb <- function(formula, data, include = c("subject_var", "visit_var", "group_var", "response_var"),
|
||
| 72 | -119x | +|||
| 248 | +
- mat %*% tcrossprod(center, mat)+ full, na.action = "na.omit", ...) { # nolint
|
|||
| 73 | +249 |
- }+ # Construct updated formula and data arguments. |
||
| 74 | -+ | |||
| 250 | +46x |
-
+ lst_formula_and_data <- |
||
| 75 | -+ | |||
| 251 | +46x |
- #' Computation of a Gradient Given Jacobian and Contrast Vector+ h_construct_model_frame_inputs( |
||
| 76 | -+ | |||
| 252 | +46x |
- #'+ formula = formula, |
||
| 77 | -+ | |||
| 253 | +46x | +
+ data = data,+ |
+ ||
| 254 | +46x | +
+ include = include,+ |
+ ||
| 255 | +46x |
- #' @description Computes the gradient of a linear combination of `beta` given the Jacobian matrix and+ full = full |
||
| 78 | +256 |
- #' variance parameters.+ ) |
||
| 79 | +257 |
- #'+ # Only if include is default (full) and also data is missing, and also na.action is na.omit we will |
||
| 80 | +258 |
- #' @param jac_list (`list`)\cr Jacobian list produced e.g. by [h_jac_list()].+ # use the model frame from the tmb_data. |
||
| 81 | -+ | |||
| 259 | +46x |
- #' @param contrast (`numeric`)\cr contrast vector, which needs to have the+ include_choice <- c("subject_var", "visit_var", "group_var", "response_var")
|
||
| 82 | -+ | |||
| 260 | +46x |
- #' same number of elements as there are rows and columns in each element of+ if (missing(data) && setequal(include, include_choice) && identical(h_get_na_action(na.action), stats::na.omit)) {
|
||
| 83 | -+ | |||
| 261 | +2x |
- #' `jac_list`.+ ret <- formula$tmb_data$full_frame |
||
| 84 | +262 |
- #'+ # Remove weights column. |
||
| 85 | -+ | |||
| 263 | +2x |
- #' @return Numeric vector which contains the quadratic forms of each element of+ ret[, "(weights)"] <- NULL |
||
| 86 | -+ | |||
| 264 | +2x |
- #' `jac_list` with the `contrast` vector.+ ret |
||
| 87 | +265 |
- #'+ } else {
|
||
| 88 | +266 |
- #' @keywords internal+ # Construct data frame to return to users. |
||
| 89 | -+ | |||
| 267 | +44x |
- h_gradient <- function(jac_list, contrast) {
+ ret <- |
||
| 90 | -491x | +268 | +44x |
- assert_list(jac_list)+ stats::model.frame( |
| 91 | -491x | +269 | +44x |
- assert_numeric(contrast)+ formula = lst_formula_and_data$formula, |
| 92 | -+ | |||
| 270 | +44x |
-
+ data = h_get_na_action(na.action)(lst_formula_and_data$data), |
||
| 93 | -491x | +271 | +44x |
- vapply(+ na.action = na.action, |
| 94 | -491x | +272 | +44x |
- jac_list,+ xlev = stats::.getXlevels(terms(formula), formula$tmb_data$full_frame) |
| 95 | -491x | +|||
| 273 | +
- h_quad_form_vec,+ ) |
|||
| 96 | -491x | +|||
| 274 | +
- vec = contrast,+ } |
|||
| 97 | -491x | +275 | +45x |
- numeric(1L)+ ret |
| 98 | +276 |
- )+ } |
||
| 99 | +277 |
- }+ |
||
| 100 | +278 | |||
| 101 | +279 |
- #' Calculation of Satterthwaite Degrees of Freedom for One-Dimensional Contrast+ #' Construction of Model Frame Formula and Data Inputs |
||
| 102 | +280 |
#' |
||
| 103 | +281 |
- #' @description Used in [df_1d()] if method is+ #' @description |
||
| 104 | +282 |
- #' "Satterthwaite".+ #' Input formulas are converted from mmrm-style to a style compatible |
||
| 105 | +283 |
- #'+ #' with default [stats::model.frame()] and [stats::model.matrix()] methods. |
||
| 106 | +284 |
- #' @param object (`mmrm`)\cr the MMRM fit.+ #' |
||
| 107 | +285 |
- #' @param contrast (`numeric`)\cr contrast vector. Note that this should not include+ #' The full formula is returned so we can construct, for example, the |
||
| 108 | +286 |
- #' elements for singular coefficient estimates, i.e. only refer to the+ #' `model.frame()` including all columns as well as the requested subset. |
||
| 109 | +287 |
- #' actually estimated coefficients.+ #' The full set is used to identify rows to include in the reduced model frame. |
||
| 110 | +288 |
#' |
||
| 111 | +289 |
- #' @return List with `est`, `se`, `df`, `t_stat` and `p_val`.+ #' @param formula (`mmrm`)\cr mmrm fit object. |
||
| 112 | +290 |
- #' @keywords internal+ #' @param data optional data frame that will be |
||
| 113 | +291 |
- h_df_1d_sat <- function(object, contrast) {
- |
- ||
| 114 | -456x | -
- assert_class(object, "mmrm")- |
- ||
| 115 | -456x | -
- contrast <- as.numeric(contrast)- |
- ||
| 116 | -456x | -
- assert_numeric(contrast, len = length(component(object, "beta_est")))+ #' passed to `model.frame()` or `model.matrix()` |
||
| 117 | +292 | - - | -||
| 118 | -456x | -
- df <- if (identical(object$vcov, "Asymptotic")) {
- |
- ||
| 119 | -444x | -
- grad <- h_gradient(component(object, "jac_list"), contrast)- |
- ||
| 120 | -444x | -
- 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"))+ #' @param include (`character`)\cr names of variable to include |
||
| 122 | -444x | +|||
| 293 | +
- v_num / v_denom+ #' @param full (`flag`)\cr indicator whether to return full model frame (deprecated). |
|||
| 123 | -456x | +|||
| 294 | +
- } else if (object$vcov %in% c("Empirical", "Empirical-Jackknife", "Empirical-Bias-Reduced")) {
+ #' |
|||
| 124 | -12x | +|||
| 295 | +
- contrast_matrix <- Matrix::.bdiag(rep(list(matrix(contrast, nrow = 1)), component(object, "n_subjects")))+ #' @return named list with four elements: |
|||
| 125 | -12x | +|||
| 296 | +
- contrast_matrix <- as.matrix(contrast_matrix)+ #' - `"formula"`: the formula including the columns requested in the `include=` argument. |
|||
| 126 | -12x | +|||
| 297 | +
- g_matrix <- h_quad_form_mat(contrast_matrix, object$empirical_df_mat)+ #' - `"data"`: a data frame including all columns needed in the formula. |
|||
| 127 | -12x | +|||
| 298 | +
- h_tr(g_matrix)^2 / sum(g_matrix^2)+ #' full formula are identical |
|||
| 128 | +299 |
- }+ #' @keywords internal |
||
| 129 | +300 |
-
+ h_construct_model_frame_inputs <- function(formula, |
||
| 130 | -456x | +|||
| 301 | +
- h_test_1d(object, contrast, df)+ data, |
|||
| 131 | +302 |
- }+ include, |
||
| 132 | +303 |
-
+ include_choice = c("subject_var", "visit_var", "group_var", "response_var"),
|
||
| 133 | +304 |
- #' Calculating Denominator Degrees of Freedom for the Multi-Dimensional Case+ full) {
|
||
| 134 | -+ | |||
| 305 | +280x |
- #'+ if (!missing(full) && identical(full, TRUE)) {
|
||
| 135 | -+ | |||
| 306 | +! |
- #' @description Calculates the degrees of freedom for multi-dimensional contrast.+ lifecycle::deprecate_warn("0.3", "model.frame.mmrm_tmb(full)")
|
||
| 136 | -+ | |||
| 307 | +! |
- #'+ include <- include_choice |
||
| 137 | +308 |
- #' @param t_stat_df (`numeric`)\cr `n` t-statistic derived degrees of freedom.+ } |
||
| 138 | +309 |
- #'+ |
||
| 139 | -+ | |||
| 310 | +280x |
- #' @return Usually the calculation is returning `2 * E / (E - n)` where+ assert_class(formula, classes = "mmrm_tmb") |
||
| 140 | -+ | |||
| 311 | +280x |
- #' `E` is the sum of `t / (t - 2)` over all `t_stat_df` values `t`.+ assert_subset(include, include_choice) |
||
| 141 | -+ | |||
| 312 | +280x |
- #'+ if (missing(data)) {
|
||
| 142 | -+ | |||
| 313 | +256x |
- #' @note If the input values are two similar to each other then just the average+ data <- formula$data |
||
| 143 | +314 |
- #' of them is returned. If any of the inputs is not larger than 2 then 2 is+ } |
||
| 144 | -+ | |||
| 315 | +280x |
- #' returned.+ assert_data_frame(data) |
||
| 145 | +316 |
- #'+ |
||
| 146 | -+ | |||
| 317 | +280x |
- #' @keywords internal+ drop_response <- !"response_var" %in% include |
||
| 147 | -+ | |||
| 318 | +280x |
- h_md_denom_df <- function(t_stat_df) {
+ add_vars <- unlist(formula$formula_parts[include]) |
||
| 148 | -24x | +319 | +280x |
- assert_numeric(t_stat_df, min.len = 1L, lower = .Machine$double.xmin, any.missing = FALSE)+ new_formula <- h_add_terms(formula$formula_parts$model_formula, add_vars, drop_response) |
| 149 | +320 | |||
| 150 | -24x | +321 | +280x |
- if (test_scalar(t_stat_df)) {
+ drop_response_full <- !"response_var" %in% include_choice |
| 151 | -1x | +322 | +280x |
- t_stat_df+ add_vars_full <- unlist(formula$formula_parts[include_choice]) |
| 152 | -23x | +323 | +280x |
- } else if (all(abs(diff(t_stat_df)) < sqrt(.Machine$double.eps))) {
+ new_formula_full <- |
| 153 | -1x | +324 | +280x |
- mean(t_stat_df)+ h_add_terms(formula$formula_parts$model_formula, add_vars_full, drop_response_full) |
| 154 | -22x | +|||
| 325 | +
- } else if (any(t_stat_df <= 2)) {
+
|
|||
| 155 | -2x | +|||
| 326 | +
- 2+ # Update data based on the columns in the full formula return. |
|||
| 156 | -+ | |||
| 327 | +280x |
- } else {
+ all_vars <- all.vars(new_formula_full) |
||
| 157 | -20x | +328 | +280x |
- e <- sum(t_stat_df / (t_stat_df - 2))+ assert_names(colnames(data), must.include = all_vars) |
| 158 | -20x | +329 | +280x |
- 2 * e / (e - (length(t_stat_df)))+ data <- data[, all_vars, drop = FALSE] |
| 159 | +330 |
- }+ |
||
| 160 | +331 |
- }+ # Return list with updated formula, data. |
||
| 161 | -+ | |||
| 332 | +280x |
-
+ list(+ |
+ ||
| 333 | +280x | +
+ formula = new_formula,+ |
+ ||
| 334 | +280x | +
+ data = data |
||
| 162 | +335 |
- #' Creating F-Statistic Results from One-Dimensional Contrast+ ) |
||
| 163 | +336 |
- #'+ } |
||
| 164 | +337 |
- #' @description Creates multi-dimensional result from one-dimensional contrast from [df_1d()].+ |
||
| 165 | +338 |
- #'+ #' @describeIn mmrm_tmb_methods obtains the model matrix. |
||
| 166 | +339 |
- #' @param object (`mmrm`)\cr model fit.+ #' @exportS3Method |
||
| 167 | +340 |
- #' @param contrast (`numeric`)\cr one-dimensional contrast.+ #' @param use_response (`flag`)\cr whether to use the response for complete rows. |
||
| 168 | +341 |
#' |
||
| 169 | +342 |
- #' @return The one-dimensional degrees of freedom are calculated and then+ #' @examples |
||
| 170 | +343 |
- #' based on that the p-value is calculated.+ #' # Model matrix: |
||
| 171 | +344 |
- #'+ #' model.matrix(object) |
||
| 172 | +345 |
- #' @keywords internal+ model.matrix.mmrm_tmb <- function(object, data, use_response = TRUE, ...) { # nolint
|
||
| 173 | +346 |
- h_df_md_from_1d <- function(object, contrast) {
+ # Always return the utilized model matrix if data not provided. |
||
| 174 | -134x | +347 | +37x |
- res_1d <- h_df_1d_sat(object, contrast)+ if (missing(data)) {
|
| 175 | -134x | +348 | +3x |
- list(+ return(object$tmb_data$x_matrix) |
| 176 | -134x | +|||
| 349 | +
- num_df = 1,+ } |
|||
| 177 | -134x | +350 | +34x |
- denom_df = res_1d$df,+ stats::model.matrix( |
| 178 | -134x | +351 | +34x |
- f_stat = res_1d$t_stat^2,+ h_add_terms(object$formula_parts$model_formula, NULL, drop_response = !use_response), |
| 179 | -134x | +352 | +34x |
- p_val = stats::pf(q = res_1d$t_stat^2, df1 = 1, df2 = res_1d$df, lower.tail = FALSE)+ data = data, |
| 180 | -+ | |||
| 353 | +34x |
- )+ contrasts.arg = attr(object$tmb_data$x_matrix, "contrasts"), |
||
| 181 | -+ | |||
| 354 | +34x |
- }+ xlev = component(object, "xlev"), |
||
| 182 | +355 |
-
+ ... |
||
| 183 | +356 |
- #' Calculation of Satterthwaite Degrees of Freedom for Multi-Dimensional Contrast+ ) |
||
| 184 | +357 |
- #'+ } |
||
| 185 | +358 |
- #' @description Used in [df_md()] if method is "Satterthwaite".+ |
||
| 186 | +359 |
- #'+ #' @describeIn mmrm_tmb_methods obtains the terms object. |
||
| 187 | +360 |
- #' @param object (`mmrm`)\cr the MMRM fit.+ #' @importFrom stats model.frame |
||
| 188 | +361 |
- #' @param contrast (`matrix`)\cr numeric contrast matrix, if given a `numeric`+ #' @exportS3Method |
||
| 189 | +362 |
- #' then this is coerced to a row vector. Note that this should not include+ #' |
||
| 190 | +363 |
- #' elements for singular coefficient estimates, i.e. only refer to the+ #' @examples |
||
| 191 | +364 |
- #' actually estimated coefficients.+ #' # terms: |
||
| 192 | +365 |
- #'+ #' terms(object) |
||
| 193 | +366 |
- #' @return List with `num_df`, `denom_df`, `f_stat` and `p_val` (2-sided p-value).+ #' terms(object, include = "subject_var") |
||
| 194 | +367 |
- #' @keywords internal+ terms.mmrm_tmb <- function(x, include = "response_var", ...) { # nolint
|
||
| 195 | +368 |
- h_df_md_sat <- function(object, contrast) {
+ # Construct updated formula and data arguments. |
||
| 196 | -151x | +369 | +231x |
- assert_class(object, "mmrm")+ lst_formula_and_data <- |
| 197 | -151x | +370 | +231x |
- assert_matrix(contrast, mode = "numeric", any.missing = FALSE, ncols = length(component(object, "beta_est")))+ h_construct_model_frame_inputs( |
| 198 | -+ | |||
| 371 | +231x |
- # Early return if we are in the one-dimensional case.+ formula = x, |
||
| 199 | -151x | +372 | +231x |
- if (identical(nrow(contrast), 1L)) {
+ include = include |
| 200 | -132x | +|||
| 373 | +
- return(h_df_md_from_1d(object, contrast))+ ) |
|||
| 201 | +374 |
- }+ |
||
| 202 | +375 |
-
+ # Use formula method for `terms()` to construct the mmrm terms object. |
||
| 203 | -19x | +376 | +231x |
- contrast_cov <- h_quad_form_mat(contrast, component(object, "beta_vcov"))+ stats::terms( |
| 204 | -19x | +377 | +231x |
- eigen_cont_cov <- eigen(contrast_cov)+ x = lst_formula_and_data$formula, |
| 205 | -19x | +378 | +231x |
- eigen_cont_cov_vctrs <- eigen_cont_cov$vectors+ data = lst_formula_and_data$data |
| 206 | -19x | +|||
| 379 | +
- eigen_cont_cov_vals <- eigen_cont_cov$values+ ) |
|||
| 207 | +380 |
-
+ } |
||
| 208 | -19x | +|||
| 381 | +
- eps <- sqrt(.Machine$double.eps)+ |
|||
| 209 | -19x | +|||
| 382 | +
- tol <- max(eps * eigen_cont_cov_vals[1], 0)+ |
|||
| 210 | -19x | +|||
| 383 | +
- rank_cont_cov <- sum(eigen_cont_cov_vals > tol)+ #' @describeIn mmrm_tmb_methods obtains the attained log likelihood value. |
|||
| 211 | -19x | +|||
| 384 | +
- assert_number(rank_cont_cov, lower = .Machine$double.xmin)+ #' @importFrom stats logLik |
|||
| 212 | -19x | +|||
| 385 | +
- rank_seq <- seq_len(rank_cont_cov)+ #' @exportS3Method |
|||
| 213 | -19x | +|||
| 386 | +
- vctrs_cont_prod <- crossprod(eigen_cont_cov_vctrs, contrast)[rank_seq, , drop = FALSE]+ #' @examples |
|||
| 214 | +387 |
-
+ #' # Log likelihood given the estimated parameters: |
||
| 215 | +388 |
- # Early return if rank 1.+ #' logLik(object) |
||
| 216 | -19x | +|||
| 389 | +
- if (identical(rank_cont_cov, 1L)) {
+ logLik.mmrm_tmb <- function(object, ...) {
|
|||
| 217 | -1x | +390 | +50x |
- return(h_df_md_from_1d(object, vctrs_cont_prod))+ -component(object, "neg_log_lik") |
| 218 | +391 |
- }+ } |
||
| 219 | +392 | |||
| 220 | -18x | +|||
| 393 | +
- t_squared_nums <- drop(vctrs_cont_prod %*% object$beta_est)^2+ #' @describeIn mmrm_tmb_methods obtains the used formula. |
|||
| 221 | -18x | +|||
| 394 | +
- t_squared_denoms <- eigen_cont_cov_vals[rank_seq]+ #' @importFrom stats formula |
|||
| 222 | -18x | +|||
| 395 | +
- t_squared <- t_squared_nums / t_squared_denoms+ #' @exportS3Method |
|||
| 223 | -18x | +|||
| 396 | +
- f_stat <- sum(t_squared) / rank_cont_cov+ #' @examples |
|||
| 224 | -18x | +|||
| 397 | +
- t_stat_df_nums <- 2 * eigen_cont_cov_vals^2+ #' # Formula which was used: |
|||
| 225 | -18x | +|||
| 398 | +
- t_stat_df <- if (identical(object$vcov, "Asymptotic")) {
+ #' formula(object) |
|||
| 226 | -18x | +|||
| 399 | +
- grads_vctrs_cont_prod <- lapply(+ formula.mmrm_tmb <- function(x, ...) {
|
|||
| 227 | -18x | +400 | +5x |
- rank_seq,+ x$formula_parts$formula |
| 228 | -18x | +|||
| 401 | +
- function(m) h_gradient(component(object, "jac_list"), contrast = vctrs_cont_prod[m, ])+ } |
|||
| 229 | +402 |
- )+ |
||
| 230 | -18x | +|||
| 403 | +
- t_stat_df_denoms <- vapply(+ #' @describeIn mmrm_tmb_methods obtains the variance-covariance matrix estimate |
|||
| 231 | -18x | +|||
| 404 | +
- grads_vctrs_cont_prod,+ #' for the coefficients. |
|||
| 232 | -18x | +|||
| 405 | +
- h_quad_form_vec,+ #' @importFrom stats vcov |
|||
| 233 | -18x | +|||
| 406 | +
- center = component(object, "theta_vcov"),+ #' @exportS3Method |
|||
| 234 | -18x | +|||
| 407 | +
- numeric(1)+ #' @examples |
|||
| 235 | +408 |
- )+ #' # Variance-covariance matrix estimate for coefficients: |
||
| 236 | -18x | +|||
| 409 | +
- t_stat_df_nums / t_stat_df_denoms+ #' vcov(object) |
|||
| 237 | +410 |
- } else {
+ vcov.mmrm_tmb <- function(object, complete = TRUE, ...) {
|
||
| 238 | -! | +|||
| 411 | +3x |
- vapply(+ assert_flag(complete) |
||
| 239 | -! | +|||
| 412 | +3x |
- rank_seq,+ nm <- if (complete) "beta_vcov_complete" else "beta_vcov" |
||
| 240 | -! | +|||
| 413 | +3x |
- function(m) {
+ component(object, name = nm) |
||
| 241 | -! | +|||
| 414 | +
- contrast_matrix <- Matrix::.bdiag(+ } |
|||
| 242 | -! | +|||
| 415 | +
- rep(list(vctrs_cont_prod[m, , drop = FALSE]), component(object, "n_subjects"))+ |
|||
| 243 | +416 |
- )+ #' @describeIn mmrm_tmb_methods obtains the variance-covariance matrix estimate |
||
| 244 | -! | +|||
| 417 | +
- contrast_matrix <- as.matrix(contrast_matrix)+ #' for the residuals. |
|||
| 245 | -! | +|||
| 418 | +
- g_matrix <- h_quad_form_mat(contrast_matrix, object$empirical_df_mat)+ #' @param sigma cannot be used (this parameter does not exist in MMRM). |
|||
| 246 | -! | +|||
| 419 | +
- h_tr(g_matrix)^2 / sum(g_matrix^2)+ #' @importFrom nlme VarCorr |
|||
| 247 | +420 |
- },+ #' @export VarCorr |
||
| 248 | -! | +|||
| 421 | +
- FUN.VALUE = 0+ #' @aliases VarCorr |
|||
| 249 | +422 |
- )+ #' @exportS3Method |
||
| 250 | +423 |
- }+ #' @examples |
||
| 251 | -18x | +|||
| 424 | +
- denom_df <- h_md_denom_df(t_stat_df)+ #' # Variance-covariance matrix estimate for residuals: |
|||
| 252 | +425 |
-
+ #' VarCorr(object) |
||
| 253 | -18x | +|||
| 426 | +
- list(+ VarCorr.mmrm_tmb <- function(x, sigma = NA, ...) { # nolint
|
|||
| 254 | -18x | +427 | +10x |
- num_df = rank_cont_cov,+ assert_scalar_na(sigma) |
| 255 | -18x | +|||
| 428 | +
- denom_df = denom_df,+ |
|||
| 256 | -18x | +429 | +10x |
- f_stat = f_stat,+ component(x, name = "varcor") |
| 257 | -18x | +|||
| 430 | +
- p_val = stats::pf(q = f_stat, df1 = rank_cont_cov, df2 = denom_df, lower.tail = FALSE)+ } |
|||
| 258 | +431 |
- )+ |
||
| 259 | +432 |
- }+ #' @describeIn mmrm_tmb_methods obtains the deviance, which is defined here |
| 1 | +433 |
- #' Component Access for `mmrm_tmb` Objects+ #' as twice the negative log likelihood, which can either be integrated |
||
| 2 | +434 |
- #'+ #' over the coefficients for REML fits or the usual one for ML fits. |
||
| 3 | +435 |
- #' @description `r lifecycle::badge("stable")`
+ #' @importFrom stats deviance |
||
| 4 | +436 |
- #'+ #' @exportS3Method |
||
| 5 | +437 |
- #' @param object (`mmrm_tmb`)\cr the fitted MMRM.+ #' @examples |
||
| 6 | +438 |
- #' @param name (`character`)\cr the component(s) to be retrieved.+ #' # REML criterion (twice the negative log likelihood): |
||
| 7 | +439 |
- #' @return The corresponding component of the object, see details.+ #' deviance(object) |
||
| 8 | +440 |
- #'+ deviance.mmrm_tmb <- function(object, ...) {
|
||
| 9 | -+ | |||
| 441 | +74x |
- #' @details Available `component()` names are as follows:+ 2 * component(object, "neg_log_lik") |
||
| 10 | +442 |
- #' - `call`: low-level function call which generated the model.+ } |
||
| 11 | +443 |
- #' - `formula`: model formula.+ |
||
| 12 | +444 |
- #' - `dataset`: data set name.+ #' @describeIn mmrm_tmb_methods obtains the Akaike Information Criterion, |
||
| 13 | +445 |
- #' - `cov_type`: covariance structure type.+ #' where the degrees of freedom are the number of variance parameters (`n_theta`). |
||
| 14 | +446 |
- #' - `n_theta`: number of parameters.+ #' If `corrected`, then this is multiplied with `m / (m - n_theta - 1)` where |
||
| 15 | +447 |
- #' - `n_subjects`: number of subjects.+ #' `m` is the number of observations minus the number of coefficients, or |
||
| 16 | +448 |
- #' - `n_timepoints`: number of modeled time points.+ #' `n_theta + 2` if it is smaller than that \insertCite{hurvich1989regression,burnham1998practical}{mmrm}.
|
||
| 17 | +449 |
- #' - `n_obs`: total number of observations.+ #' @param corrected (`flag`)\cr whether corrected AIC should be calculated. |
||
| 18 | +450 |
- #' - `reml`: was REML used (ML was used if `FALSE`).+ #' @param k (`number`)\cr the penalty per parameter to be used; default `k = 2` |
||
| 19 | +451 |
- #' - `neg_log_lik`: negative log likelihood.+ #' is the classical AIC. |
||
| 20 | +452 |
- #' - `convergence`: convergence code from optimizer.+ #' @importFrom stats AIC |
||
| 21 | +453 |
- #' - `conv_message`: message accompanying the convergence code.+ #' @exportS3Method |
||
| 22 | +454 |
- #' - `evaluations`: number of function evaluations for optimization.+ #' @examples |
||
| 23 | +455 |
- #' - `method`: Adjustment method which was used (for `mmrm` objects),+ #' # AIC: |
||
| 24 | +456 |
- #' otherwise `NULL` (for `mmrm_tmb` objects).+ #' AIC(object) |
||
| 25 | +457 |
- #' - `beta_vcov`: estimated variance-covariance matrix of coefficients+ #' AIC(object, corrected = TRUE) |
||
| 26 | +458 |
- #' (excluding aliased coefficients). When Kenward-Roger/Empirical adjusted+ #' @references |
||
| 27 | +459 |
- #' coefficients covariance matrix is used, the adjusted covariance matrix is returned (to still obtain the+ #' - \insertRef{hurvich1989regression}{mmrm}
|
||
| 28 | +460 |
- #' original asymptotic covariance matrix use `object$beta_vcov`).+ #' - \insertRef{burnham1998practical}{mmrm}
|
||
| 29 | +461 |
- #' - `beta_vcov_complete`: estimated variance-covariance matrix including+ AIC.mmrm_tmb <- function(object, corrected = FALSE, ..., k = 2) {
|
||
| 30 | +462 |
- #' aliased coefficients with entries set to `NA`.+ # nolint |
||
| 31 | -+ | |||
| 463 | +44x |
- #' - `varcor`: estimated covariance matrix for residuals. If there are multiple+ assert_flag(corrected) |
||
| 32 | -+ | |||
| 464 | +44x |
- #' groups, a named list of estimated covariance matrices for residuals will be+ assert_number(k, lower = 1) |
||
| 33 | +465 |
- #' returned. The names are the group levels.+ |
||
| 34 | -+ | |||
| 466 | +44x |
- #' - `theta_est`: estimated variance parameters.+ n_theta <- length(component(object, "theta_est")) |
||
| 35 | -+ | |||
| 467 | +44x |
- #' - `beta_est`: estimated coefficients (excluding aliased coefficients).+ df <- if (!corrected) {
|
||
| 36 | -+ | |||
| 468 | +43x |
- #' - `beta_est_complete`: estimated coefficients including aliased coefficients+ n_theta |
||
| 37 | +469 |
- #' set to `NA`.+ } else {
|
||
| 38 | -+ | |||
| 470 | +1x |
- #' - `beta_aliased`: whether each coefficient was aliased (i.e. cannot be estimated)+ n_obs <- length(component(object, "y_vector")) |
||
| 39 | -+ | |||
| 471 | +1x |
- #' or not.+ n_beta <- length(component(object, "beta_est")) |
||
| 40 | -+ | |||
| 472 | +1x |
- #' - `theta_vcov`: estimated variance-covariance matrix of variance parameters.+ m <- max(n_theta + 2, n_obs - n_beta)+ |
+ ||
| 473 | +1x | +
+ n_theta * (m / (m - n_theta - 1)) |
||
| 41 | +474 |
- #' - `x_matrix`: design matrix used (excluding aliased columns).+ } |
||
| 42 | +475 |
- #' - `xlev`: a named list of character vectors giving the full set of levels to be assumed for each factor.+ + |
+ ||
| 476 | +44x | +
+ 2 * component(object, "neg_log_lik") + k * df |
||
| 43 | +477 |
- #' - `contrasts`: a list of contrasts used for each factor.+ } |
||
| 44 | +478 |
- #' - `y_vector`: response vector used.+ |
||
| 45 | +479 |
- #' - `jac_list`: Jacobian, see [h_jac_list()] for details.+ #' @describeIn mmrm_tmb_methods obtains the Bayesian Information Criterion, |
||
| 46 | +480 |
- #' - `full_frame`: `data.frame` with `n` rows containing all variables needed in the model.+ #' which is using the natural logarithm of the number of subjects for the |
||
| 47 | +481 |
- #'+ #' penalty parameter `k`. |
||
| 48 | +482 |
- #' @seealso In the `lme4` package there is a similar function `getME()`.+ #' @importFrom stats BIC |
||
| 49 | +483 |
- #'+ #' @exportS3Method |
||
| 50 | +484 |
#' @examples |
||
| 51 | +485 |
- #' fit <- mmrm(+ #' # BIC: |
||
| 52 | +486 |
- #' formula = FEV1 ~ RACE + SEX + ARMCD * AVISIT + us(AVISIT | USUBJID),+ #' BIC(object) |
||
| 53 | +487 |
- #' data = fev_data+ BIC.mmrm_tmb <- function(object, ...) {
|
||
| 54 | +488 |
- #' )+ # nolint |
||
| 55 | -+ | |||
| 489 | +21x |
- #' # Get all available components.+ k <- log(component(object, "n_subjects")) |
||
| 56 | -+ | |||
| 490 | +21x |
- #' component(fit)+ AIC(object, corrected = FALSE, k = k) |
||
| 57 | +491 |
- #' # Get convergence code and message.+ } |
||
| 58 | +492 |
- #' component(fit, c("convergence", "conv_message"))
+
|
||
| 59 | +493 |
- #' # Get modeled formula as a string.+ |
||
| 60 | +494 |
- #' component(fit, c("formula"))
+ #' @describeIn mmrm_tmb_methods prints the object. |
||
| 61 | +495 |
- #'+ #' @exportS3Method |
||
| 62 | +496 |
- #' @export+ print.mmrm_tmb <- function(x, |
||
| 63 | +497 |
- component <- function(object,+ ...) {
|
||
| 64 | -+ | |||
| 498 | +2x |
- name = c(+ cat("mmrm fit\n\n")
|
||
| 65 | +499 |
- "cov_type", "subject_var", "n_theta", "n_subjects", "n_timepoints",+ |
||
| 66 | -+ | |||
| 500 | +2x |
- "n_obs", "beta_vcov", "beta_vcov_complete",+ h_print_call( |
||
| 67 | -+ | |||
| 501 | +2x |
- "varcor", "formula", "dataset", "n_groups",+ component(x, "call"), component(x, "n_obs"), |
||
| 68 | -+ | |||
| 502 | +2x |
- "reml", "convergence", "evaluations", "method", "optimizer",+ component(x, "n_subjects"), component(x, "n_timepoints") |
||
| 69 | +503 |
- "conv_message", "call", "theta_est",+ )+ |
+ ||
| 504 | +2x | +
+ h_print_cov(component(x, "cov_type"), component(x, "n_theta"), component(x, "n_groups")) |
||
| 70 | +505 |
- "beta_est", "beta_est_complete", "beta_aliased",+ + |
+ ||
| 506 | +2x | +
+ cat("Inference: ")
+ |
+ ||
| 507 | +2x | +
+ cat(ifelse(component(x, "reml"), "REML", "ML"))+ |
+ ||
| 508 | +2x | +
+ cat("\n")
+ |
+ ||
| 509 | +2x | +
+ cat("Deviance: ")
+ |
+ ||
| 510 | +2x | +
+ cat(deviance(x)) |
||
| 71 | +511 |
- "x_matrix", "y_vector", "neg_log_lik", "jac_list", "theta_vcov",+ + |
+ ||
| 512 | +2x | +
+ cat("\n\nCoefficients: ")
+ |
+ ||
| 513 | +2x | +
+ n_singular_coefs <- sum(component(x, "beta_aliased"))+ |
+ ||
| 514 | +2x | +
+ if (n_singular_coefs > 0) {
+ |
+ ||
| 515 | +1x | +
+ cat("(", n_singular_coefs, " not defined because of singularities)", sep = "")
|
||
| 72 | +516 |
- "full_frame", "xlev", "contrasts"+ }+ |
+ ||
| 517 | +2x | +
+ cat("\n")
+ |
+ ||
| 518 | +2x | +
+ print(coef(x, complete = TRUE)) |
||
| 73 | +519 |
- )) {
- |
- ||
| 74 | -5115x | -
- assert_class(object, "mmrm_tmb")+ |
||
| 75 | -5115x | +520 | +2x |
- name <- match.arg(name, several.ok = TRUE)+ cat("\nModel Inference Optimization:")
|
| 76 | +521 | |||
| 77 | -5115x | +522 | +2x |
- list_components <- sapply(+ cat(ifelse(component(x, "convergence") == 0, "\nConverged", "\nFailed to converge")) |
| 78 | -5115x | +523 | +2x |
- X = name,+ cat( |
| 79 | -5115x | +524 | +2x |
- FUN = switch,+ " with code", component(x, "convergence"), |
| 80 | -5115x | +525 | +2x |
- "call" = object$call,+ "and message:", |
| 81 | -+ | |||
| 526 | +2x |
- # Strings.+ if (is.null(component(x, "conv_message"))) "No message provided." else tolower(component(x, "conv_message")) |
||
| 82 | -5115x | +|||
| 527 | +
- "cov_type" = object$formula_parts$cov_type,+ ) |
|||
| 83 | -5115x | +528 | +2x |
- "subject_var" = object$formula_parts$subject_var,+ cat("\n")
|
| 84 | -5115x | +529 | +2x |
- "formula" = deparse(object$call$formula),+ invisible(x) |
| 85 | -5115x | +|||
| 530 | +
- "dataset" = object$call$data,+ } |
|||
| 86 | -5115x | +|||
| 531 | +
- "reml" = object$reml,+ |
|||
| 87 | -5115x | +|||
| 532 | +
- "conv_message" = object$opt_details$message,+ |
|||
| 88 | +533 |
- # Numeric of length 1.+ #' @describeIn mmrm_tmb_methods to obtain residuals - either unscaled ('response'), 'pearson' or 'normalized'.
|
||
| 89 | -5115x | +|||
| 534 | +
- "convergence" = object$opt_details$convergence,+ #' @param type (`string`)\cr unscaled (`response`), `pearson` or `normalized`. Default is `response`, |
|||
| 90 | -5115x | +|||
| 535 | +
- "neg_log_lik" = object$neg_log_lik,+ #' and this is the only type available for use with models with a spatial covariance structure. |
|||
| 91 | -5115x | +|||
| 536 | +
- "n_theta" = length(object$theta_est),+ #' @importFrom stats residuals |
|||
| 92 | -5115x | +|||
| 537 | +
- "n_subjects" = object$tmb_data$n_subjects,+ #' @exportS3Method |
|||
| 93 | -5115x | +|||
| 538 | +
- "n_timepoints" = object$tmb_data$n_visits,+ #' @examples |
|||
| 94 | -5115x | +|||
| 539 | +
- "n_obs" = length(object$tmb_data$y_vector),+ #' # residuals: |
|||
| 95 | -5115x | +|||
| 540 | +
- "n_groups" = ifelse(is.list(object$cov), length(object$cov), 1L),+ #' residuals(object, type = "response") |
|||
| 96 | +541 |
- # Numeric of length > 1.+ #' residuals(object, type = "pearson") |
||
| 97 | -5115x | +|||
| 542 | +
- "evaluations" = unlist(ifelse(is.null(object$opt_details$evaluations),+ #' residuals(object, type = "normalized") |
|||
| 98 | -5115x | +|||
| 543 | +
- list(object$opt_details$counts),+ #' @references |
|||
| 99 | -5115x | +|||
| 544 | +
- list(object$opt_details$evaluations)+ #' - \insertRef{galecki2013linear}{mmrm}
|
|||
| 100 | +545 |
- )),+ residuals.mmrm_tmb <- function(object, type = c("response", "pearson", "normalized"), ...) {
|
||
| 101 | -5115x | +546 | +20x |
- "method" = object$method,+ type <- match.arg(type) |
| 102 | -5115x | +547 | +20x |
- "optimizer" = object$optimizer,+ switch(type, |
| 103 | -5115x | +548 | +8x |
- "beta_est" = object$beta_est,+ "response" = h_residuals_response(object), |
| 104 | -5115x | +549 | +5x |
- "beta_est_complete" =+ "pearson" = h_residuals_pearson(object), |
| 105 | -5115x | +550 | +7x |
- if (any(object$tmb_data$x_cols_aliased)) {
+ "normalized" = h_residuals_normalized(object) |
| 106 | -8x | +|||
| 551 | +
- stats::setNames(+ ) |
|||
| 107 | -8x | +|||
| 552 | +
- object$beta_est[names(object$tmb_data$x_cols_aliased)],+ } |
|||
| 108 | -8x | +|||
| 553 | +
- names(object$tmb_data$x_cols_aliased)+ #' Calculate Pearson Residuals |
|||
| 109 | +554 |
- )+ #' |
||
| 110 | +555 |
- } else {
+ #' This is used by [residuals.mmrm_tmb()] to calculate Pearson residuals. |
||
| 111 | -54x | +|||
| 556 | +
- object$beta_est+ #' |
|||
| 112 | +557 |
- },+ #' @param object (`mmrm_tmb`)\cr the fitted MMRM. |
||
| 113 | -5115x | +|||
| 558 | +
- "beta_aliased" = object$tmb_data$x_cols_aliased,+ #' |
|||
| 114 | -5115x | +|||
| 559 | +
- "theta_est" = object$theta_est,+ #' @return Vector of residuals. |
|||
| 115 | -5115x | +|||
| 560 | +
- "y_vector" = object$tmb_data$y_vector,+ #' |
|||
| 116 | -5115x | +|||
| 561 | +
- "jac_list" = object$jac_list,+ #' @keywords internal |
|||
| 117 | +562 |
- # Matrices.+ h_residuals_pearson <- function(object) {
|
||
| 118 | -5115x | +563 | +6x |
- "beta_vcov" =+ assert_class(object, "mmrm_tmb") |
| 119 | -5115x | +564 | +6x |
- if (is.null(object$vcov) || identical(object$vcov, "Asymptotic")) {
+ h_residuals_response(object) * object$tmb_object$report()$diag_cov_inv_sqrt |
| 120 | -985x | +|||
| 565 | +
- object$beta_vcov+ } |
|||
| 121 | +566 |
- } else {
+
|
||
| 122 | -66x | +|||
| 567 | +
- object$beta_vcov_adj+ #' Calculate normalized residuals |
|||
| 123 | +568 |
- },+ #' |
||
| 124 | -5115x | +|||
| 569 | +
- "beta_vcov_complete" =+ #' This is used by [residuals.mmrm_tmb()] to calculate normalized / scaled residuals. |
|||
| 125 | -5115x | +|||
| 570 | +
- if (any(object$tmb_data$x_cols_aliased)) {
+ #' |
|||
| 126 | -2x | +|||
| 571 | +
- stats::.vcov.aliased(+ #' @param object (`mmrm_tmb`)\cr the fitted MMRM. |
|||
| 127 | -2x | +|||
| 572 | +
- aliased = object$tmb_data$x_cols_aliased,+ #' |
|||
| 128 | -2x | +|||
| 573 | +
- vc = component(object, "beta_vcov"),+ #' @return Vector of residuals |
|||
| 129 | -2x | +|||
| 574 | +
- complete = TRUE+ #' |
|||
| 130 | +575 |
- )+ #' @keywords internal |
||
| 131 | +576 |
- } else {
+ h_residuals_normalized <- function(object) {
|
||
| 132 | -4x | +577 | +8x |
- object$beta_vcov+ assert_class(object, "mmrm_tmb")+ |
+
| 578 | +8x | +
+ object$tmb_object$report()$epsilonTilde |
||
| 133 | +579 |
- },+ } |
||
| 134 | -5115x | +|||
| 580 | +
- "varcor" = object$cov,+ #' Calculate response residuals. |
|||
| 135 | -5115x | +|||
| 581 | +
- "x_matrix" = object$tmb_data$x_matrix,+ #' |
|||
| 136 | -5115x | +|||
| 582 | +
- "xlev" = stats::.getXlevels(terms(object), object$tmb_data$full_frame),+ #' This is used by [residuals.mmrm_tmb()] to calculate response residuals. |
|||
| 137 | -5115x | +|||
| 583 | +
- "contrasts" = attr(object$tmb_data$x_matrix, "contrasts"),+ #' |
|||
| 138 | -5115x | +|||
| 584 | +
- "theta_vcov" = object$theta_vcov,+ #' @param object (`mmrm_tmb`)\cr the fitted MMRM. |
|||
| 139 | -5115x | +|||
| 585 | +
- "full_frame" = object$tmb_data$full_frame,+ #' |
|||
| 140 | +586 |
- # If not found.+ #' @return Vector of residuals |
||
| 141 | -5115x | +|||
| 587 | +
- "..foo.." =+ #' |
|||
| 142 | -5115x | +|||
| 588 | +
- stop(sprintf(+ #' @keywords internal+ |
+ |||
| 589 | ++ |
+ h_residuals_response <- function(object) {
|
||
| 143 | -5115x | +590 | +15x |
- "component '%s' is not available",+ assert_class(object, "mmrm_tmb") |
| 144 | -5115x | +591 | +15x |
- name, paste0(class(object), collapse = ", ")+ component(object, "y_vector") - unname(fitted(object)) |
| 145 | +592 |
- )),+ } |
||
| 146 | -5115x | +|||
| 593 | ++ | + + | +||
| 594 | +
- simplify = FALSE+ #' @describeIn mmrm_tmb_methods simulate responses from a fitted model according |
|||
| 147 | +595 |
- )+ #' to the simulation `method`, returning a `data.frame` of dimension `[n, m]` |
||
| 148 | +596 |
-
+ #' where n is the number of rows in `newdata`, |
||
| 149 | -23x | +|||
| 597 | +
- if (length(name) == 1) list_components[[1]] else list_components+ #' and m is the number `nsim` of simulated responses. |
|||
| 150 | +598 |
- }+ #' |
| 1 | +599 |
- #' Determine Within or Between for each Design Matrix Column+ #' @param seed unused argument from [stats::simulate()]. |
||
| 2 | +600 |
- #'+ #' @param method (`string`)\cr simulation method to use. If "conditional", |
||
| 3 | +601 |
- #' @description Used in [h_df_bw_calc()] to determine whether a variable+ #' simulated values are sampled given the estimated covariance matrix of `object`. |
||
| 4 | +602 |
- #' differs only between subjects or also within subjects.+ #' If "marginal", the variance of the estimated covariance matrix is taken into account. |
||
| 5 | +603 |
#' |
||
| 6 | +604 |
- #' @param x_matrix (`matrix`)\cr the design matrix with column names.+ #' @importFrom stats simulate |
||
| 7 | +605 |
- #' @param subject_ids (`factor`)\cr the subject IDs.+ #' @exportS3Method |
||
| 8 | +606 |
- #'+ simulate.mmrm_tmb <- function(object, |
||
| 9 | +607 |
- #' @return Character vector with "intercept", "within" or "between" for each+ nsim = 1, |
||
| 10 | +608 |
- #' design matrix column identified via the names of the vector.+ seed = NULL, |
||
| 11 | +609 |
- #'+ newdata, |
||
| 12 | +610 |
- #' @keywords internal+ ..., |
||
| 13 | +611 |
- h_within_or_between <- function(x_matrix, subject_ids) {
+ method = c("conditional", "marginal")) {
|
||
| 14 | -19x | +612 | +15x |
- assert_matrix(x_matrix, col.names = "unique", min.cols = 1L)+ assert_count(nsim, positive = TRUE) |
| 15 | -19x | +613 | +15x |
- assert_factor(subject_ids, len = nrow(x_matrix))+ assert_null(seed)+ |
+
| 614 | +15x | +
+ if (missing(newdata)) {
+ |
+ ||
| 615 | +12x | +
+ newdata <- object$data |
||
| 16 | +616 |
-
+ } |
||
| 17 | -19x | +617 | +15x |
- n_subjects <- length(unique(subject_ids))+ assert_data_frame(newdata) |
| 18 | -19x | +618 | +15x |
- vapply(+ method <- match.arg(method) |
| 19 | -19x | +|||
| 619 | +
- colnames(x_matrix),+ |
|||
| 20 | -19x | +|||
| 620 | +
- function(x) {
+
|
|||
| 21 | -112x | +621 | +15x |
- if (x == "(Intercept)") {
+ tmb_data <- h_mmrm_tmb_data( |
| 22 | -19x | +622 | +15x |
- "intercept"+ object$formula_parts, newdata, |
| 23 | -+ | |||
| 623 | +15x |
- } else {
+ weights = rep(1, nrow(newdata)), |
||
| 24 | -93x | +624 | +15x |
- n_unique <- nrow(unique(cbind(x_matrix[, x], subject_ids)))+ reml = TRUE, |
| 25 | -43x | +625 | +15x |
- if (n_unique > n_subjects) "within" else "between"+ singular = "keep", |
| 26 | -+ | |||
| 626 | +15x |
- }+ drop_visit_levels = FALSE, |
||
| 27 | -+ | |||
| 627 | +15x |
- },+ allow_na_response = TRUE, |
||
| 28 | -19x | +628 | +15x |
- character(1L)+ drop_levels = FALSE, |
| 29 | -+ | |||
| 629 | +15x |
- )+ xlev = component(object, "xlev"), |
||
| 30 | -+ | |||
| 630 | +15x |
- }+ contrasts = component(object, "contrasts") |
||
| 31 | +631 |
-
+ ) |
||
| 32 | -+ | |||
| 632 | +15x |
- #' Calculation of Between-Within Degrees of Freedom+ ret <- if (method == "conditional") {
|
||
| 33 | -+ | |||
| 633 | +8x |
- #'+ predict_res <- h_get_prediction(tmb_data, object$theta_est, object$beta_est, object$beta_vcov) |
||
| 34 | -+ | |||
| 634 | +8x |
- #' @description Used in [h_df_1d_bw()] and [h_df_md_bw()].+ as.data.frame(h_get_sim_per_subj(predict_res, tmb_data$n_subjects, nsim)) |
||
| 35 | -+ | |||
| 635 | +15x |
- #'+ } else if (method == "marginal") {
|
||
| 36 | -+ | |||
| 636 | +7x |
- #' @param object (`mmrm`)\cr the fitted MMRM.+ theta_chol <- t(chol(object$theta_vcov)) |
||
| 37 | -+ | |||
| 637 | +7x |
- #'+ n_theta <- length(object$theta_est) |
||
| 38 | -+ | |||
| 638 | +7x |
- #' @return List with:+ as.data.frame( |
||
| 39 | -+ | |||
| 639 | +7x |
- #' - `coefs_between_within` calculated via [h_within_or_between()]+ sapply(seq_len(nsim), function(x) {
|
||
| 40 | -+ | |||
| 640 | +503x |
- #' - `ddf_between`+ newtheta <- object$theta_est + theta_chol %*% matrix(stats::rnorm(n_theta), ncol = 1) |
||
| 41 | +641 |
- #' - `ddf_within`+ # Recalculate betas with sampled thetas. |
||
| 42 | -+ | |||
| 642 | +503x |
- #'+ hold <- object$tmb_object$report(newtheta) |
||
| 43 | +643 |
- #' @keywords internal+ # Resample betas given new beta distribution. |
||
| 44 | +644 |
- h_df_bw_calc <- function(object) {
+ # We first solve L^\top w = D^{-1/2}z_{sample}:
|
||
| 45 | -18x | +645 | +503x |
- assert_class(object, "mmrm")+ w_sample <- backsolve( |
| 46 | -+ | |||
| 646 | +503x |
-
+ r = hold$XtWX_L, |
||
| 47 | -18x | +647 | +503x |
- n_subjects <- component(object, "n_subjects")+ x = stats::rnorm(length(hold$beta)) / sqrt(hold$XtWX_D), |
| 48 | -18x | +648 | +503x |
- n_obs <- component(object, "n_obs")+ upper.tri = FALSE, |
| 49 | -18x | +649 | +503x |
- x_mat <- component(object, "x_matrix")+ transpose = TRUE |
| 50 | +650 |
-
+ )+ |
+ ||
| 651 | ++ |
+ # Then we add the mean vector, the beta estimate. |
||
| 51 | -18x | +652 | +503x |
- subject_var <- component(object, "subject_var")+ beta_sample <- hold$beta + w_sample |
| 52 | -18x | +653 | +503x |
- full_frame <- component(object, "full_frame")+ predict_res <- h_get_prediction(tmb_data, newtheta, beta_sample, hold$beta_vcov) |
| 53 | -18x | +654 | +503x |
- subject_ids <- full_frame[[subject_var]]+ h_get_sim_per_subj(predict_res, tmb_data$n_subjects, 1L) |
| 54 | +655 |
-
+ }) |
||
| 55 | -18x | +|||
| 656 | +
- coefs_between_within <- h_within_or_between(x_mat, subject_ids)+ ) |
|||
| 56 | -18x | +|||
| 657 | +
- n_coefs_between <- sum(coefs_between_within == "between")+ } |
|||
| 57 | -18x | +658 | +15x |
- n_intercept <- sum(coefs_between_within == "intercept")+ orig_row_names <- row.names(newdata) |
| 58 | -18x | +659 | +15x |
- n_coefs_within <- sum(coefs_between_within == "within")+ new_order <- match(orig_row_names, row.names(tmb_data$full_frame)) |
| 59 | -18x | +660 | +15x |
- ddf_between <- n_subjects - n_coefs_between - n_intercept+ ret[new_order, , drop = FALSE] |
| 60 | -18x | +|||
| 661 | +
- ddf_within <- n_obs - n_subjects - n_coefs_within+ } |
|||
| 61 | +662 | |||
| 62 | -18x | +|||
| 663 | +
- list(+ #' Get simulated values by patient. |
|||
| 63 | -18x | +|||
| 664 | +
- coefs_between_within = coefs_between_within,+ #' |
|||
| 64 | -18x | +|||
| 665 | +
- ddf_between = ddf_between,+ #' @param predict_res (`list`)\cr from [h_get_prediction()]. |
|||
| 65 | -18x | +|||
| 666 | +
- ddf_within = ddf_within+ #' @param nsub (`count`)\cr number of subjects. |
|||
| 66 | +667 |
- )+ #' @param nsim (`count`)\cr number of values to simulate. |
||
| 67 | +668 |
- }+ #' |
||
| 68 | +669 |
-
+ #' @keywords internal |
||
| 69 | +670 |
- #' Assign Minimum Degrees of Freedom Given Involved Coefficients+ h_get_sim_per_subj <- function(predict_res, nsub, nsim) {
|
||
| 70 | -+ | |||
| 671 | +517x |
- #'+ assert_list(predict_res) |
||
| 71 | -+ | |||
| 672 | +517x |
- #' @description Used in [h_df_1d_bw()] and [h_df_md_bw()].+ assert_count(nsub, positive = TRUE)+ |
+ ||
| 673 | +516x | +
+ assert_count(nsim, positive = TRUE) |
||
| 72 | +674 |
- #'+ + |
+ ||
| 675 | +515x | +
+ ret <- matrix(+ |
+ ||
| 676 | +515x | +
+ predict_res$prediction[, "fit"],+ |
+ ||
| 677 | +515x | +
+ ncol = nsim,+ |
+ ||
| 678 | +515x | +
+ nrow = nrow(predict_res$prediction) |
||
| 73 | +679 |
- #' @param bw_calc (`list`)\cr from [h_df_bw_calc()].+ ) |
||
| 74 | -+ | |||
| 680 | +515x |
- #' @param is_coef_involved (`logical`)\cr whether each coefficient is involved+ for (i in seq_len(nsub)) {
|
||
| 75 | +681 |
- #' in the contrast.+ # Skip subjects which are not included in predict_res. |
||
| 76 | -+ | |||
| 682 | +82699x |
- #'+ if (length(predict_res$index[[i]]) > 0) {
|
||
| 77 | +683 |
- #' @return The minimum of the degrees of freedom assigned to each involved+ # Obtain indices of data.frame belonging to subject i |
||
| 78 | +684 |
- #' coefficient according to its between-within categorization.+ # (increment by 1, since indices from cpp are 0-order). |
||
| 79 | -+ | |||
| 685 | +66631x |
- #'+ inds <- predict_res$index[[i]] + 1 |
||
| 80 | -+ | |||
| 686 | +66631x |
- #' @keywords internal+ obs <- length(inds) |
||
| 81 | +687 |
- h_df_min_bw <- function(bw_calc, is_coef_involved) {
+
|
||
| 82 | -17x | +|||
| 688 | +
- assert_list(bw_calc)+ # Get relevant covariance matrix for subject i. |
|||
| 83 | -17x | +689 | +66631x |
- assert_names(names(bw_calc), identical.to = c("coefs_between_within", "ddf_between", "ddf_within"))
+ covmat_i <- predict_res$covariance[[i]] |
| 84 | -17x | +690 | +66631x |
- assert_logical(is_coef_involved, len = length(bw_calc$coefs_between_within))+ theta_chol <- t(chol(covmat_i)) |
| 85 | -17x | +|||
| 691 | +
- assert_true(sum(is_coef_involved) > 0)+ |
|||
| 86 | +692 |
-
+ # Simulate epsilon from covariance matrix. |
||
| 87 | -17x | +693 | +66631x |
- coef_categories <- bw_calc$coefs_between_within[is_coef_involved]+ mus <- ret[inds, , drop = FALSE] |
| 88 | -17x | +694 | +66631x |
- coef_dfs <- vapply(+ epsilons <- theta_chol %*% matrix(stats::rnorm(nsim * obs), ncol = nsim) |
| 89 | -17x | +695 | +66631x |
- X = coef_categories,+ ret[inds, ] <- mus + epsilons |
| 90 | -17x | +|||
| 696 | +
- FUN = switch,+ } |
|||
| 91 | -17x | +|||
| 697 | +
- intercept = bw_calc$ddf_within,+ } |
|||
| 92 | -17x | +|||
| 698 | +
- between = bw_calc$ddf_between,+ |
|||
| 93 | -17x | +699 | +515x |
- within = bw_calc$ddf_within,+ ret |
| 94 | -17x | +|||
| 700 | +
- FUN.VALUE = integer(1)+ } |
| 95 | +1 |
- )+ #' Determine Within or Between for each Design Matrix Column |
||
| 96 | -17x | +|||
| 2 | +
- min(coef_dfs)+ #' |
|||
| 97 | +3 |
- }+ #' @description Used in [h_df_bw_calc()] to determine whether a variable |
||
| 98 | +4 |
-
+ #' differs only between subjects or also within subjects. |
||
| 99 | +5 |
- #' Calculation of Between-Within Degrees of Freedom for One-Dimensional Contrast+ #' |
||
| 100 | +6 |
- #'+ #' @param x_matrix (`matrix`)\cr the design matrix with column names. |
||
| 101 | +7 |
- #' @description Used in [df_1d()] if method is "Between-Within".+ #' @param subject_ids (`factor`)\cr the subject IDs. |
||
| 102 | +8 |
#' |
||
| 103 | +9 |
- #' @inheritParams h_df_1d_sat+ #' @return Character vector with "intercept", "within" or "between" for each |
||
| 104 | +10 |
- #' @inherit h_df_1d_sat return+ #' design matrix column identified via the names of the vector. |
||
| 105 | +11 | ++ |
+ #'+ |
+ |
| 12 |
#' @keywords internal |
|||
| 106 | +13 |
- h_df_1d_bw <- function(object, contrast) {
+ h_within_or_between <- function(x_matrix, subject_ids) {
|
||
| 107 | -7x | +14 | +19x |
- assert_class(object, "mmrm")+ assert_matrix(x_matrix, col.names = "unique", min.cols = 1L) |
| 108 | -7x | +15 | +19x |
- assert_numeric(contrast, len = length(component(object, "beta_est")))+ assert_factor(subject_ids, len = nrow(x_matrix)) |
| 109 | +16 | |||
| 110 | -7x | +17 | +19x |
- bw_calc <- h_df_bw_calc(object)+ n_subjects <- length(unique(subject_ids)) |
| 111 | -7x | +18 | +19x |
- is_coef_involved <- contrast != 0+ vapply( |
| 112 | -7x | +19 | +19x |
- df <- h_df_min_bw(bw_calc, is_coef_involved)+ colnames(x_matrix), |
| 113 | -7x | +20 | +19x |
- h_test_1d(object, contrast, df)+ function(x) {
|
| 114 | -+ | |||
| 21 | +112x |
- }+ if (x == "(Intercept)") {
|
||
| 115 | -+ | |||
| 22 | +19x |
-
+ "intercept" |
||
| 116 | +23 |
- #' Calculation of Between-Within Degrees of Freedom for Multi-Dimensional Contrast+ } else {
|
||
| 117 | -+ | |||
| 24 | +93x |
- #'+ n_unique <- nrow(unique(cbind(x_matrix[, x], subject_ids))) |
||
| 118 | -+ | |||
| 25 | +43x |
- #' @description Used in [df_md()] if method is "Between-Within".+ if (n_unique > n_subjects) "within" else "between" |
||
| 119 | +26 |
- #'+ } |
||
| 120 | +27 |
- #' @inheritParams h_df_md_sat+ }, |
||
| 121 | -+ | |||
| 28 | +19x |
- #' @inherit h_df_md_sat return+ character(1L) |
||
| 122 | +29 |
- #' @keywords internal+ ) |
||
| 123 | +30 |
- h_df_md_bw <- function(object, contrast) {
+ } |
||
| 124 | -7x | +|||
| 31 | +
- assert_class(object, "mmrm")+ |
|||
| 125 | -7x | +|||
| 32 | +
- assert_matrix(contrast, mode = "numeric", any.missing = FALSE, ncols = length(component(object, "beta_est")))+ #' Calculation of Between-Within Degrees of Freedom |
|||
| 126 | +33 |
-
+ #' |
||
| 127 | -7x | +|||
| 34 | +
- bw_calc <- h_df_bw_calc(object)+ #' @description Used in [h_df_1d_bw()] and [h_df_md_bw()]. |
|||
| 128 | -7x | +|||
| 35 | +
- is_coef_involved <- apply(X = contrast != 0, MARGIN = 2L, FUN = any)+ #' |
|||
| 129 | -7x | +|||
| 36 | +
- df <- h_df_min_bw(bw_calc, is_coef_involved)+ #' @param object (`mmrm`)\cr the fitted MMRM. |
|||
| 130 | -7x | +|||
| 37 | +
- h_test_md(object, contrast, df)+ #' |
|||
| 131 | +38 |
- }+ #' @return List with: |
| 1 | +39 |
- #' Methods for `mmrm` Objects+ #' - `coefs_between_within` calculated via [h_within_or_between()] |
||
| 2 | +40 |
- #'+ #' - `ddf_between` |
||
| 3 | +41 |
- #' @description `r lifecycle::badge("stable")`
+ #' - `ddf_within` |
||
| 4 | +42 |
#' |
||
| 5 | +43 |
- #' @param object (`mmrm`)\cr the fitted MMRM including Jacobian and call etc.+ #' @keywords internal |
||
| 6 | +44 |
- #' @param ... not used.+ h_df_bw_calc <- function(object) {
|
||
| 7 | -+ | |||
| 45 | +18x |
- #' @return Depends on the method, see Details and Functions.+ assert_class(object, "mmrm") |
||
| 8 | +46 |
- #'+ |
||
| 9 | -+ | |||
| 47 | +18x |
- #' @details+ n_subjects <- component(object, "n_subjects") |
||
| 10 | -+ | |||
| 48 | +18x |
- #' While printing the summary of (`mmrm`)\cr object, the following will be displayed:+ n_obs <- component(object, "n_obs") |
||
| 11 | -+ | |||
| 49 | +18x |
- #' 1. Formula. The formula used in the model.+ x_mat <- component(object, "x_matrix") |
||
| 12 | +50 |
- #' 2. Data. The data used for analysis, including number of subjects, number of valid observations.+ |
||
| 13 | -+ | |||
| 51 | +18x |
- #' 3. Covariance. The covariance structure and number of variance parameters.+ subject_var <- component(object, "subject_var") |
||
| 14 | -+ | |||
| 52 | +18x |
- #' 4. Method. Restricted maximum likelihood(REML) or maximum likelihood(ML).+ full_frame <- component(object, "full_frame") |
||
| 15 | -+ | |||
| 53 | +18x |
- #' 5. Model selection criteria. AIC, BIC, log likelihood and deviance.+ subject_ids <- full_frame[[subject_var]] |
||
| 16 | +54 |
- #' 6. Coefficients. Coefficients of the covariates.+ |
||
| 17 | -+ | |||
| 55 | +18x |
- #' 7. Covariance estimate. The covariance estimate(for each group).+ coefs_between_within <- h_within_or_between(x_mat, subject_ids) |
||
| 18 | -+ | |||
| 56 | +18x |
- #' 1. If the covariance structure is non-spatial, the covariance matrix of all categorical time points available+ n_coefs_between <- sum(coefs_between_within == "between") |
||
| 19 | -+ | |||
| 57 | +18x |
- #' in data will be displayed.+ n_intercept <- sum(coefs_between_within == "intercept") |
||
| 20 | -+ | |||
| 58 | +18x |
- #' 2. If the covariance structure is spatial, the covariance matrix of two time points with unit distance+ n_coefs_within <- sum(coefs_between_within == "within") |
||
| 21 | -+ | |||
| 59 | +18x |
- #' will be displayed.+ ddf_between <- n_subjects - n_coefs_between - n_intercept |
||
| 22 | -+ | |||
| 60 | +18x |
- #'+ ddf_within <- n_obs - n_subjects - n_coefs_within |
||
| 23 | +61 |
- #' `confint` is used to obtain the confidence intervals for the coefficients.+ + |
+ ||
| 62 | +18x | +
+ list(+ |
+ ||
| 63 | +18x | +
+ coefs_between_within = coefs_between_within, |
||
| 24 | -+ | |||
| 64 | +18x |
- #' Please note that this is different from the confidence interval of difference+ ddf_between = ddf_between, |
||
| 25 | -+ | |||
| 65 | +18x |
- #' of least square means from `emmeans`.+ ddf_within = ddf_within |
||
| 26 | +66 |
- #'+ ) |
||
| 27 | +67 |
- #' @name mmrm_methods+ } |
||
| 28 | +68 |
- #'+ |
||
| 29 | +69 |
- #' @seealso [`mmrm_tmb_methods`], [`mmrm_tidiers`] for additional methods.+ #' Assign Minimum Degrees of Freedom Given Involved Coefficients |
||
| 30 | +70 |
#' |
||
| 31 | +71 |
- #' @examples+ #' @description Used in [h_df_1d_bw()] and [h_df_md_bw()]. |
||
| 32 | +72 |
- #' formula <- FEV1 ~ RACE + SEX + ARMCD * AVISIT + us(AVISIT | USUBJID)+ #' |
||
| 33 | +73 |
- #' object <- mmrm(formula, fev_data)+ #' @param bw_calc (`list`)\cr from [h_df_bw_calc()]. |
||
| 34 | +74 |
- NULL+ #' @param is_coef_involved (`logical`)\cr whether each coefficient is involved |
||
| 35 | +75 |
-
+ #' in the contrast. |
||
| 36 | +76 |
- #' Coefficients Table for MMRM Fit+ #' |
||
| 37 | +77 |
- #'+ #' @return The minimum of the degrees of freedom assigned to each involved |
||
| 38 | +78 |
- #' This is used by [summary.mmrm()] to obtain the coefficients table.+ #' coefficient according to its between-within categorization. |
||
| 39 | +79 |
#' |
||
| 40 | +80 |
- #' @param object (`mmrm`)\cr model fit.+ #' @keywords internal |
||
| 41 | +81 |
- #'+ h_df_min_bw <- function(bw_calc, is_coef_involved) {
|
||
| 42 | -+ | |||
| 82 | +17x |
- #' @return Matrix with one row per coefficient and columns+ assert_list(bw_calc) |
||
| 43 | -+ | |||
| 83 | +17x |
- #' `Estimate`, `Std. Error`, `df`, `t value` and `Pr(>|t|)`.+ assert_names(names(bw_calc), identical.to = c("coefs_between_within", "ddf_between", "ddf_within"))
|
||
| 44 | -+ | |||
| 84 | +17x |
- #'+ assert_logical(is_coef_involved, len = length(bw_calc$coefs_between_within)) |
||
| 45 | -+ | |||
| 85 | +17x |
- #' @keywords internal+ assert_true(sum(is_coef_involved) > 0) |
||
| 46 | +86 |
- h_coef_table <- function(object) {
+
|
||
| 47 | -40x | +87 | +17x |
- assert_class(object, "mmrm")+ coef_categories <- bw_calc$coefs_between_within[is_coef_involved] |
| 48 | -+ | |||
| 88 | +17x |
-
+ coef_dfs <- vapply( |
||
| 49 | -40x | +89 | +17x |
- coef_est <- component(object, "beta_est")+ X = coef_categories, |
| 50 | -40x | +90 | +17x |
- coef_contrasts <- diag(x = rep(1, length(coef_est)))+ FUN = switch, |
| 51 | -40x | +91 | +17x |
- rownames(coef_contrasts) <- names(coef_est)+ intercept = bw_calc$ddf_within, |
| 52 | -40x | +92 | +17x |
- coef_table <- t(apply(+ between = bw_calc$ddf_between, |
| 53 | -40x | +93 | +17x |
- coef_contrasts,+ within = bw_calc$ddf_within, |
| 54 | -40x | +94 | +17x |
- MARGIN = 1L,+ FUN.VALUE = integer(1)+ |
+
| 95 | ++ |
+ ) |
||
| 55 | -40x | +96 | +17x |
- FUN = function(contrast) unlist(df_1d(object, contrast))+ min(coef_dfs) |
| 56 | +97 |
- ))+ } |
||
| 57 | -40x | +|||
| 98 | +
- assert_names(+ |
|||
| 58 | -40x | +|||
| 99 | +
- colnames(coef_table),+ #' Calculation of Between-Within Degrees of Freedom for One-Dimensional Contrast |
|||
| 59 | -40x | +|||
| 100 | +
- identical.to = c("est", "se", "df", "t_stat", "p_val")
+ #' |
|||
| 60 | +101 |
- )+ #' @description Used in [df_1d()] if method is "Between-Within". |
||
| 61 | -40x | +|||
| 102 | +
- colnames(coef_table) <- c("Estimate", "Std. Error", "df", "t value", "Pr(>|t|)")
+ #' |
|||
| 62 | +103 |
-
+ #' @inheritParams h_df_1d_sat |
||
| 63 | -40x | +|||
| 104 | +
- coef_aliased <- component(object, "beta_aliased")+ #' @inherit h_df_1d_sat return |
|||
| 64 | -40x | +|||
| 105 | +
- if (any(coef_aliased)) {
+ #' @keywords internal |
|||
| 65 | -2x | +|||
| 106 | +
- names_coef_na <- names(which(coef_aliased))+ h_df_1d_bw <- function(object, contrast) {
|
|||
| 66 | -2x | +107 | +7x |
- coef_na_table <- matrix(+ assert_class(object, "mmrm") |
| 67 | -2x | +108 | +7x |
- data = NA,+ assert_numeric(contrast, len = length(component(object, "beta_est"))) |
| 68 | -2x | +|||
| 109 | +
- nrow = length(names_coef_na),+ |
|||
| 69 | -2x | +110 | +7x |
- ncol = ncol(coef_table),+ bw_calc <- h_df_bw_calc(object) |
| 70 | -2x | +111 | +7x |
- dimnames = list(names_coef_na, colnames(coef_table))+ is_coef_involved <- contrast != 0 |
| 71 | -+ | |||
| 112 | +7x |
- )+ df <- h_df_min_bw(bw_calc, is_coef_involved) |
||
| 72 | -2x | +113 | +7x |
- coef_table <- rbind(coef_table, coef_na_table)[names(coef_aliased), ]+ h_test_1d(object, contrast, df) |
| 73 | +114 |
- }+ } |
||
| 74 | +115 | |||
| 75 | -40x | +|||
| 116 | +
- coef_table+ #' Calculation of Between-Within Degrees of Freedom for Multi-Dimensional Contrast |
|||
| 76 | +117 |
- }+ #' |
||
| 77 | +118 |
-
+ #' @description Used in [df_md()] if method is "Between-Within". |
||
| 78 | +119 |
- #' @describeIn mmrm_methods summarizes the MMRM fit results.+ #' |
||
| 79 | +120 |
- #' @exportS3Method+ #' @inheritParams h_df_md_sat |
||
| 80 | +121 |
- #' @examples+ #' @inherit h_df_md_sat return |
||
| 81 | +122 |
- #' # Summary:+ #' @keywords internal |
||
| 82 | +123 |
- #' summary(object)+ h_df_md_bw <- function(object, contrast) {
+ |
+ ||
| 124 | +7x | +
+ assert_class(object, "mmrm")+ |
+ ||
| 125 | +7x | +
+ assert_matrix(contrast, mode = "numeric", any.missing = FALSE, ncols = length(component(object, "beta_est"))) |
||
| 83 | +126 |
- summary.mmrm <- function(object, ...) {
+
|
||
| 84 | -20x | +127 | +7x |
- aic_list <- list(+ bw_calc <- h_df_bw_calc(object) |
| 85 | -20x | +128 | +7x |
- AIC = AIC(object),+ is_coef_involved <- apply(X = contrast != 0, MARGIN = 2L, FUN = any) |
| 86 | -20x | +129 | +7x |
- BIC = BIC(object),+ df <- h_df_min_bw(bw_calc, is_coef_involved) |
| 87 | -20x | +130 | +7x |
- logLik = logLik(object),+ h_test_md(object, contrast, df) |
| 88 | -20x | +|||
| 131 | +
- deviance = deviance(object)+ } |
| 89 | +1 |
- )+ #' Methods for `mmrm` Objects |
||
| 90 | -20x | +|||
| 2 | +
- coefficients <- h_coef_table(object)+ #' |
|||
| 91 | -20x | +|||
| 3 | +
- call <- stats::getCall(object)+ #' @description `r lifecycle::badge("stable")`
|
|||
| 92 | -20x | +|||
| 4 | +
- components <- component(object, c(+ #' |
|||
| 93 | -20x | +|||
| 5 | +
- "cov_type", "reml", "n_groups", "n_theta",+ #' @param object (`mmrm`)\cr the fitted MMRM including Jacobian and call etc. |
|||
| 94 | -20x | +|||
| 6 | +
- "n_subjects", "n_timepoints", "n_obs",+ #' @param ... not used. |
|||
| 95 | -20x | +|||
| 7 | +
- "beta_vcov", "varcor"+ #' @return Depends on the method, see Details and Functions. |
|||
| 96 | +8 |
- ))+ #' |
||
| 97 | -20x | +|||
| 9 | +
- components$method <- object$method+ #' @details |
|||
| 98 | -20x | +|||
| 10 | +
- components$vcov <- object$vcov+ #' While printing the summary of (`mmrm`)\cr object, the following will be displayed: |
|||
| 99 | -20x | +|||
| 11 | +
- structure(+ #' 1. Formula. The formula used in the model. |
|||
| 100 | -20x | +|||
| 12 | +
- c(+ #' 2. Data. The data used for analysis, including number of subjects, number of valid observations. |
|||
| 101 | -20x | +|||
| 13 | ++ |
+ #' 3. Covariance. The covariance structure and number of variance parameters.+ |
+ ||
| 14 | ++ |
+ #' 4. Method. Restricted maximum likelihood(REML) or maximum likelihood(ML).+ |
+ ||
| 15 | ++ |
+ #' 5. Model selection criteria. AIC, BIC, log likelihood and deviance.+ |
+ ||
| 16 | ++ |
+ #' 6. Coefficients. Coefficients of the covariates.+ |
+ ||
| 17 | +
- components,+ #' 7. Covariance estimate. The covariance estimate(for each group). |
|||
| 102 | -20x | +|||
| 18 | +
- list(+ #' 1. If the covariance structure is non-spatial, the covariance matrix of all categorical time points available |
|||
| 103 | -20x | +|||
| 19 | +
- coefficients = coefficients,+ #' in data will be displayed. |
|||
| 104 | -20x | +|||
| 20 | +
- n_singular_coefs = sum(component(object, "beta_aliased")),+ #' 2. If the covariance structure is spatial, the covariance matrix of two time points with unit distance |
|||
| 105 | -20x | +|||
| 21 | +
- aic_list = aic_list,+ #' will be displayed. |
|||
| 106 | -20x | +|||
| 22 | +
- call = call+ #' |
|||
| 107 | +23 |
- )+ #' `confint` is used to obtain the confidence intervals for the coefficients. |
||
| 108 | +24 |
- ),+ #' Please note that this is different from the confidence interval of difference |
||
| 109 | -20x | +|||
| 25 | +
- class = "summary.mmrm"+ #' of least square means from `emmeans`. |
|||
| 110 | +26 |
- )+ #' |
||
| 111 | +27 |
- }+ #' @name mmrm_methods |
||
| 112 | +28 |
-
+ #' |
||
| 113 | +29 |
- #' Printing MMRM Function Call+ #' @seealso [`mmrm_tmb_methods`], [`mmrm_tidiers`] for additional methods. |
||
| 114 | +30 |
#' |
||
| 115 | +31 |
- #' This is used in [print.summary.mmrm()].+ #' @examples |
||
| 116 | +32 |
- #'+ #' formula <- FEV1 ~ RACE + SEX + ARMCD * AVISIT + us(AVISIT | USUBJID) |
||
| 117 | +33 |
- #' @param call (`call`)\cr original [mmrm()] function call.+ #' object <- mmrm(formula, fev_data) |
||
| 118 | +34 |
- #' @param n_obs (`int`)\cr number of observations.+ NULL |
||
| 119 | +35 |
- #' @param n_subjects (`int`)\cr number of subjects.+ |
||
| 120 | +36 |
- #' @param n_timepoints (`int`)\cr number of timepoints.+ #' Coefficients Table for MMRM Fit |
||
| 121 | +37 |
#' |
||
| 122 | +38 |
- #' @keywords internal+ #' This is used by [summary.mmrm()] to obtain the coefficients table. |
||
| 123 | +39 |
- h_print_call <- function(call, n_obs, n_subjects, n_timepoints) {
+ #' |
||
| 124 | -9x | +|||
| 40 | +
- pass <- 0+ #' @param object (`mmrm`)\cr model fit. |
|||
| 125 | -9x | +|||
| 41 | +
- if (!is.null(tmp <- call$formula)) {
+ #' |
|||
| 126 | -9x | +|||
| 42 | +
- cat("Formula: ", deparse(tmp), fill = TRUE)
+ #' @return Matrix with one row per coefficient and columns |
|||
| 127 | -9x | +|||
| 43 | +
- rhs <- tmp[[2]]+ #' `Estimate`, `Std. Error`, `df`, `t value` and `Pr(>|t|)`. |
|||
| 128 | -9x | +|||
| 44 | +
- pass <- nchar(deparse(rhs))+ #' |
|||
| 129 | +45 |
- }+ #' @keywords internal |
||
| 130 | -9x | +|||
| 46 | +
- if (!is.null(call$data)) {
+ h_coef_table <- function(object) {
|
|||
| 131 | -9x | +47 | +40x |
- cat(+ assert_class(object, "mmrm") |
| 132 | -9x | +|||
| 48 | +
- "Data: ", deparse(call$data), "(used", n_obs, "observations from",+ |
|||
| 133 | -9x | +49 | +40x |
- n_subjects, "subjects with maximum", n_timepoints, "timepoints)",+ coef_est <- component(object, "beta_est") |
| 134 | -9x | +50 | +40x |
- fill = TRUE+ coef_contrasts <- diag(x = rep(1, length(coef_est))) |
| 135 | -+ | |||
| 51 | +40x |
- )+ rownames(coef_contrasts) <- names(coef_est) |
||
| 136 | -+ | |||
| 52 | +40x |
- }+ coef_table <- t(apply( |
||
| 137 | -+ | |||
| 53 | +40x |
- # Display the expression of weights+ coef_contrasts, |
||
| 138 | -9x | +54 | +40x |
- if (!is.null(call$weights)) {
+ MARGIN = 1L, |
| 139 | -4x | +55 | +40x |
- cat("Weights: ", deparse(call$weights), fill = TRUE)
+ FUN = function(contrast) unlist(df_1d(object, contrast)) |
| 140 | +56 |
- }+ )) |
||
| 141 | -+ | |||
| 57 | +40x |
- }+ assert_names( |
||
| 142 | -+ | |||
| 58 | +40x |
-
+ colnames(coef_table), |
||
| 143 | -+ | |||
| 59 | +40x |
- #' Printing MMRM Covariance Type+ identical.to = c("est", "se", "df", "t_stat", "p_val")
|
||
| 144 | +60 |
- #'+ ) |
||
| 145 | -+ | |||
| 61 | +40x |
- #' This is used in [print.summary.mmrm()].+ colnames(coef_table) <- c("Estimate", "Std. Error", "df", "t value", "Pr(>|t|)")
|
||
| 146 | +62 |
- #'+ |
||
| 147 | -+ | |||
| 63 | +40x |
- #' @param cov_type (`string`)\cr covariance structure abbreviation.+ coef_aliased <- component(object, "beta_aliased") |
||
| 148 | -+ | |||
| 64 | +40x |
- #' @param n_theta (`count`)\cr number of variance parameters.+ if (any(coef_aliased)) {
|
||
| 149 | -+ | |||
| 65 | +2x |
- #' @param n_groups (`count`)\cr number of groups.+ names_coef_na <- names(which(coef_aliased)) |
||
| 150 | -+ | |||
| 66 | +2x |
- #' @keywords internal+ coef_na_table <- matrix( |
||
| 151 | -+ | |||
| 67 | +2x |
- h_print_cov <- function(cov_type, n_theta, n_groups) {
+ data = NA, |
||
| 152 | -9x | +68 | +2x |
- assert_string(cov_type)+ nrow = length(names_coef_na), |
| 153 | -9x | +69 | +2x |
- assert_count(n_theta, positive = TRUE)+ ncol = ncol(coef_table), |
| 154 | -9x | +70 | +2x |
- assert_count(n_groups, positive = TRUE)+ dimnames = list(names_coef_na, colnames(coef_table)) |
| 155 | -9x | +|||
| 71 | +
- cov_definition <- switch(cov_type,+ ) |
|||
| 156 | -9x | +72 | +2x |
- us = "unstructured",+ coef_table <- rbind(coef_table, coef_na_table)[names(coef_aliased), ] |
| 157 | -9x | +|||
| 73 | +
- toep = "Toeplitz",+ } |
|||
| 158 | -9x | +|||
| 74 | +
- toeph = "heterogeneous Toeplitz",+ |
|||
| 159 | -9x | +75 | +40x |
- ar1 = "auto-regressive order one",+ coef_table |
| 160 | -9x | +|||
| 76 | +
- ar1h = "heterogeneous auto-regressive order one",+ } |
|||
| 161 | -9x | +|||
| 77 | +
- ad = "ante-dependence",+ |
|||
| 162 | -9x | +|||
| 78 | +
- adh = "heterogeneous ante-dependence",+ #' @describeIn mmrm_methods summarizes the MMRM fit results. |
|||
| 163 | -9x | +|||
| 79 | +
- cs = "compound symmetry",+ #' @exportS3Method |
|||
| 164 | -9x | +|||
| 80 | +
- csh = "heterogeneous compound symmetry",+ #' @examples |
|||
| 165 | -9x | +|||
| 81 | +
- sp_exp = "spatial exponential"+ #' # Summary: |
|||
| 166 | +82 |
- )+ #' summary(object) |
||
| 167 | +83 |
-
+ summary.mmrm <- function(object, ...) {
|
||
| 168 | -9x | +84 | +20x |
- catstr <- sprintf(+ aic_list <- list( |
| 169 | -9x | +85 | +20x |
- "Covariance: %s (%d variance parameters%s)\n",+ AIC = AIC(object), |
| 170 | -9x | +86 | +20x |
- cov_definition,+ BIC = BIC(object), |
| 171 | -9x | +87 | +20x |
- n_theta,+ logLik = logLik(object), |
| 172 | -9x | +88 | +20x |
- ifelse(n_groups == 1L, "", sprintf(" of %d groups", n_groups))
+ deviance = deviance(object) |
| 173 | +89 |
) |
||
| 174 | -9x | +90 | +20x |
- cat(catstr)+ coefficients <- h_coef_table(object) |
| 175 | -+ | |||
| 91 | +20x |
- }+ call <- stats::getCall(object) |
||
| 176 | -+ | |||
| 92 | +20x |
-
+ components <- component(object, c( |
||
| 177 | -+ | |||
| 93 | +20x |
- #' Printing AIC and other Model Fit Criteria+ "cov_type", "reml", "n_groups", "n_theta", |
||
| 178 | -+ | |||
| 94 | +20x |
- #'+ "n_subjects", "n_timepoints", "n_obs", |
||
| 179 | -+ | |||
| 95 | +20x |
- #' This is used in [print.summary.mmrm()].+ "beta_vcov", "varcor" |
||
| 180 | +96 |
- #'+ )) |
||
| 181 | -+ | |||
| 97 | +20x |
- #' @param aic_list (`list`)\cr list as part of from [summary.mmrm()].+ components$method <- object$method |
||
| 182 | -+ | |||
| 98 | +20x |
- #' @param digits (`number`)\cr number of decimal places used with [round()].+ components$vcov <- object$vcov |
||
| 183 | -+ | |||
| 99 | +20x |
- #'+ structure( |
||
| 184 | -+ | |||
| 100 | +20x |
- #' @keywords internal+ c( |
||
| 185 | -+ | |||
| 101 | +20x |
- h_print_aic_list <- function(aic_list,+ components, |
||
| 186 | -+ | |||
| 102 | +20x |
- digits = 1) {
+ list( |
||
| 187 | -6x | +103 | +20x |
- diag_vals <- round(unlist(aic_list), digits)+ coefficients = coefficients, |
| 188 | -6x | +104 | +20x |
- diag_vals <- format(diag_vals)+ n_singular_coefs = sum(component(object, "beta_aliased")), |
| 189 | -6x | +105 | +20x |
- print(diag_vals, quote = FALSE)+ aic_list = aic_list, |
| 190 | -+ | |||
| 106 | +20x |
- }+ call = call |
||
| 191 | +107 |
-
+ ) |
||
| 192 | +108 |
- #' @describeIn mmrm_methods prints the MMRM fit summary.+ ), |
||
| 193 | -+ | |||
| 109 | +20x |
- #' @exportS3Method+ class = "summary.mmrm" |
||
| 194 | +110 |
- #' @keywords internal+ ) |
||
| 195 | +111 |
- print.summary.mmrm <- function(x,+ } |
||
| 196 | +112 |
- digits = max(3, getOption("digits") - 3),
+
|
||
| 197 | +113 |
- signif.stars = getOption("show.signif.stars"), # nolint
+ #' Printing MMRM Function Call |
||
| 198 | +114 |
- ...) {
+ #' |
||
| 199 | -5x | +|||
| 115 | +
- cat("mmrm fit\n\n")
+ #' This is used in [print.summary.mmrm()]. |
|||
| 200 | -5x | +|||
| 116 | +
- h_print_call(x$call, x$n_obs, x$n_subjects, x$n_timepoints)+ #' |
|||
| 201 | -5x | +|||
| 117 | +
- h_print_cov(x$cov_type, x$n_theta, x$n_groups)+ #' @param call (`call`)\cr original [mmrm()] function call. |
|||
| 202 | -5x | +|||
| 118 | +
- cat("Method: ", x$method, "\n", sep = "")
+ #' @param n_obs (`int`)\cr number of observations. |
|||
| 203 | -5x | +|||
| 119 | +
- cat("Vcov Method: ", x$vcov, "\n", sep = "")
+ #' @param n_subjects (`int`)\cr number of subjects. |
|||
| 204 | -5x | +|||
| 120 | +
- cat("Inference: ")
+ #' @param n_timepoints (`int`)\cr number of timepoints. |
|||
| 205 | -5x | +|||
| 121 | +
- cat(ifelse(x$reml, "REML", "ML"))+ #' |
|||
| 206 | -5x | +|||
| 122 | +
- cat("\n\n")
+ #' @keywords internal |
|||
| 207 | -5x | +|||
| 123 | +
- cat("Model selection criteria:\n")
+ h_print_call <- function(call, n_obs, n_subjects, n_timepoints) {
|
|||
| 208 | -5x | +124 | +9x |
- h_print_aic_list(x$aic_list)+ pass <- 0 |
| 209 | -5x | +125 | +9x |
- cat("\n")
+ if (!is.null(tmp <- call$formula)) {
|
| 210 | -5x | +126 | +9x |
- cat("Coefficients: ")
+ cat("Formula: ", deparse(tmp), fill = TRUE)
|
| 211 | -5x | +127 | +9x |
- if (x$n_singular_coefs > 0) {
+ rhs <- tmp[[2]] |
| 212 | -1x | +128 | +9x |
- cat("(", x$n_singular_coefs, " not defined because of singularities)", sep = "")
+ pass <- nchar(deparse(rhs)) |
| 213 | +129 |
} |
||
| 214 | -5x | -
- cat("\n")
- |
- ||
| 215 | -5x | +130 | +9x |
- stats::printCoefmat(+ if (!is.null(call$data)) {
|
| 216 | -5x | +131 | +9x |
- x$coefficients,+ cat( |
| 217 | -5x | +132 | +9x |
- zap.ind = 3,+ "Data: ", deparse(call$data), "(used", n_obs, "observations from", |
| 218 | -5x | +133 | +9x |
- digits = digits,+ n_subjects, "subjects with maximum", n_timepoints, "timepoints)", |
| 219 | -5x | +134 | +9x |
- signif.stars = signif.stars+ fill = TRUE |
| 220 | +135 |
- )- |
- ||
| 221 | -5x | -
- cat("\n")
- |
- ||
| 222 | -5x | -
- cat("Covariance estimate:\n")
+ ) |
||
| 223 | -5x | +|||
| 136 | +
- if (is.list(x$varcor)) {
+ } |
|||
| 224 | -1x | +|||
| 137 | +
- for (v in names(x$varcor)) {
+ # Display the expression of weights |
|||
| 225 | -2x | +138 | +9x |
- cat(sprintf("Group: %s\n", v))
+ if (!is.null(call$weights)) {
|
| 226 | -2x | +139 | +4x |
- print(round(x$varcor[[v]], digits = digits))+ cat("Weights: ", deparse(call$weights), fill = TRUE)
|
| 227 | +140 |
- }+ } |
||
| 228 | +141 |
- } else {
- |
- ||
| 229 | -4x | -
- print(round(x$varcor, digits = digits))+ } |
||
| 230 | +142 |
- }- |
- ||
| 231 | -5x | -
- cat("\n")
- |
- ||
| 232 | -5x | -
- invisible(x)+ |
||
| 233 | +143 |
- }+ #' Printing MMRM Covariance Type |
||
| 234 | +144 |
-
+ #' |
||
| 235 | +145 |
-
+ #' This is used in [print.summary.mmrm()]. |
||
| 236 | +146 |
- #' @describeIn mmrm_methods obtain the confidence intervals for the coefficients.+ #' |
||
| 237 | +147 |
- #' @exportS3Method+ #' @param cov_type (`string`)\cr covariance structure abbreviation. |
||
| 238 | +148 |
- #' @examples+ #' @param n_theta (`count`)\cr number of variance parameters. |
||
| 239 | +149 |
- #' # Confidence Interval:+ #' @param n_groups (`count`)\cr number of groups. |
||
| 240 | +150 |
- #' confint(object)+ #' @keywords internal |
||
| 241 | +151 |
- confint.mmrm <- function(object, parm, level = 0.95, ...) {
+ h_print_cov <- function(cov_type, n_theta, n_groups) {
|
||
| 242 | -20x | +152 | +9x |
- cf <- coef(object)+ assert_string(cov_type) |
| 243 | -20x | +153 | +9x |
- pnames <- names(cf)+ assert_count(n_theta, positive = TRUE) |
| 244 | -20x | +154 | +9x |
- if (missing(parm)) {
+ assert_count(n_groups, positive = TRUE) |
| 245 | -15x | -
- parm <- pnames- |
- ||
| 246 | -+ | 155 | +9x |
- }+ cov_definition <- switch(cov_type, |
| 247 | -20x | +156 | +9x |
- assert(+ us = "unstructured", |
| 248 | -20x | +157 | +9x |
- check_subset(parm, pnames),+ toep = "Toeplitz", |
| 249 | -20x | -
- check_integerish(parm, lower = 1L, upper = length(cf))- |
- ||
| 250 | -+ | 158 | +9x |
- )+ toeph = "heterogeneous Toeplitz", |
| 251 | -2x | +159 | +9x |
- if (is.numeric(parm)) parm <- pnames[parm]+ ar1 = "auto-regressive order one", |
| 252 | -18x | +160 | +9x |
- assert_number(level, lower = 0, upper = 1)+ ar1h = "heterogeneous auto-regressive order one", |
| 253 | -18x | +161 | +9x |
- a <- (1 - level) / 2+ ad = "ante-dependence", |
| 254 | -18x | +162 | +9x |
- pct <- paste(format(100 * c(a, 1 - a), trim = TRUE, scientific = FALSE, digits = 3), "%")+ adh = "heterogeneous ante-dependence", |
| 255 | -18x | +163 | +9x |
- coef_table <- h_coef_table(object)+ cs = "compound symmetry", |
| 256 | -18x | +164 | +9x |
- df <- coef_table[parm, "df"]+ csh = "heterogeneous compound symmetry", |
| 257 | -18x | +165 | +9x |
- ses <- coef_table[parm, "Std. Error"]+ sp_exp = "spatial exponential" |
| 258 | -18x | +|||
| 166 | +
- fac <- stats::qt(a, df = df)+ ) |
|||
| 259 | -18x | +|||
| 167 | +
- ci <- array(NA, dim = c(length(parm), 2L), dimnames = list(parm, pct))+ |
|||
| 260 | -18x | +168 | +9x |
- sefac <- ses * fac+ catstr <- sprintf( |
| 261 | -18x | +169 | +9x |
- ci[] <- cf[parm] + c(sefac, -sefac)+ "Covariance: %s (%d variance parameters%s)\n", |
| 262 | -18x | +170 | +9x |
- ci+ cov_definition, |
| 263 | -+ | |||
| 171 | +9x |
- }+ n_theta, |
| 1 | -+ | |||
| 172 | +9x |
- #' Tidying Methods for `mmrm` Objects+ ifelse(n_groups == 1L, "", sprintf(" of %d groups", n_groups))
|
||
| 2 | +173 |
- #'+ ) |
||
| 3 | -+ | |||
| 174 | +9x |
- #' @description `r lifecycle::badge("stable")`
+ cat(catstr) |
||
| 4 | +175 |
- #'+ } |
||
| 5 | +176 |
- #' These methods tidy the estimates from an `mmrm` object into a+ |
||
| 6 | +177 |
- #' summary.+ #' Printing AIC and other Model Fit Criteria |
||
| 7 | +178 |
#' |
||
| 8 | +179 |
- #' @param x (`mmrm`)\cr fitted model.+ #' This is used in [print.summary.mmrm()]. |
||
| 9 | +180 |
- #' @param conf.int (`flag`)\cr if `TRUE` columns for the lower (`conf.low`) and upper bounds+ #' |
||
| 10 | +181 |
- #' (`conf.high`) of coefficient estimates are included.+ #' @param aic_list (`list`)\cr list as part of from [summary.mmrm()]. |
||
| 11 | +182 |
- #' @param conf.level (`number`)\cr defines the range of the optional confidence internal.+ #' @param digits (`number`)\cr number of decimal places used with [round()]. |
||
| 12 | +183 |
- #' @param newdata (`data.frame` or `NULL`)\cr optional new data frame.+ #' |
||
| 13 | +184 |
- #' @param se_fit (`flag`)\cr whether to return standard errors of fit.+ #' @keywords internal |
||
| 14 | +185 |
- #' @param interval (`string`)\cr type of interval calculation.+ h_print_aic_list <- function(aic_list, |
||
| 15 | +186 |
- #' @param type.residuals (`string`)\cr passed on to [residuals.mmrm_tmb()].+ digits = 1) {
|
||
| 16 | -+ | |||
| 187 | +6x |
- #' @param ... only used by `augment()` to pass arguments to the [predict.mmrm_tmb()] method.+ diag_vals <- round(unlist(aic_list), digits) |
||
| 17 | -+ | |||
| 188 | +6x |
- #'+ diag_vals <- format(diag_vals) |
||
| 18 | -+ | |||
| 189 | +6x |
- #' @name mmrm_tidiers+ print(diag_vals, quote = FALSE) |
||
| 19 | +190 |
- #' @aliases mmrm_tidiers+ } |
||
| 20 | +191 |
- #'+ |
||
| 21 | +192 |
- #' @seealso [`mmrm_methods`], [`mmrm_tmb_methods`] for additional methods.+ #' @describeIn mmrm_methods prints the MMRM fit summary. |
||
| 22 | +193 |
- #'+ #' @exportS3Method |
||
| 23 | +194 |
- #' @examples+ #' @keywords internal |
||
| 24 | +195 |
- #' fit <- mmrm(+ print.summary.mmrm <- function(x, |
||
| 25 | +196 |
- #' formula = FEV1 ~ RACE + SEX + ARMCD * AVISIT + us(AVISIT | USUBJID),+ digits = max(3, getOption("digits") - 3),
|
||
| 26 | +197 |
- #' data = fev_data+ signif.stars = getOption("show.signif.stars"), # nolint
|
||
| 27 | +198 |
- #' )+ ...) {
|
||
| 28 | -+ | |||
| 199 | +5x |
- NULL+ cat("mmrm fit\n\n")
|
||
| 29 | -+ | |||
| 200 | +5x |
-
+ h_print_call(x$call, x$n_obs, x$n_subjects, x$n_timepoints) |
||
| 30 | -+ | |||
| 201 | +5x |
- #' @describeIn mmrm_tidiers derives tidy `tibble` from an `mmrm` object.+ h_print_cov(x$cov_type, x$n_theta, x$n_groups) |
||
| 31 | -+ | |||
| 202 | +5x |
- #' @exportS3Method+ cat("Method: ", x$method, "\n", sep = "")
|
||
| 32 | -+ | |||
| 203 | +5x |
- #' @examples+ cat("Vcov Method: ", x$vcov, "\n", sep = "")
|
||
| 33 | -+ | |||
| 204 | +5x |
- #' # Applying tidy method to return summary table of covariate estimates.+ cat("Inference: ")
|
||
| 34 | -+ | |||
| 205 | +5x |
- #' fit |> tidy()+ cat(ifelse(x$reml, "REML", "ML")) |
||
| 35 | -+ | |||
| 206 | +5x |
- #' fit |> tidy(conf.int = TRUE, conf.level = 0.9)+ cat("\n\n")
|
||
| 36 | -+ | |||
| 207 | +5x |
- tidy.mmrm <- function(x, # nolint+ cat("Model selection criteria:\n")
|
||
| 37 | -+ | |||
| 208 | +5x |
- conf.int = FALSE, # nolint+ h_print_aic_list(x$aic_list) |
||
| 38 | -+ | |||
| 209 | +5x |
- conf.level = 0.95, # nolint+ cat("\n")
|
||
| 39 | -+ | |||
| 210 | +5x |
- ...) {
+ cat("Coefficients: ")
|
||
| 40 | +211 | 5x |
- assert_flag(conf.int)+ if (x$n_singular_coefs > 0) {
|
|
| 41 | -5x | +212 | +1x |
- assert_number(conf.level, lower = 0, upper = 1)+ cat("(", x$n_singular_coefs, " not defined because of singularities)", sep = "")
+ |
+
| 213 | ++ |
+ } |
||
| 42 | +214 | 5x |
- tbl <- tibble::as_tibble(summary(x)$coefficients, rownames = "term")+ cat("\n")
|
|
| 43 | +215 | 5x |
- colnames(tbl) <- c("term", "estimate", "std.error", "df", "statistic", "p.value")
+ stats::printCoefmat( |
|
| 44 | +216 | 5x |
- coefs <- coef(x)+ x$coefficients, |
|
| 45 | +217 | 5x |
- if (length(coefs) != nrow(tbl)) {
+ zap.ind = 3, |
|
| 46 | -! | +|||
| 218 | +5x |
- coefs <- tibble::enframe(coefs, name = "term", value = "estimate")+ digits = digits, |
||
| 47 | -! | +|||
| 219 | +5x |
- tbl <- merge(coefs, tbl, by = c("term", "estimate"))
+ signif.stars = signif.stars |
||
| 48 | +220 |
- }+ ) |
||
| 49 | +221 | 5x |
- if (conf.int) {
+ cat("\n")
|
|
| 50 | -4x | +222 | +5x |
- ci <- h_tbl_confint_terms(x, level = conf.level)+ cat("Covariance estimate:\n")
|
| 51 | -4x | +223 | +5x |
- tbl <- tibble::as_tibble(merge(tbl, ci, by = "term"))+ if (is.list(x$varcor)) {
|
| 52 | -+ | |||
| 224 | +1x |
- }+ for (v in names(x$varcor)) {
|
||
| 53 | -5x | +225 | +2x |
- tbl+ cat(sprintf("Group: %s\n", v))
|
| 54 | -+ | |||
| 226 | +2x |
- }+ print(round(x$varcor[[v]], digits = digits)) |
||
| 55 | +227 |
-
+ } |
||
| 56 | +228 |
- #' @describeIn mmrm_tidiers derives `glance` `tibble` from an `mmrm` object.+ } else {
|
||
| 57 | -+ | |||
| 229 | +4x |
- #' @exportS3Method+ print(round(x$varcor, digits = digits)) |
||
| 58 | +230 |
- #' @examples+ } |
||
| 59 | -+ | |||
| 231 | +5x |
- #' # Applying glance method to return summary table of goodness of fit statistics.+ cat("\n")
|
||
| 60 | -+ | |||
| 232 | +5x |
- #' fit |> glance()+ invisible(x) |
||
| 61 | +233 |
- glance.mmrm <- function(x, ...) { # nolint
- |
- ||
| 62 | -1x | -
- tibble::as_tibble(summary(x)$aic_list)+ } |
||
| 63 | +234 |
- }+ |
||
| 64 | +235 | |||
| 65 | +236 |
- #' @describeIn mmrm_tidiers derives `augment` `tibble` from an `mmrm` object.+ #' @describeIn mmrm_methods obtain the confidence intervals for the coefficients. |
||
| 66 | +237 |
#' @exportS3Method |
||
| 67 | +238 |
#' @examples |
||
| 68 | +239 |
- #' # Applying augment method to return merged `tibble` of model data, fitted and residuals.+ #' # Confidence Interval: |
||
| 69 | +240 |
- #' fit |> augment()+ #' confint(object) |
||
| 70 | +241 |
- #' fit |> augment(interval = "confidence")+ confint.mmrm <- function(object, parm, level = 0.95, ...) {
|
||
| 71 | -+ | |||
| 242 | +20x |
- #' fit |> augment(type.residuals = "pearson")+ cf <- coef(object) |
||
| 72 | -+ | |||
| 243 | +20x |
- augment.mmrm <- function(x, # nolint+ pnames <- names(cf) |
||
| 73 | -+ | |||
| 244 | +20x |
- newdata = NULL,+ if (missing(parm)) {
|
||
| 74 | -+ | |||
| 245 | +15x |
- interval = c("none", "confidence", "prediction"),
+ parm <- pnames |
||
| 75 | +246 |
- se_fit = (interval != "none"),+ } |
||
| 76 | -+ | |||
| 247 | +20x |
- type.residuals = c("response", "pearson", "normalized"), # nolint
+ assert(+ |
+ ||
| 248 | +20x | +
+ check_subset(parm, pnames),+ |
+ ||
| 249 | +20x | +
+ check_integerish(parm, lower = 1L, upper = length(cf)) |
||
| 77 | +250 |
- ...) {
+ ) |
||
| 78 | -9x | +251 | +2x |
- type.residuals <- match.arg(type.residuals) # nolint+ if (is.numeric(parm)) parm <- pnames[parm] |
| 79 | -9x | +252 | +18x |
- resid_df <- NULL+ assert_number(level, lower = 0, upper = 1) |
| 80 | -9x | +253 | +18x |
- if (is.null(newdata)) {
+ a <- (1 - level) / 2 |
| 81 | -4x | +254 | +18x |
- newdata <- stats::get_all_vars(x, data = stats::na.omit(x$data))+ pct <- paste(format(100 * c(a, 1 - a), trim = TRUE, scientific = FALSE, digits = 3), "%") |
| 82 | -4x | +255 | +18x |
- resid_df <- data.frame(+ coef_table <- h_coef_table(object) |
| 83 | -4x | +256 | +18x |
- .rownames = rownames(newdata),+ df <- coef_table[parm, "df"] |
| 84 | -4x | +257 | +18x |
- .resid = unname(residuals(x, type = type.residuals))+ ses <- coef_table[parm, "Std. Error"] |
| 85 | -+ | |||
| 258 | +18x |
- )+ fac <- stats::qt(a, df = df) |
||
| 86 | -+ | |||
| 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) |
||
| 87 | -9x | +262 | +18x |
- interval <- match.arg(interval)+ ci |
| 88 | +263 |
-
+ } |
||
| 89 | -9x | +
| 1 | +
- tbl <- h_newdata_add_pred(+ #' Dynamic Registration for Package Interoperability |
|||
| 90 | -9x | +|||
| 2 | +
- x,+ #' |
|||
| 91 | -9x | +|||
| 3 | +
- newdata = newdata,+ #' @seealso See `vignette("xtending", package = "emmeans")` for background.
|
|||
| 92 | -9x | +|||
| 4 | +
- se_fit = se_fit,+ #' @keywords internal |
|||
| 93 | -9x | +|||
| 5 | +
- interval = interval,+ #' @noRd |
|||
| 94 | +6 |
- ...+ .onLoad <- function(libname, pkgname) { # nolint
|
||
| 95 | -+ | |||
| 7 | +! |
- )+ if (!h_tmb_version_sufficient()) {
|
||
| 96 | -9x | +|||
| 8 | +! |
- if (!is.null(resid_df)) {
+ msg <- paste( |
||
| 97 | -4x | +|||
| 9 | +! |
- tbl <- merge(tbl, resid_df, by = ".rownames")+ "TMB below version 1.9.15 has been used to compile the mmrm package.", |
||
| 98 | -4x | +|||
| 10 | +! |
- tbl$.rownames <- as.numeric(tbl$.rownames)+ "Reproducible model fits are not guaranteed.", |
||
| 99 | -4x | +|||
| 11 | +! |
- tbl <- tbl[order(tbl$.rownames), , drop = FALSE]+ "Please consider recompiling the package with TMB version 1.9.15 or higher." |
||
| 100 | +12 |
- }+ ) |
||
| 101 | -9x | +|||
| 13 | +! |
- tibble::as_tibble(tbl)+ warning(msg, call. = FALSE) |
||
| 102 | +14 |
- }+ } |
||
| 103 | +15 | |||
| 104 | -+ | |||
| 16 | +! |
- #' Extract `tibble` with Confidence Intervals and Term Names+ register_on_load( |
||
| 105 | -+ | |||
| 17 | +! |
- #'+ "emmeans", c("1.6", NA),
|
||
| 106 | -+ | |||
| 18 | +! |
- #' This is used in [tidy.mmrm()].+ callback = function() emmeans::.emm_register("mmrm", pkgname),
|
||
| 107 | -+ | |||
| 19 | +! |
- #'+ message = "mmrm() registered as emmeans extension" |
||
| 108 | +20 |
- #' @param x (`mmrm`)\cr fit object.+ ) |
||
| 109 | +21 |
- #' @param ... passed to [stats::confint()], hence not used at the moment.+ |
||
| 110 | -+ | |||
| 22 | +! |
- #'+ register_on_load( |
||
| 111 | -+ | |||
| 23 | +! |
- #' @return A `tibble` with `term`, `conf.low`, `conf.high` columns.+ "parsnip", c("1.1.0", NA),
|
||
| 112 | -+ | |||
| 24 | +! |
- #'+ callback = parsnip_add_mmrm, |
||
| 113 | -+ | |||
| 25 | +! |
- #' @keywords internal+ message = emit_tidymodels_register_msg |
||
| 114 | +26 |
- h_tbl_confint_terms <- function(x, ...) {
+ ) |
||
| 115 | -8x | +|||
| 27 | +! |
- df <- stats::confint(x, ...)+ register_on_load( |
||
| 116 | -8x | +|||
| 28 | +! |
- tbl <- tibble::as_tibble(df, rownames = "term", .name_repair = "minimal")+ "car", c("3.1.2", NA),
|
||
| 117 | -8x | +|||
| 29 | +! |
- names(tbl) <- c("term", "conf.low", "conf.high")
+ callback = car_add_mmrm, |
||
| 118 | -8x | +|||
| 30 | +! |
- tbl+ message = "mmrm() registered as car::Anova extension" |
||
| 119 | +31 |
- }+ ) |
||
| 120 | +32 |
-
+ } |
||
| 121 | +33 |
- #' Add Prediction Results to New Data+ |
||
| 122 | +34 |
- #'+ #' Helper Function for Registering Functionality With Suggests Packages |
||
| 123 | +35 |
- #' This is used in [augment.mmrm()].+ #' |
||
| 124 | +36 |
- #'+ #' @inheritParams check_package_version |
||
| 125 | +37 |
- #' @param x (`mmrm`)\cr fit.+ #' |
||
| 126 | +38 |
- #' @param newdata (`data.frame`)\cr data to predict.+ #' @param callback (`function(...) ANY`)\cr a callback to execute upon package |
||
| 127 | +39 |
- #' @param se_fit (`flag`)\cr whether to return standard error of prediction,+ #' load. Note that no arguments are passed to this function. Any necessary |
||
| 128 | +40 |
- #' can only be used when `interval` is not "none".+ #' data must be provided upon construction. |
||
| 129 | +41 |
- #' @param interval (`string`)\cr type of interval.+ #' |
||
| 130 | +42 |
- #' @param ... passed to [predict.mmrm_tmb()].+ #' @param message (`NULL` or `string`)\cr an optional message to print after |
||
| 131 | +43 |
- #'+ #' the callback is executed upon successful registration. |
||
| 132 | +44 |
- #' @return The `newdata` as a `tibble` with additional columns `.fitted`,+ #' |
||
| 133 | +45 |
- #' `.lower`, `.upper` (if interval is not `none`) and `.se.fit` (if `se_fit`+ #' @return A logical (invisibly) indicating whether registration was successful. |
||
| 134 | +46 |
- #' requested).+ #' If not, a onLoad hook was set for the next time the package is loaded. |
||
| 135 | +47 |
#' |
||
| 136 | +48 |
#' @keywords internal |
||
| 137 | -- |
- h_newdata_add_pred <- function(x,- |
- ||
| 138 | +49 |
- newdata,+ register_on_load <- function(pkg, |
||
| 139 | +50 |
- se_fit,+ ver = c(NA_character_, NA_character_), |
||
| 140 | +51 |
- interval,+ callback, |
||
| 141 | +52 |
- ...) {
- |
- ||
| 142 | -13x | -
- assert_class(x, "mmrm")+ message = NULL) {
|
||
| 143 | -13x | +53 | +4x |
- assert_data_frame(newdata)+ if (isNamespaceLoaded(pkg) && check_package_version(pkg, ver)) {
|
| 144 | -13x | +54 | +3x |
- assert_flag(se_fit)+ callback() |
| 145 | -13x | +55 | +2x |
- assert_string(interval)+ if (is.character(message)) packageStartupMessage(message) |
| 146 | -13x | +56 | +1x |
- if (interval == "none") {
+ if (is.function(message)) packageStartupMessage(message()) |
| 147 | -7x | +57 | +3x |
- assert_false(se_fit)+ return(invisible(TRUE)) |
| 148 | +58 |
} |
||
| 149 | +59 | |||
| 150 | -12x | +60 | +1x |
- tbl <- h_df_to_tibble(newdata)+ setHook( |
| 151 | -12x | +61 | +1x |
- pred_results <- predict(+ packageEvent(pkg, event = "onLoad"), |
| 152 | -12x | +62 | +1x |
- x,+ action = "append", |
| 153 | -12x | +63 | +1x |
- newdata = newdata,+ function(...) {
|
| 154 | -12x | +|||
| 64 | +! |
- na.action = stats::na.pass,+ register_on_load( |
||
| 155 | -12x | +|||
| 65 | +! |
- se.fit = se_fit,+ pkg = pkg, |
||
| 156 | -12x | +|||
| 66 | +! |
- interval = interval,+ ver = ver,+ |
+ ||
| 67 | +! | +
+ callback = callback,+ |
+ ||
| 68 | +! | +
+ message = message |
||
| 157 | +69 |
- ...+ ) |
||
| 158 | +70 |
- )+ } |
||
| 159 | -12x | +|||
| 71 | +
- if (interval == "none") {
+ ) |
|||
| 160 | -6x | +|||
| 72 | +
- assert_numeric(pred_results)+ |
|||
| 161 | -6x | +73 | +1x |
- tbl$.fitted <- unname(pred_results)+ invisible(FALSE) |
| 162 | +74 |
- } else {
- |
- ||
| 163 | -6x | -
- assert_matrix(pred_results)+ } |
||
| 164 | -6x | +|||
| 75 | +
- tbl$.fitted <- unname(pred_results[, "fit"])+ |
|||
| 165 | -6x | +|||
| 76 | +
- tbl$.lower <- unname(pred_results[, "lwr"])+ #' Check Suggested Dependency Against Version Requirements |
|||
| 166 | -6x | +|||
| 77 | +
- tbl$.upper <- unname(pred_results[, "upr"])+ #' |
|||
| 167 | +78 |
- }+ #' @param pkg (`string`)\cr package name. |
||
| 168 | -12x | +|||
| 79 | +
- if (se_fit) {
+ #' @param ver (`character`)\cr of length 2 whose elements can be provided to |
|||
| 169 | -5x | +|||
| 80 | +
- tbl$.se.fit <- unname(pred_results[, "se"])+ #' [numeric_version()], representing a minimum and maximum (inclusive) version |
|||
| 170 | +81 |
- }+ #' requirement for interoperability. When `NA`, no version requirement is |
||
| 171 | -12x | +|||
| 82 | +
- tbl+ #' imposed. Defaults to no version requirement. |
|||
| 172 | +83 |
- }+ #' |
||
| 173 | +84 |
-
+ #' @return A logical (invisibly) indicating whether the loaded package meets |
||
| 174 | +85 |
- #' Coerce a Data Frame to a `tibble`+ #' the version requirements. A warning is emitted otherwise. |
||
| 175 | +86 |
#' |
||
| 176 | +87 |
- #' This is used in [h_newdata_add_pred()].+ #' @keywords internal |
||
| 177 | +88 |
- #'+ check_package_version <- function(pkg, ver = c(NA_character_, NA_character_)) {
|
||
| 178 | -+ | |||
| 89 | +7x |
- #' @details This is only a thin wrapper around [tibble::as_tibble()], except+ assert_character(ver, len = 2L) |
||
| 179 | -+ | |||
| 90 | +6x |
- #' giving a useful error message and it checks for `rownames` and adds them+ pkg_ver <- utils::packageVersion(pkg) |
||
| 180 | -+ | |||
| 91 | +6x |
- #' as a new column `.rownames` if they are not just a numeric sequence as+ ver <- numeric_version(ver, strict = FALSE) |
||
| 181 | +92 |
- #' per the [tibble::has_rownames()] decision.+ |
||
| 182 | -+ | |||
| 93 | +6x |
- #'+ warn_version <- function(pkg, pkg_ver, ver) {
|
||
| 183 | -+ | |||
| 94 | +2x |
- #' @param data (`data.frame`)\cr what to coerce.+ ver_na <- is.na(ver) |
||
| 184 | -+ | |||
| 95 | +2x |
- #'+ warning(sprintf( |
||
| 185 | -+ | |||
| 96 | +2x |
- #' @return The `data` as a `tibble`, potentially with a `.rownames` column.+ "Cannot register mmrm for use with %s (v%s). Version %s required.", |
||
| 186 | -+ | |||
| 97 | +2x |
- #'+ pkg, pkg_ver, |
||
| 187 | -+ | |||
| 98 | +2x |
- #' @keywords internal+ if (!any(ver_na)) {
|
||
| 188 | -+ | |||
| 99 | +! |
- h_df_to_tibble <- function(data) {
+ sprintf("%s to %s", ver[1], ver[2])
|
||
| 189 | -15x | +100 | +2x |
- tryCatch(tbl <- tibble::as_tibble(data), error = function(cnd) {
+ } else if (ver_na[2]) {
|
| 190 | +101 | 1x |
- stop("Could not coerce data to `tibble`. Try explicitly passing a",
+ paste0(">= ", ver[1])
|
|
| 191 | -1x | +102 | +2x |
- "dataset to either the `data` or `newdata` argument.",+ } else if (ver_na[1]) {
|
| 192 | +103 | 1x |
- call. = FALSE+ paste0("<= ", ver[2])
|
|
| 193 | +104 |
- )+ } |
||
| 194 | +105 |
- })+ )) |
||
| 195 | -14x | +|||
| 106 | +
- if (tibble::has_rownames(data)) {
+ }+ |
+ |||
| 107 | ++ | + | ||
| 196 | -5x | +108 | +6x |
- tbl <- tibble::add_column(tbl, .rownames = rownames(data), .before = TRUE)+ if (identical(pkg_ver < ver[1], TRUE) || identical(pkg_ver > ver[2], TRUE)) {
|
| 197 | -+ | |||
| 109 | +2x |
- }+ warn_version(pkg, pkg_ver, ver) |
||
| 198 | -14x | +110 | +2x |
- tbl+ return(invisible(FALSE)) |
| 199 | +111 |
- }+ } |
| 1 | +112 |
- #' Calculation of Residual Degrees of Freedom for One-Dimensional Contrast+ + |
+ |
| 113 | +4x | +
+ invisible(TRUE) |
|
| 2 | +114 |
- #'+ } |
|
| 3 | +115 |
- #' @description Used in [df_1d()] if method is+ |
|
| 4 | +116 |
- #' "Residual".+ #' Format a Message to Emit When Tidymodels is Loaded |
|
| 5 | +117 |
#' |
|
| 6 | +118 |
- #' @inheritParams h_df_1d_sat+ #' @return A character message to emit. Either a ansi-formatted cli output if |
|
| 7 | +119 |
- #' @inherit h_df_1d_sat return+ #' package 'cli' is available or a plain-text message otherwise. |
|
| 8 | +120 | ++ |
+ #'+ |
+
| 121 |
#' @keywords internal |
||
| 9 | +122 |
- h_df_1d_res <- function(object, contrast) {
+ emit_tidymodels_register_msg <- function() {
|
|
| 10 | +123 | 1x |
- assert_class(object, "mmrm")+ pkg <- utils::packageName() |
| 11 | +124 | 1x |
- assert_numeric(contrast, len = length(component(object, "beta_est")))+ ver <- utils::packageVersion(pkg) |
| 12 | +125 | ||
| 13 | +126 | 1x |
- df <- component(object, "n_obs") - length(component(object, "beta_est"))- |
-
| 14 | -- |
-
+ if (isTRUE(getOption("tidymodels.quiet"))) {
|
|
| 15 | -1x | +||
| 127 | +! |
- h_test_1d(object, contrast, df)+ return() |
|
| 16 | +128 |
- }+ } |
|
| 17 | +129 | ||
| 18 | +130 |
- #' Calculation of Residual Degrees of Freedom for Multi-Dimensional Contrast+ # if tidymodels is attached, cli packages come as a dependency |
|
| 19 | -+ | ||
| 131 | +1x |
- #'+ has_cli <- requireNamespace("cli", quietly = TRUE)
|
|
| 20 | -+ | ||
| 132 | +1x |
- #' @description Used in [df_md()] if method is "Residual".+ if (has_cli) {
|
|
| 21 | +133 |
- #'+ # unfortunately, cli does not expose many formatting tools for emitting |
|
| 22 | +134 |
- #' @inheritParams h_df_md_sat+ # messages (only via conditions to stderr) which can't be suppressed using |
|
| 23 | +135 |
- #' @inherit h_df_md_sat return+ # suppressPackageStartupMessages() so formatting must be done adhoc, |
|
| 24 | +136 |
- #' @keywords internal+ # similar to how it's done in {tidymodels} R/attach.R
|
|
| 25 | -+ | ||
| 137 | +1x |
- h_df_md_res <- function(object, contrast) {
+ paste0( |
|
| 26 | +138 | 1x |
- assert_class(object, "mmrm")+ cli::rule( |
| 27 | +139 | 1x |
- assert_matrix(contrast, mode = "numeric", any.missing = FALSE, ncols = length(component(object, "beta_est")))+ left = cli::style_bold("Model Registration"),
+ |
+
| 140 | +1x | +
+ right = paste(pkg, ver) |
|
| 28 | +141 |
-
+ ), |
|
| 29 | +142 | 1x |
- df <- component(object, "n_obs") - length(component(object, "beta_est"))+ "\n", |
| 30 | -+ | ||
| 143 | +1x |
-
+ cli::col_green(cli::symbol$tick), " ", |
|
| 31 | +144 | 1x |
- h_test_md(object, contrast, df)+ cli::col_blue("mmrm"), "::", cli::col_green("mmrm()")
|
| 32 | +145 | ++ |
+ )+ |
+
| 146 | ++ |
+ } else {
+ |
+ |
| 147 | +! | +
+ paste0(pkg, "::mmrm() registered for use with tidymodels")+ |
+ |
| 148 | ++ |
+ }+ |
+ |
| 149 |
}@@ -33324,14 +33136,14 @@ mmrm coverage - 97.05% |
| 1 |
- #' Register `mmrm` For Use With `tidymodels`+ #' Extract Formula Terms used for Covariance Structure Definition |
||
| 3 |
- #' @inheritParams base::requireNamespace+ #' @param f (`formula`)\cr a formula from which covariance terms should be |
||
| 4 |
- #' @return A logical value indicating whether registration was successful.+ #' extracted. |
||
| 6 |
- #' @details We can use `parsnip::show_model_info("linear_reg")` to check the
+ #' @return A list of covariance structure expressions found in `f`. |
||
| 7 |
- #' registration with `parsnip` and thus the wider `tidymodels` ecosystem.+ #' |
||
| 8 |
- #'+ #' @importFrom stats terms |
||
| 10 |
- parsnip_add_mmrm <- function(quietly = FALSE) {
+ h_extract_covariance_terms <- function(f) {
|
||
| 11 | -1x | +291x |
- if (!requireNamespace("parsnip", quietly = quietly)) {
+ specials <- cov_types(c("abbr", "habbr"))
|
| 12 | -! | +291x |
- return(FALSE)+ terms <- stats::terms(formula_rhs(f), specials = specials) |
| 13 | -+ | 291x |
- }+ covariance_terms <- Filter(length, attr(terms, "specials")) |
| 14 | -+ | 291x |
-
+ variables <- attr(terms, "variables") |
| 15 | -1x | +291x |
- parsnip::set_model_engine(+ lapply(covariance_terms, function(i) variables[[i + 1]]) |
| 16 | -1x | +
- model = "linear_reg",+ } |
|
| 17 | -1x | +
- eng = "mmrm",+ |
|
| 18 | -1x | +
- mode = "regression"+ #' Drop Formula Terms used for Covariance Structure Definition |
|
| 19 |
- )+ #' |
||
| 20 |
-
+ #' @param f (`formula`)\cr a formula from which covariance terms should be |
||
| 21 | -1x | +
- parsnip::set_dependency(+ #' dropped. |
|
| 22 | -1x | +
- pkg = "mmrm",+ #' |
|
| 23 | -1x | +
- model = "linear_reg",+ #' @return The formula without accepted covariance terms. |
|
| 24 | -1x | +
- eng = "mmrm",+ #' |
|
| 25 | -1x | +
- mode = "regression"+ #' @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 | -1x | +
- parsnip::set_encoding(+ #' @keywords internal |
|
| 29 | -1x | +
- model = "linear_reg",+ h_drop_covariance_terms <- function(f) {
|
|
| 30 | -1x | +274x |
- eng = "mmrm",+ specials <- cov_types(c("abbr", "habbr"))
|
| 31 | -1x | +
- mode = "regression",+ |
|
| 32 | -1x | +274x |
- options = list(+ terms <- stats::terms(f, specials = specials) |
| 33 | -1x | +274x |
- predictor_indicators = "none",+ covariance_terms <- Filter(Negate(is.null), attr(terms, "specials")) |
| 34 | -1x | +
- compute_intercept = FALSE,+ |
|
| 35 | -1x | +
- remove_intercept = FALSE,+ # if no covariance terms were found, return original formula |
|
| 36 | -1x | +274x |
- allow_sparse_x = TRUE+ if (length(covariance_terms) == 0) {
|
| 37 | -+ | 6x |
- )+ return(f) |
| 38 |
- )+ } |
||
| 39 | -+ | 268x |
-
+ if (length(f) != 3) {
|
| 40 | 1x |
- parsnip::set_fit(+ update_str <- "~ . -" |
|
| 41 | -1x | +
- model = "linear_reg",+ } else {
|
|
| 42 | -1x | +267x |
- eng = "mmrm",+ update_str <- ". ~ . -" |
| 43 | -1x | +
- mode = "regression",+ } |
|
| 44 | -1x | +268x |
- value = list(+ stats::update( |
| 45 | -1x | +268x |
- interface = "formula",+ f, |
| 46 | -1x | +268x |
- protect = c("formula", "data", "weights"),
+ stats::as.formula(paste(update_str, deparse(attr(terms, "variables")[[covariance_terms[[1]] + 1]]))) |
| 47 | -1x | +
- data = c(formula = "formula", data = "data", weights = "weights"),+ ) |
|
| 48 | -1x | +
- func = c(pkg = "mmrm", fun = "mmrm"),+ } |
|
| 49 | -1x | +
- defaults = list()+ |
|
| 50 |
- )+ #' Add Individual Covariance Variables As Terms to Formula |
||
| 51 |
- )+ #' |
||
| 52 |
-
+ #' @param f (`formula`)\cr a formula to which covariance structure terms should |
||
| 53 | -1x | +
- parsnip::set_pred(+ #' be added. |
|
| 54 | -1x | +
- model = "linear_reg",+ #' @param covariance (`cov_struct`)\cr a covariance structure object from which |
|
| 55 | -1x | +
- eng = "mmrm",+ #' additional variables should be sourced. |
|
| 56 | -1x | +
- mode = "regression",+ #' |
|
| 57 | -1x | +
- type = "numeric",+ #' @return A new formula with included covariance terms. |
|
| 58 | -1x | +
- value = parsnip::pred_value_template(+ #' |
|
| 59 |
- # This is boilerplate.+ #' @details [stats::update()] is used to append the covariance structure and the environment |
||
| 60 | -1x | +
- func = c(fun = "predict"),+ #' attribute will not be changed. This ensures the returned formula and the input formula |
|
| 61 | -1x | +
- object = quote(object$fit),+ #' have the same environment. |
|
| 62 | -1x | +
- newdata = quote(new_data)+ #' |
|
| 63 |
- )+ #' @keywords internal |
||
| 64 |
- )+ h_add_covariance_terms <- function(f, covariance) {
|
||
| 65 | -+ | 272x |
-
+ cov_terms <- with(covariance, c(subject, visits, group)) |
| 66 | -1x | +266x |
- parsnip::set_pred(+ cov_terms <- paste(cov_terms, collapse = " + ") |
| 67 | -1x | +266x |
- model = "linear_reg",+ stats::update(f, stats::as.formula(paste(". ~ . + ", cov_terms)))
|
| 68 | -1x | +
- eng = "mmrm",+ } |
|
| 69 | -1x | +
- mode = "regression",+ |
|
| 70 |
- # This type allows to pass arguments via `opts` to `parsnip::predict.model_fit`.+ #' Add Formula Terms with Character |
||
| 71 | -1x | +
- type = "raw",+ #' |
|
| 72 | -1x | +
- value = parsnip::pred_value_template(+ #' Add formula terms from the original formula with character representation. |
|
| 73 |
- # This is boilerplate.+ #' |
||
| 74 | -1x | +
- func = c(fun = "predict"),+ #' @param f (`formula`)\cr a formula to be updated. |
|
| 75 | -1x | +
- object = quote(object$fit),+ #' @param adds (`character`)\cr representation of elements to be added. |
|
| 76 | -1x | +
- newdata = quote(new_data)+ #' @param drop_response (`flag`)\cr whether response should be dropped. |
|
| 77 |
- # We don't specify additional argument defaults here since otherwise+ #' |
||
| 78 |
- # the user is not able to change them (they will be fixed).+ #' @details Elements in `adds` will be added from the formula, while the environment |
||
| 79 |
- )+ #' of the formula is unchanged. If `adds` is `NULL` or `character(0)`, the formula is |
||
| 80 |
- )+ #' unchanged. |
||
| 81 |
-
+ #' @return A new formula with elements in `drops` removed. |
||
| 82 | -1x | +
- TRUE+ #' |
|
| 83 | + |
+ #' @keywords internal+ |
+ |
| 84 | ++ |
+ h_add_terms <- function(f, adds, drop_response = FALSE) {
+ |
+ |
| 85 | +599x | +
+ assert_character(adds, null.ok = TRUE)+ |
+ |
| 86 | +599x | +
+ if (length(adds) > 0L) {
+ |
+ |
| 87 | +321x | +
+ add_terms <- stats::as.formula(sprintf(". ~ . + %s", paste(adds, collapse = "+")))
+ |
+ |
| 88 | +321x | +
+ f <- stats::update(f, add_terms)+ |
+ |
| 89 | ++ |
+ }+ |
+ |
| 90 | +599x | +
+ if (drop_response && length(f) == 3L) {
+ |
+ |
| 91 | +35x | +
+ f[[2]] <- NULL+ |
+ |
| 92 | ++ |
+ }+ |
+ |
| 93 | +599x | +
+ f+ |
+ |
| 94 | +
} |
@@ -35259,6 +35148,236 @@
| 1 | ++ |
+ #' Calculation of Residual Degrees of Freedom for One-Dimensional Contrast+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description Used in [df_1d()] if method is+ |
+
| 4 | ++ |
+ #' "Residual".+ |
+
| 5 | ++ |
+ #'+ |
+
| 6 | ++ |
+ #' @inheritParams h_df_1d_sat+ |
+
| 7 | ++ |
+ #' @inherit h_df_1d_sat return+ |
+
| 8 | ++ |
+ #' @keywords internal+ |
+
| 9 | ++ |
+ h_df_1d_res <- function(object, contrast) {
+ |
+
| 10 | +1x | +
+ assert_class(object, "mmrm")+ |
+
| 11 | +1x | +
+ assert_numeric(contrast, len = length(component(object, "beta_est")))+ |
+
| 12 | ++ | + + | +
| 13 | +1x | +
+ df <- component(object, "n_obs") - length(component(object, "beta_est"))+ |
+
| 14 | ++ | + + | +
| 15 | +1x | +
+ h_test_1d(object, contrast, df)+ |
+
| 16 | ++ |
+ }+ |
+
| 17 | ++ | + + | +
| 18 | ++ |
+ #' Calculation of Residual Degrees of Freedom for Multi-Dimensional Contrast+ |
+
| 19 | ++ |
+ #'+ |
+
| 20 | ++ |
+ #' @description Used in [df_md()] if method is "Residual".+ |
+
| 21 | ++ |
+ #'+ |
+
| 22 | ++ |
+ #' @inheritParams h_df_md_sat+ |
+
| 23 | ++ |
+ #' @inherit h_df_md_sat return+ |
+
| 24 | ++ |
+ #' @keywords internal+ |
+
| 25 | ++ |
+ h_df_md_res <- function(object, contrast) {
+ |
+
| 26 | +1x | +
+ assert_class(object, "mmrm")+ |
+
| 27 | +1x | +
+ assert_matrix(contrast, mode = "numeric", any.missing = FALSE, ncols = length(component(object, "beta_est")))+ |
+
| 28 | ++ | + + | +
| 29 | +1x | +
+ df <- component(object, "n_obs") - length(component(object, "beta_est"))+ |
+
| 30 | ++ | + + | +
| 31 | +1x | +
+ h_test_md(object, contrast, df)+ |
+
| 32 | ++ |
+ }+ |
+