From 782d08b38409efe20059efcf072ad12c323aec80 Mon Sep 17 00:00:00 2001 From: Guanya Peng Date: Wed, 27 Apr 2022 20:54:36 +0200 Subject: [PATCH 01/84] add change function and lst2df function to utility --- R/utilities.R | 43 ++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 40 insertions(+), 3 deletions(-) diff --git a/R/utilities.R b/R/utilities.R index cd4fa8cb0..d5e0fa499 100644 --- a/R/utilities.R +++ b/R/utilities.R @@ -513,7 +513,44 @@ as_dataframe <- function(x) { return(x2) } +#' Change a function +#' +#' A wrapper to change function with a modified return value. Specifically change a function returned named element based on given name and method +#' @param f A function to be changed +#' @param what A character representing name of the element to be changed from function's return +#' @param how A function specifying how to change the element +#' @return A function with modified return value +#' @example +#' pool <- change(pool, 'pars', function(...) lst2df(..., 'visit')) +change <- function(f, what, how) { + force(f) + function(...) { + out <- f(...) + tryCatch( + expr = { + out[[what]] <- how(out[[what]]) + }, + error = function(e) { + message(paste("Error when changing", what, ':', e)) + }, + finally = { + return(out) + } + ) + } +} - - - +#' Convert nested list to data frame +#' +#' Convert a nested list to a data frame with specified group id and additional processer for the group +#' @param lst A nested list +#' @param id A group ID +#' @param processor A function to process group data +lst2df <- function(lst, id, processor = function(...) summarise(..., ci = toString(ci), across(), .groups = 'drop')) { + out <- bind_rows(lst, .id = id) + if (is.null(processor)) out + else out %>% + group_by(.data[[id]]) %>% + processor %>% + ungroup() +} From 670d82e4ec1efe4ca8ac921de76e145399a8cca5 Mon Sep 17 00:00:00 2001 From: Guanya Peng Date: Wed, 27 Apr 2022 21:57:07 +0200 Subject: [PATCH 02/84] wrap pool to return data.frame instead of list --- R/pool.R | 1 + 1 file changed, 1 insertion(+) diff --git a/R/pool.R b/R/pool.R index 98eb74524..4a415a3e8 100644 --- a/R/pool.R +++ b/R/pool.R @@ -103,6 +103,7 @@ pool <- function( return(ret) } +pool <- change(pool, 'pars', function(...) lst2df(..., 'visit')) #' Expected Pool Components #' From 4150c76d8a4759d1033f88ffef89c8d67e3b793a Mon Sep 17 00:00:00 2001 From: Guanya Peng Date: Fri, 6 May 2022 10:03:55 +0200 Subject: [PATCH 03/84] use analysis_results object in ancova instead of named list --- R/ancova.R | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/R/ancova.R b/R/ancova.R index 57a08af44..75eca82f1 100644 --- a/R/ancova.R +++ b/R/ancova.R @@ -139,8 +139,7 @@ ancova <- function(data, vars, visits = NULL, weights = c("proportional", "equal visits, function(x) { data2 <- data[data[[visit]] == x, ] - res <- ancova_single(data2, outcome, group, covariates, weights) - names(res) <- paste0(names(res), "_", x) + res <- ancova_single(data2, outcome, group, covariates, weights, x) return(res) } ) @@ -174,7 +173,7 @@ ancova <- function(data, vars, visits = NULL, weights = c("proportional", "equal #' } #' @seealso [ancova()] #' @importFrom stats lm coef vcov df.residual -ancova_single <- function(data, outcome, group, covariates, weights = c("proportional", "equal")) { +ancova_single <- function(data, outcome, group, covariates, weights = c("proportional", "equal"), ...) { weights <- match.arg(weights) assert_that( @@ -201,13 +200,15 @@ ancova_single <- function(data, outcome, group, covariates, weights = c("proport lsm1 <- do.call(lsmeans, args) x <- list( - trt = list( + analysis_result( + name = 'trt', est = coef(mod)[[group]], se = sqrt(vcov(mod)[group, group]), - df = df.residual(mod) + df = df.residual(mod), + meta = add_meta(...) ), - lsm_ref = lsm0, - lsm_alt = lsm1 + as_analysis_result(lsm0, name = 'lsm_ref'), + as_analysis_result(lsm1, name = 'lsm_alt') ) return(x) } From 6bf45380f92e3d09380c88e796f71f0229a55458 Mon Sep 17 00:00:00 2001 From: Guanya Peng Date: Fri, 6 May 2022 14:53:22 +0200 Subject: [PATCH 04/84] update analysis function to handle analysis_result object --- R/analyse.R | 195 ++++++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 191 insertions(+), 4 deletions(-) diff --git a/R/analyse.R b/R/analyse.R index b313d74b5..bf2810193 100644 --- a/R/analyse.R +++ b/R/analyse.R @@ -341,6 +341,16 @@ print.analysis <- function(x, ...) { n_samp ) + info <- function(where, what) { + if (all(length(where) != 0, + !is.null(where[[1]]), + rlang::has_name(where[[1]], what))) { + sapply(where, `[[`, what) + } else { + paste("No", what, "info") + } + } + string <- c( "", "Analysis Object", @@ -349,7 +359,7 @@ print.analysis <- function(x, ...) { sprintf("Analysis Function: %s", x$fun_name), sprintf("Delta Applied: %s", !is.null(x$delta)), "Analysis Estimates:", - sprintf(" %s", names(x$results[[1]])), + sprintf(" %s", info(x$results[[1]], 'name')), "" ) @@ -440,9 +450,9 @@ validate_analyse_pars <- function(results, pars) { ) assert_that( - length(names(results[[1]])) != 0, - all(vapply(results, function(x) !is.null(names(x)) & all(names(x) != ""), logical(1))), - msg = "Individual analysis results must be named lists" + length(results[[1]]) != 0, + all(vapply(results, function(Xs) all(vapply(Xs, function(X) is.analysis_result(X), logical(1))), logical(1))), + msg = "Individual analysis results must be type of analysis_result" ) results_names <- lapply(results, function(x) unique(names(x))) @@ -487,3 +497,180 @@ validate_analyse_pars <- function(results, pars) { return(invisible(TRUE)) } + +#' Constructor of analysis result +#' +#' Construct an analysis result class object whose base type is a list +#' +#' @param name A character variable for the group name +#' @param est A double type numeric variable as the estimate +#' @param se A double type numeric variable as the standard error +#' @param df An integer type of numeric variable +#' @param meta A list type of variable as meta information +#' @details +#' - `se` must be numeric values greater or equal to 0 +#' - `meta` is optional +#' @return An object of "analysis_result" class +#' @examples +#' \dontrun{ +#' ana_res_obj <- analysis_result(name = 'trt', est = 1, se = 2, df = as.integer(3), meta = list(visit = 1)) +#' } +#' @export +analysis_result <- function (name = character(), + est = double(), + se = double(), + df = integer(), + meta = NULL) { + + # constraints + stopifnot(is.character(name)) + stopifnot(is.double(est)) + stopifnot(is.double(se)) + stopifnot(is.integer(df) | is.double(df)) + stopifnot(is.list(meta) | is.null(meta)) + + # validators + if (se < 0) stop("SE must great or equal to 0", .call = FALSE) + + value <- list(name = name, + est = est, + se = se, + df = df) + + if (!is.null(meta)) { + value[['meta']] <- meta + } + + structure( + value, + meta = meta, + class = "analysis_result" + ) +} + +#' Convert object to analysis result class +#' +#' @param x The object to be converted to analysis_result class +#' @param ... Optional keywords parameters for adding missing elements to the object +#' @return An "analysis_result" class object with optionally updated elements +#' @examples +#' \dontrun{ +#' ana_res_obj <- as_analysis_result(list(est = 1, se = 2, df = 3), name = 'trt') +#' } +#' @export +as_analysis_result <- function(x, ...) { + dots <- rlang::enquos(...) + + # coercion with generic function + x <- as.list(x) + + present <- ana_name_chker('present') + + names_not_presented <- names(present(x))[!present(x)] + + # update list if required elements are not presented or if the element is 'meta' + updated_x <- x + for (i in seq_along(dots)) { + name <- names(dots)[[i]] + dot <- dots[[i]] + print(name) + print(dot) + print('---') + + if (is.element(name, names_not_presented) | name == 'meta') { + updated_x[[name]] <- rlang::eval_tidy(dot) + } + } + + # after updating check if all required elements are presented + stopifnot(all(present(updated_x))) + + # keep only required elements and put them in defined order + if (length(names(updated_x)) < length(ana_name_chker('all'))) { + ordered_x <- updated_x[ana_name_chker('musthave')] + } else { + ordered_x <- updated_x[ana_name_chker('all')] + } + + as_class(ordered_x, "analysis_result") +} + +#' Create name checkers with message passing dispatch +#' +#' @param ... Character vectors for the reference to check against +#' @param optional Character vector of optional name. Default: NULL +#' @return A constructor to create checker functions with message passing dispatch +namechecker <- function(..., optional = NULL) { + + # compile the musthave list at the top level so that easier to maintain and update + musthave <- c(...) + + # message passing as a dispatch + function(msg) { + + # generic function to check if elements in list X exist in Y + XsInYs <- function(x, y) vapply(x, purrr::partial(is.element, ... =, y), logical(1)) + + # generic wrapper to swap oder of formal parameter of binary function + swap <- function(f) { + function(x, y) f(y, x) + } + + extend <- function(v1, v2) { + if(is.null(v2)) v1 + else append(v1, v2) + } + + # higher-order function to create template for checkers/validators + chker_template <- function(musthave, wrapper=identity, f = XsInYs, .optional = optional) { + function(...) { + wrapper(f)(extend(musthave, .optional), names(...)) + } + } + + # checker to check if elements in musthave present in the object's name + # checker does not check against optional names. Only names in musthave have to be presented in the object + present <- chker_template(musthave, .optional = NULL) + + # validator to validate if object's name belongs to musthave + optional names (simply swap the order of arguments from present) + validate <- chker_template(musthave, swap) + + dispatch <- list( + present = present, + validate = validate, + musthave = musthave, + optional = optional, + all = append(musthave, optional) + ) + + dispatch[[msg]] + } +} + +#' Name checker for analysis function +#' +#' @param msg Character vector representing which checker to return +ana_name_chker <- namechecker('name', 'est', 'se', 'df', optional = 'meta') + +#' Check if an object is in class analysis_result +#' +#' @param x Object to be checked +#' @return Logical value TRUE/FALSE +#' @details +#' This function does not only check the class attribute of the object. +#' It also checks constraints of the names of the elements in the list +#' @importFrom dplyr %in% +#' @export +is.analysis_result <- function(x) { + + has_attribute <- function(x, which){ + which %in% names(attributes(x)) + } + + all( + has_attribute(x, 'class'), + is.object(x), + attr(x, 'class') == 'analysis_result', + all(ana_name_chker('validate')(x)) + ) +} From 14f532c7c0f6bba8979b5e488475619ac19d43a0 Mon Sep 17 00:00:00 2001 From: Guanya Peng Date: Fri, 6 May 2022 14:54:22 +0200 Subject: [PATCH 05/84] add meta data to lsm0 and lsm1 in ancova --- R/ancova.R | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/R/ancova.R b/R/ancova.R index 75eca82f1..75249a64a 100644 --- a/R/ancova.R +++ b/R/ancova.R @@ -205,10 +205,10 @@ ancova_single <- function(data, outcome, group, covariates, weights = c("proport est = coef(mod)[[group]], se = sqrt(vcov(mod)[group, group]), df = df.residual(mod), - meta = add_meta(...) + meta = add_meta('visit', ...) ), - as_analysis_result(lsm0, name = 'lsm_ref'), - as_analysis_result(lsm1, name = 'lsm_alt') + as_analysis_result(lsm0, name = 'lsm_ref', meta = add_meta('visit', ...)), + as_analysis_result(lsm1, name = 'lsm_alt', meta = add_meta('visit', ...)) ) return(x) } From 22fd02176a5e471176798868cd265988822e7b4c Mon Sep 17 00:00:00 2001 From: Guanya Peng Date: Fri, 6 May 2022 14:55:11 +0200 Subject: [PATCH 06/84] add util function of add meta --- R/utilities.R | 52 +++++++++++++-------------------------------------- 1 file changed, 13 insertions(+), 39 deletions(-) diff --git a/R/utilities.R b/R/utilities.R index d5e0fa499..cec6a789c 100644 --- a/R/utilities.R +++ b/R/utilities.R @@ -513,44 +513,18 @@ as_dataframe <- function(x) { return(x2) } -#' Change a function -#' -#' A wrapper to change function with a modified return value. Specifically change a function returned named element based on given name and method -#' @param f A function to be changed -#' @param what A character representing name of the element to be changed from function's return -#' @param how A function specifying how to change the element -#' @return A function with modified return value -#' @example -#' pool <- change(pool, 'pars', function(...) lst2df(..., 'visit')) -change <- function(f, what, how) { - force(f) - function(...) { - out <- f(...) - tryCatch( - expr = { - out[[what]] <- how(out[[what]]) - }, - error = function(e) { - message(paste("Error when changing", what, ':', e)) - }, - finally = { - return(out) - } - ) - } -} +#' Add meta information to customerize analysis function +#' +#' @param name The name of the element to be added to meta +#' @param ... The values of the element to be added to meta +#' This function used only internally for ancova +add_meta <- function (var_names, var_values) { + assert_that( + !is.null(var_names) & !is.null(var_values) & length(var_names) == length(var_values), + msg = paste("Invalid parameters:", var_names, var_values) + ) -#' Convert nested list to data frame -#' -#' Convert a nested list to a data frame with specified group id and additional processer for the group -#' @param lst A nested list -#' @param id A group ID -#' @param processor A function to process group data -lst2df <- function(lst, id, processor = function(...) summarise(..., ci = toString(ci), across(), .groups = 'drop')) { - out <- bind_rows(lst, .id = id) - if (is.null(processor)) out - else out %>% - group_by(.data[[id]]) %>% - processor %>% - ungroup() + out <- as.list(as.character(var_values)) + names(out) <- var_names + out } From caf8a2d249575018ea0ab046082d511d9d313771 Mon Sep 17 00:00:00 2001 From: Guanya Peng Date: Fri, 6 May 2022 14:57:53 +0200 Subject: [PATCH 07/84] update example of analysis function in the header --- R/analyse.R | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/R/analyse.R b/R/analyse.R index bf2810193..f68016895 100644 --- a/R/analyse.R +++ b/R/analyse.R @@ -32,12 +32,14 @@ #' mod_1 <- lm(data = dat, outcome ~ group) #' mod_2 <- lm(data = dat, outcome ~ group + covar) #' x <- list( -#' trt_1 = list( +#' analysis_result( +#' name = trt_1, #' est = coef(mod_1)[[group]], #' se = sqrt(vcov(mod_1)[group, group]), #' df = df.residual(mod_1) #' ), -#' trt_2 = list( +#' analysis_result( +#' name = trt_2, #' est = coef(mod_2)[[group]], #' se = sqrt(vcov(mod_2)[group, group]), #' df = df.residual(mod_2) From 6a97460f2a2dcf51a6dbab37f9fdca9ef755dd80 Mon Sep 17 00:00:00 2001 From: Guanya Peng Date: Fri, 6 May 2022 16:55:25 +0200 Subject: [PATCH 08/84] update print.analysis function to print analysis info in a tabular format --- R/analyse.R | 56 +++++++++++++++++++++++++++++++++++++++-------------- 1 file changed, 42 insertions(+), 14 deletions(-) diff --git a/R/analyse.R b/R/analyse.R index f68016895..22e429b9d 100644 --- a/R/analyse.R +++ b/R/analyse.R @@ -343,16 +343,6 @@ print.analysis <- function(x, ...) { n_samp ) - info <- function(where, what) { - if (all(length(where) != 0, - !is.null(where[[1]]), - rlang::has_name(where[[1]], what))) { - sapply(where, `[[`, what) - } else { - paste("No", what, "info") - } - } - string <- c( "", "Analysis Object", @@ -361,7 +351,7 @@ print.analysis <- function(x, ...) { sprintf("Analysis Function: %s", x$fun_name), sprintf("Delta Applied: %s", !is.null(x$delta)), "Analysis Estimates:", - sprintf(" %s", info(x$results[[1]], 'name')), + as_ascii_table(analysis_info(x$results[[1]])), "" ) @@ -575,9 +565,6 @@ as_analysis_result <- function(x, ...) { for (i in seq_along(dots)) { name <- names(dots)[[i]] dot <- dots[[i]] - print(name) - print(dot) - print('---') if (is.element(name, names_not_presented) | name == 'meta') { updated_x[[name]] <- rlang::eval_tidy(dot) @@ -676,3 +663,44 @@ is.analysis_result <- function(x) { all(ana_name_chker('validate')(x)) ) } + +#' Get printable analysis information from an example of analysis result +#' +#' The example should not be the complete result of analysis object but a subset of it such as anaObj$results[[1]] +#' @param example A subset of the result of the analysis object for getting enough info to print +#' @param name_of_meta A character variable for the name of meta data in the result of analysis. Default: 'meta' +#' @return A data.frame containing the information of the analysis result from the example +#' @example analysis_info(dat, name_of_meta = 'meta') +#' @importFrom dplyr bind_cols bind_rows left_join select %>% +analysis_info <- function(example, name_of_meta = 'meta') { + + pars_no_meta <- list() + pars_with_meta <- list() + meta <- list() + var <- list() + + index <- function(i, body) { + list( + append(list(index=i), body) + ) + } + + for (i in seq_along(example)) { + item <- example[[i]] + if (rlang::has_name(item, name_of_meta)){ + meta <- append(meta, index(i, item[[name_of_meta]])) + var <- append(var, list(item['name'])) + pars_with_meta <- append(pars_with_meta, index(i, item[names(item) != name_of_meta])) + } else { + pars_no_meta <- append(pars_no_meta, index(i, item)) + } + } + + all_pars <- append(pars_with_meta, pars_no_meta) + + base_df <- bind_rows(all_pars) + + meta_df <- bind_cols(bind_rows(var), bind_rows(meta)) + + left_join(base_df, meta_df, by = c('index', 'name')) %>% select(-index) +} From 0f8c654d41df685470e7e1b48f49a0991c870cf1 Mon Sep 17 00:00:00 2001 From: pengguanya Date: Fri, 6 May 2022 17:48:56 +0200 Subject: [PATCH 09/84] remove wrapper's call --- R/pool.R | 1 - 1 file changed, 1 deletion(-) diff --git a/R/pool.R b/R/pool.R index 4a415a3e8..98eb74524 100644 --- a/R/pool.R +++ b/R/pool.R @@ -103,7 +103,6 @@ pool <- function( return(ret) } -pool <- change(pool, 'pars', function(...) lst2df(..., 'visit')) #' Expected Pool Components #' From 1e6180547bf92d10696d2d15ac270df19d321e90 Mon Sep 17 00:00:00 2001 From: pengguanya Date: Mon, 9 May 2022 15:09:52 +0200 Subject: [PATCH 10/84] fix import error %in% is in base not dplyr --- R/analyse.R | 1 - 1 file changed, 1 deletion(-) diff --git a/R/analyse.R b/R/analyse.R index 22e429b9d..055177875 100644 --- a/R/analyse.R +++ b/R/analyse.R @@ -648,7 +648,6 @@ ana_name_chker <- namechecker('name', 'est', 'se', 'df', optional = 'meta') #' @details #' This function does not only check the class attribute of the object. #' It also checks constraints of the names of the elements in the list -#' @importFrom dplyr %in% #' @export is.analysis_result <- function(x) { From 80d48c7d6eacca488798835bb1ecd39f55a0d38c Mon Sep 17 00:00:00 2001 From: Guanya Peng Date: Mon, 9 May 2022 16:31:20 +0200 Subject: [PATCH 11/84] update docs --- NAMESPACE | 8 ++++++++ man/add_meta.Rd | 17 ++++++++++++++++ man/ana_name_chker.Rd | 14 +++++++++++++ man/analyse.Rd | 6 ++++-- man/analysis_info.Rd | 24 ++++++++++++++++++++++ man/analysis_result.Rd | 42 +++++++++++++++++++++++++++++++++++++++ man/ancova_single.Rd | 3 ++- man/as_analysis_result.Rd | 24 ++++++++++++++++++++++ man/is.analysis_result.Rd | 21 ++++++++++++++++++++ man/namechecker.Rd | 19 ++++++++++++++++++ 10 files changed, 175 insertions(+), 3 deletions(-) create mode 100644 man/add_meta.Rd create mode 100644 man/ana_name_chker.Rd create mode 100644 man/analysis_info.Rd create mode 100644 man/analysis_result.Rd create mode 100644 man/as_analysis_result.Rd create mode 100644 man/is.analysis_result.Rd create mode 100644 man/namechecker.Rd diff --git a/NAMESPACE b/NAMESPACE index d2e3f0bd4..3cc7cc200 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -37,7 +37,9 @@ S3method(validate,stan_data) export(Stack) export(add_class) export(analyse) +export(analysis_result) export(ancova) +export(as_analysis_result) export(as_class) export(as_vcov) export(delta_template) @@ -50,6 +52,7 @@ export(getStrategies) export(get_example_data) export(has_class) export(impute) +export(is.analysis_result) export(locf) export(longDataConstructor) export(method_approxbayes) @@ -72,6 +75,11 @@ import(R6) import(Rcpp) import(methods) importFrom(assertthat,assert_that) +importFrom(dplyr,"%>%") +importFrom(dplyr,bind_cols) +importFrom(dplyr,bind_rows) +importFrom(dplyr,left_join) +importFrom(dplyr,select) importFrom(glmmTMB,VarCorr) importFrom(glmmTMB,fixef) importFrom(glmmTMB,getME) diff --git a/man/add_meta.Rd b/man/add_meta.Rd new file mode 100644 index 000000000..5f579ddc0 --- /dev/null +++ b/man/add_meta.Rd @@ -0,0 +1,17 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utilities.R +\name{add_meta} +\alias{add_meta} +\title{Add meta information to customerize analysis function} +\usage{ +add_meta(var_names, var_values) +} +\arguments{ +\item{name}{The name of the element to be added to meta} + +\item{...}{The values of the element to be added to meta +This function used only internally for ancova} +} +\description{ +Add meta information to customerize analysis function +} diff --git a/man/ana_name_chker.Rd b/man/ana_name_chker.Rd new file mode 100644 index 000000000..31dd6e151 --- /dev/null +++ b/man/ana_name_chker.Rd @@ -0,0 +1,14 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/analyse.R +\name{ana_name_chker} +\alias{ana_name_chker} +\title{Name checker for analysis function} +\usage{ +ana_name_chker(msg) +} +\arguments{ +\item{msg}{Character vector representing which checker to return} +} +\description{ +Name checker for analysis function +} diff --git a/man/analyse.Rd b/man/analyse.Rd index d740ee131..6bb1ef340 100644 --- a/man/analyse.Rd +++ b/man/analyse.Rd @@ -43,12 +43,14 @@ i.e.:\preformatted{myfun <- function(dat, ...) \{ mod_1 <- lm(data = dat, outcome ~ group) mod_2 <- lm(data = dat, outcome ~ group + covar) x <- list( - trt_1 = list( + analysis_result( + name = trt_1, est = coef(mod_1)[[group]], se = sqrt(vcov(mod_1)[group, group]), df = df.residual(mod_1) ), - trt_2 = list( + analysis_result( + name = trt_2, est = coef(mod_2)[[group]], se = sqrt(vcov(mod_2)[group, group]), df = df.residual(mod_2) diff --git a/man/analysis_info.Rd b/man/analysis_info.Rd new file mode 100644 index 000000000..adcab848d --- /dev/null +++ b/man/analysis_info.Rd @@ -0,0 +1,24 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/analyse.R +\name{analysis_info} +\alias{analysis_info} +\title{Get printable analysis information from an example of analysis result} +\usage{ +analysis_info(example, name_of_meta = "meta") +} +\arguments{ +\item{example}{A subset of the result of the analysis object for getting enough info to print} + +\item{name_of_meta}{A character variable for the name of meta data in the result of analysis. Default: 'meta'} +} +\value{ +A data.frame containing the information of the analysis result from the example +} +\description{ +The example should not be the complete result of analysis object but a subset of it such as \code{anaObj$results[[1]]} +} +\examples{ +\dontrun{ +analysis_info(dat, name_of_meta = 'meta') +} +} diff --git a/man/analysis_result.Rd b/man/analysis_result.Rd new file mode 100644 index 000000000..f47a5cabe --- /dev/null +++ b/man/analysis_result.Rd @@ -0,0 +1,42 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/analyse.R +\name{analysis_result} +\alias{analysis_result} +\title{Constructor of analysis result} +\usage{ +analysis_result( + name = character(), + est = double(), + se = double(), + df = integer(), + meta = NULL +) +} +\arguments{ +\item{name}{A character variable for the group name} + +\item{est}{A double type numeric variable as the estimate} + +\item{se}{A double type numeric variable as the standard error} + +\item{df}{An integer type of numeric variable} + +\item{meta}{A list type of variable as meta information} +} +\value{ +An object of "analysis_result" class +} +\description{ +Construct an analysis result class object whose base type is a list +} +\details{ +\itemize{ +\item \code{se} must be numeric values greater or equal to 0 +\item \code{meta} is optional +} +} +\examples{ +\dontrun{ +ana_res_obj <- analysis_result(name = 'trt', est = 1, se = 2, df = as.integer(3), meta = list(visit = 1)) +} +} diff --git a/man/ancova_single.Rd b/man/ancova_single.Rd index 464e652aa..74e8e1b39 100644 --- a/man/ancova_single.Rd +++ b/man/ancova_single.Rd @@ -9,7 +9,8 @@ ancova_single( outcome, group, covariates, - weights = c("proportional", "equal") + weights = c("proportional", "equal"), + ... ) } \arguments{ diff --git a/man/as_analysis_result.Rd b/man/as_analysis_result.Rd new file mode 100644 index 000000000..8f005dcb4 --- /dev/null +++ b/man/as_analysis_result.Rd @@ -0,0 +1,24 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/analyse.R +\name{as_analysis_result} +\alias{as_analysis_result} +\title{Convert object to analysis result class} +\usage{ +as_analysis_result(x, ...) +} +\arguments{ +\item{x}{The object to be converted to analysis_result class} + +\item{...}{Optional keywords parameters for adding missing elements to the object} +} +\value{ +An "analysis_result" class object with optionally updated elements +} +\description{ +Convert object to analysis result class +} +\examples{ +\dontrun{ +ana_res_obj <- as_analysis_result(list(est = 1, se = 2, df = 3), name = 'trt') +} +} diff --git a/man/is.analysis_result.Rd b/man/is.analysis_result.Rd new file mode 100644 index 000000000..835b1024a --- /dev/null +++ b/man/is.analysis_result.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/analyse.R +\name{is.analysis_result} +\alias{is.analysis_result} +\title{Check if an object is in class analysis_result} +\usage{ +is.analysis_result(x) +} +\arguments{ +\item{x}{Object to be checked} +} +\value{ +Logical value TRUE/FALSE +} +\description{ +Check if an object is in class analysis_result +} +\details{ +This function does not only check the class attribute of the object. +It also checks constraints of the names of the elements in the list +} diff --git a/man/namechecker.Rd b/man/namechecker.Rd new file mode 100644 index 000000000..9bfe0b3be --- /dev/null +++ b/man/namechecker.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/analyse.R +\name{namechecker} +\alias{namechecker} +\title{Create name checkers with message passing dispatch} +\usage{ +namechecker(..., optional = NULL) +} +\arguments{ +\item{...}{Character vectors for the reference to check against} + +\item{optional}{Character vector of optional name. Default: NULL} +} +\value{ +A constructor to create checker functions with message passing dispatch +} +\description{ +Create name checkers with message passing dispatch +} From 5ef2b848f20c994443d52cd03f1dbcce42b833c5 Mon Sep 17 00:00:00 2001 From: Guanya Peng Date: Mon, 9 May 2022 16:32:07 +0200 Subject: [PATCH 12/84] fix header example --- R/analyse.R | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/R/analyse.R b/R/analyse.R index 22e429b9d..0aabd32a2 100644 --- a/R/analyse.R +++ b/R/analyse.R @@ -648,7 +648,6 @@ ana_name_chker <- namechecker('name', 'est', 'se', 'df', optional = 'meta') #' @details #' This function does not only check the class attribute of the object. #' It also checks constraints of the names of the elements in the list -#' @importFrom dplyr %in% #' @export is.analysis_result <- function(x) { @@ -666,11 +665,14 @@ is.analysis_result <- function(x) { #' Get printable analysis information from an example of analysis result #' -#' The example should not be the complete result of analysis object but a subset of it such as anaObj$results[[1]] +#' The example should not be the complete result of analysis object but a subset of it such as `anaObj$results[[1]]` #' @param example A subset of the result of the analysis object for getting enough info to print #' @param name_of_meta A character variable for the name of meta data in the result of analysis. Default: 'meta' #' @return A data.frame containing the information of the analysis result from the example -#' @example analysis_info(dat, name_of_meta = 'meta') +#' @examples +#' \dontrun{ +#' analysis_info(dat, name_of_meta = 'meta') +#' } #' @importFrom dplyr bind_cols bind_rows left_join select %>% analysis_info <- function(example, name_of_meta = 'meta') { From e87eeee30a0aac1050d0f255b045bf389e9673d1 Mon Sep 17 00:00:00 2001 From: Guanya Peng Date: Mon, 9 May 2022 17:52:11 +0200 Subject: [PATCH 13/84] add validation for object class and exceptoin handling --- R/analyse.R | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/R/analyse.R b/R/analyse.R index 0aabd32a2..989fbd33a 100644 --- a/R/analyse.R +++ b/R/analyse.R @@ -689,6 +689,9 @@ analysis_info <- function(example, name_of_meta = 'meta') { for (i in seq_along(example)) { item <- example[[i]] + + stopifnot("Object in example is not in analysis_result class" = is.analysis_result(item)) + if (rlang::has_name(item, name_of_meta)){ meta <- append(meta, index(i, item[[name_of_meta]])) var <- append(var, list(item['name'])) @@ -704,5 +707,8 @@ analysis_info <- function(example, name_of_meta = 'meta') { meta_df <- bind_cols(bind_rows(var), bind_rows(meta)) - left_join(base_df, meta_df, by = c('index', 'name')) %>% select(-index) + tryCatch( + left_join(base_df, meta_df, by = c('index', 'name')) %>% select(-index), + error=function(e) base_df + ) %>% select(-index) } From 2f5feef1c7baa3f4d7f0164ea77881ba7bed76fe Mon Sep 17 00:00:00 2001 From: Guanya Peng Date: Mon, 9 May 2022 17:54:31 +0200 Subject: [PATCH 14/84] fix exception handling --- R/analyse.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/analyse.R b/R/analyse.R index 989fbd33a..8bffaf6f8 100644 --- a/R/analyse.R +++ b/R/analyse.R @@ -708,7 +708,7 @@ analysis_info <- function(example, name_of_meta = 'meta') { meta_df <- bind_cols(bind_rows(var), bind_rows(meta)) tryCatch( - left_join(base_df, meta_df, by = c('index', 'name')) %>% select(-index), + left_join(base_df, meta_df, by = c('index', 'name')), error=function(e) base_df ) %>% select(-index) } From 9eba1d3bdd596f74516d08380d0d94d2e0e36b1d Mon Sep 17 00:00:00 2001 From: Guanya Peng Date: Mon, 9 May 2022 19:20:54 +0200 Subject: [PATCH 15/84] use assertthat instead of stopifnot and git rid of non-base functions (dplyr...) --- R/analyse.R | 24 +++++++++++++++--------- 1 file changed, 15 insertions(+), 9 deletions(-) diff --git a/R/analyse.R b/R/analyse.R index 8bffaf6f8..2837414ce 100644 --- a/R/analyse.R +++ b/R/analyse.R @@ -670,10 +670,10 @@ is.analysis_result <- function(x) { #' @param name_of_meta A character variable for the name of meta data in the result of analysis. Default: 'meta' #' @return A data.frame containing the information of the analysis result from the example #' @examples +#' @importFrom assertthat has_attr #' \dontrun{ #' analysis_info(dat, name_of_meta = 'meta') #' } -#' @importFrom dplyr bind_cols bind_rows left_join select %>% analysis_info <- function(example, name_of_meta = 'meta') { pars_no_meta <- list() @@ -690,9 +690,10 @@ analysis_info <- function(example, name_of_meta = 'meta') { for (i in seq_along(example)) { item <- example[[i]] - stopifnot("Object in example is not in analysis_result class" = is.analysis_result(item)) + assert_that(is.analysis_result(item), + msg = "Object in example is not in analysis_result class") - if (rlang::has_name(item, name_of_meta)){ + if (has_attr(item, name_of_meta)){ meta <- append(meta, index(i, item[[name_of_meta]])) var <- append(var, list(item['name'])) pars_with_meta <- append(pars_with_meta, index(i, item[names(item) != name_of_meta])) @@ -701,14 +702,19 @@ analysis_info <- function(example, name_of_meta = 'meta') { } } + base_bind_rows <- function(L) as.data.frame(do.call(rbind, L)) + base_left_join <- function(x, y, by) merge(x, y, by = by, all.x=TRUE) + all_pars <- append(pars_with_meta, pars_no_meta) - base_df <- bind_rows(all_pars) + res_df <- base_bind_rows(all_pars) + + meta_df <- cbind(base_bind_rows(var), base_bind_rows(meta)) - meta_df <- bind_cols(bind_rows(var), bind_rows(meta)) + info_df <- tryCatch( + base_left_join(res_df, meta_df, by = c('index', 'name')), + error=function(e) res_df + ) - tryCatch( - left_join(base_df, meta_df, by = c('index', 'name')), - error=function(e) base_df - ) %>% select(-index) + subset(info_df, select = -index) } From deb1ee9aec640f1aff99e2c60cfbec131cda2200 Mon Sep 17 00:00:00 2001 From: Guanya Peng Date: Tue, 10 May 2022 23:07:25 +0200 Subject: [PATCH 16/84] add util funs --- R/utilities.R | 52 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 52 insertions(+) diff --git a/R/utilities.R b/R/utilities.R index cec6a789c..7d2db99cd 100644 --- a/R/utilities.R +++ b/R/utilities.R @@ -528,3 +528,55 @@ add_meta <- function (var_names, var_values) { names(out) <- var_names out } + +#' Assert variable's type +#' +#' @param what Variable to be asserted +#' @param how Type asserting functions: is.character, is.numeric, is.list, is.logic +#' @examples +#' \dontrun{ +#' assert_type(est, is.numeric) +#' } +assert_type <- function(what, + how, + whatname = deparse(substitute(what)), + howname = deparse(substitute(how))) { + + prettier <- function(...) gsub("_", " ", as.character(...)) + + type <- (function(s) sub(".*\\.", "", s))(howname) + assert_that(how(what), + msg = sprintf("%s of analysis_result `%s` is not %s", whatname, what, prettier(type)) + ) +} + +#' Make a chain of function calls with certain relation function +#' @param relation A relation function: `any` or `all` +#' @param ... Functions to be chained +#' @return A function taking arguments that are feed into chained functions +#' @examples +#' \dontrun{ +#' is.numeric_or_na <- make_chain(any, is.numeric, is.na) +#' is.numeric_or_na(NA) # returns TRUE +#' is.numeric_or_na(15) # returns TRUE +#' is.numeric_or_na('a') # returns FALSE +#' } +make_chain <- function(relation, ...) { + fs <- c(...) + function(...) relation(sapply(fs, function(f) f(...))) +} + +#' Order a named list by its names according to given character vector +#' @param L A list to be ordered +#' @param v A character contains the names in order +#' @return A list with names in order +#' \dontrun{ +#' L_ordered <- order_list_by_name(list(a=1,b='x',c=TRUE), c("c", "a", "d", "x", "b", "t")) +#' # returns a list `list(c=TRUE, a=1, b='x)` +#' +#' } +order_list_by_name <- function(L, v) { + ordered_pos <- match(v, names(L)) + ordered_pos <- ordered_pos[!is.na(ordered_pos)] + L[ordered_pos] +} From 98581617e1c39a06066afa10370e465c51a9a8cd Mon Sep 17 00:00:00 2001 From: Guanya Peng Date: Tue, 10 May 2022 23:09:10 +0200 Subject: [PATCH 17/84] update analysis --- R/analyse.R | 86 +++++++++++++++++++++++++++-------------------------- 1 file changed, 44 insertions(+), 42 deletions(-) diff --git a/R/analyse.R b/R/analyse.R index 2837414ce..8338e2d23 100644 --- a/R/analyse.R +++ b/R/analyse.R @@ -444,7 +444,7 @@ validate_analyse_pars <- function(results, pars) { assert_that( length(results[[1]]) != 0, all(vapply(results, function(Xs) all(vapply(Xs, function(X) is.analysis_result(X), logical(1))), logical(1))), - msg = "Individual analysis results must be type of analysis_result" + msg = "Individual analysis result must be type of analysis_result" ) results_names <- lapply(results, function(x) unique(names(x))) @@ -509,26 +509,33 @@ validate_analyse_pars <- function(results, pars) { #' } #' @export analysis_result <- function (name = character(), - est = double(), - se = double(), - df = integer(), + est = numeric(), + se = numeric(), + df = NULL, meta = NULL) { # constraints - stopifnot(is.character(name)) - stopifnot(is.double(est)) - stopifnot(is.double(se)) - stopifnot(is.integer(df) | is.double(df)) - stopifnot(is.list(meta) | is.null(meta)) + is.numeric_or_NA <- make_chain(any, is.numeric, anyNA) + is.numeric_or_NA_or_NULL <- make_chain(any, is.numeric_or_NA, is.null) + is.list_or_null <- make_chain(any, is.list, is.null) + + assert_type(name, is.character) + assert_type(est, is.numeric) + assert_type(se, is.numeric) + assert_type(df, is.numeric_or_NA_or_NULL) + assert_type(meta, is.list_or_null) # validators - if (se < 0) stop("SE must great or equal to 0", .call = FALSE) + if (se < 0) stop("SE must greater or equal to 0", .call = FALSE) value <- list(name = name, est = est, - se = se, - df = df) + se = se) + # optional values + if (!is.null(df)) { + value[['df']] <- df + } if (!is.null(meta)) { value[['meta']] <- meta } @@ -536,7 +543,7 @@ analysis_result <- function (name = character(), structure( value, meta = meta, - class = "analysis_result" + class = c("analysis_result", "list") ) } @@ -556,7 +563,7 @@ as_analysis_result <- function(x, ...) { # coercion with generic function x <- as.list(x) - present <- ana_name_chker('present') + present <- ana_name_chker('musthave_in_objnames') names_not_presented <- names(present(x))[!present(x)] @@ -574,14 +581,15 @@ as_analysis_result <- function(x, ...) { # after updating check if all required elements are presented stopifnot(all(present(updated_x))) - # keep only required elements and put them in defined order - if (length(names(updated_x)) < length(ana_name_chker('all'))) { - ordered_x <- updated_x[ana_name_chker('musthave')] - } else { - ordered_x <- updated_x[ana_name_chker('all')] + # order the list by names + ordered_x <- order_list_by_name(updated_x, ana_name_chker('all')) + + # set attributes: meta & class + if ('meta' %in% names(ordered_x)) { + attr(ordered_x, 'meta') <- ordered_x[['meta']] } - as_class(ordered_x, "analysis_result") + as_class(ordered_x, c("analysis_result", "list")) } #' Create name checkers with message passing dispatch @@ -605,28 +613,23 @@ namechecker <- function(..., optional = NULL) { function(x, y) f(y, x) } - extend <- function(v1, v2) { - if(is.null(v2)) v1 - else append(v1, v2) - } - # higher-order function to create template for checkers/validators chker_template <- function(musthave, wrapper=identity, f = XsInYs, .optional = optional) { function(...) { - wrapper(f)(extend(musthave, .optional), names(...)) + wrapper(f)(append(musthave, .optional), names(...)) } } - # checker to check if elements in musthave present in the object's name + # Validator to check if elements in musthave present in the object's name # checker does not check against optional names. Only names in musthave have to be presented in the object - present <- chker_template(musthave, .optional = NULL) + musthave_in_objnames <- chker_template(musthave, .optional = NULL) - # validator to validate if object's name belongs to musthave + optional names (simply swap the order of arguments from present) - validate <- chker_template(musthave, swap) + # Validator to check if object's name belongs to musthave + optional names (simply swap the order of arguments from present) + objnames_in_musthave <- chker_template(musthave, swap) dispatch <- list( - present = present, - validate = validate, + musthave_in_objnames = musthave_in_objnames, + objnames_in_musthave = objnames_in_musthave, musthave = musthave, optional = optional, all = append(musthave, optional) @@ -639,7 +642,7 @@ namechecker <- function(..., optional = NULL) { #' Name checker for analysis function #' #' @param msg Character vector representing which checker to return -ana_name_chker <- namechecker('name', 'est', 'se', 'df', optional = 'meta') +ana_name_chker <- namechecker('name', 'est', 'se', optional = c('df', 'meta')) #' Check if an object is in class analysis_result #' @@ -649,31 +652,30 @@ ana_name_chker <- namechecker('name', 'est', 'se', 'df', optional = 'meta') #' This function does not only check the class attribute of the object. #' It also checks constraints of the names of the elements in the list #' @export +#' @importFrom assertthat has_attr is.analysis_result <- function(x) { - has_attribute <- function(x, which){ - which %in% names(attributes(x)) - } - all( - has_attribute(x, 'class'), + has_attr(x, 'class'), is.object(x), - attr(x, 'class') == 'analysis_result', - all(ana_name_chker('validate')(x)) + 'analysis_result' %in% attr(x, 'class'), + typeof(x) == 'list', + all(ana_name_chker('objnames_in_musthave')(x)), + all(ana_name_chker('musthave_in_objnames')(x)) ) } #' Get printable analysis information from an example of analysis result #' #' The example should not be the complete result of analysis object but a subset of it such as `anaObj$results[[1]]` -#' @param example A subset of the result of the analysis object for getting enough info to print +#' @param example A list of analysis result A subset of the result of the analysis object for getting enough info to print #' @param name_of_meta A character variable for the name of meta data in the result of analysis. Default: 'meta' #' @return A data.frame containing the information of the analysis result from the example #' @examples -#' @importFrom assertthat has_attr #' \dontrun{ #' analysis_info(dat, name_of_meta = 'meta') #' } +#' @importFrom assertthat has_attr analysis_info <- function(example, name_of_meta = 'meta') { pars_no_meta <- list() From 606eeac5e2d3a3f4f0f5eea40b36e72aefca14c5 Mon Sep 17 00:00:00 2001 From: Guanya Peng Date: Tue, 10 May 2022 23:09:51 +0200 Subject: [PATCH 18/84] update doc --- man/analysis_info.Rd | 2 +- man/analysis_result.Rd | 6 +++--- man/assert_type.Rd | 26 ++++++++++++++++++++++++++ man/make_chain.Rd | 27 +++++++++++++++++++++++++++ man/order_list_by_name.Rd | 24 ++++++++++++++++++++++++ 5 files changed, 81 insertions(+), 4 deletions(-) create mode 100644 man/assert_type.Rd create mode 100644 man/make_chain.Rd create mode 100644 man/order_list_by_name.Rd diff --git a/man/analysis_info.Rd b/man/analysis_info.Rd index adcab848d..6fb0f3da9 100644 --- a/man/analysis_info.Rd +++ b/man/analysis_info.Rd @@ -7,7 +7,7 @@ analysis_info(example, name_of_meta = "meta") } \arguments{ -\item{example}{A subset of the result of the analysis object for getting enough info to print} +\item{example}{A list of analysis result A subset of the result of the analysis object for getting enough info to print} \item{name_of_meta}{A character variable for the name of meta data in the result of analysis. Default: 'meta'} } diff --git a/man/analysis_result.Rd b/man/analysis_result.Rd index f47a5cabe..1f5c74dcd 100644 --- a/man/analysis_result.Rd +++ b/man/analysis_result.Rd @@ -6,9 +6,9 @@ \usage{ analysis_result( name = character(), - est = double(), - se = double(), - df = integer(), + est = numeric(), + se = numeric(), + df = NULL, meta = NULL ) } diff --git a/man/assert_type.Rd b/man/assert_type.Rd new file mode 100644 index 000000000..bfa5366ee --- /dev/null +++ b/man/assert_type.Rd @@ -0,0 +1,26 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utilities.R +\name{assert_type} +\alias{assert_type} +\title{Assert variable's type} +\usage{ +assert_type( + what, + how, + whatname = deparse(substitute(what)), + howname = deparse(substitute(how)) +) +} +\arguments{ +\item{what}{Variable to be asserted} + +\item{how}{Type asserting functions: is.character, is.numeric, is.list, is.logic} +} +\description{ +Assert variable's type +} +\examples{ +\dontrun{ +assert_type(est, is.numeric) +} +} diff --git a/man/make_chain.Rd b/man/make_chain.Rd new file mode 100644 index 000000000..82193eb2b --- /dev/null +++ b/man/make_chain.Rd @@ -0,0 +1,27 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utilities.R +\name{make_chain} +\alias{make_chain} +\title{Make a chain of function calls with certain relation function} +\usage{ +make_chain(relation, ...) +} +\arguments{ +\item{relation}{A relation function: \code{any} or \code{all}} + +\item{...}{Functions to be chained} +} +\value{ +A function taking arguments that are feed into chained functions +} +\description{ +Make a chain of function calls with certain relation function +} +\examples{ +\dontrun{ +is.numeric_or_na <- make_chain(any, is.numeric, is.na) +is.numeric_or_na(NA) # returns TRUE +is.numeric_or_na(15) # returns TRUE +is.numeric_or_na('a') # returns FALSE +} +} diff --git a/man/order_list_by_name.Rd b/man/order_list_by_name.Rd new file mode 100644 index 000000000..0eaa9f13b --- /dev/null +++ b/man/order_list_by_name.Rd @@ -0,0 +1,24 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utilities.R +\name{order_list_by_name} +\alias{order_list_by_name} +\title{Order a named list by its names according to given character vector} +\usage{ +order_list_by_name(L, v) +} +\arguments{ +\item{L}{A list to be ordered} + +\item{v}{A character contains the names in order} +} +\value{ +A list with names in order +\dontrun{ +L_ordered <- order_list_by_name(list(a=1,b='x',c=TRUE), c("c", "a", "d", "x", "b", "t")) +# returns a list `list(c=TRUE, a=1, b='x)` + +} +} +\description{ +Order a named list by its names according to given character vector +} From 1d25df02c67a06d7b8227f53ca7cb4033fb7cda9 Mon Sep 17 00:00:00 2001 From: Guanya Peng Date: Tue, 10 May 2022 23:10:08 +0200 Subject: [PATCH 19/84] udpate namespace --- NAMESPACE | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 3cc7cc200..9d32fdca9 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -75,11 +75,7 @@ import(R6) import(Rcpp) import(methods) importFrom(assertthat,assert_that) -importFrom(dplyr,"%>%") -importFrom(dplyr,bind_cols) -importFrom(dplyr,bind_rows) -importFrom(dplyr,left_join) -importFrom(dplyr,select) +importFrom(assertthat,has_attr) importFrom(glmmTMB,VarCorr) importFrom(glmmTMB,fixef) importFrom(glmmTMB,getME) From 4c044220e7900e3fd26ca99b0344418f7c603284 Mon Sep 17 00:00:00 2001 From: Guanya Peng Date: Wed, 11 May 2022 12:00:33 +0200 Subject: [PATCH 20/84] update base_bind_rows and use it in analysis instead of dplyr::bind_rows --- R/analyse.R | 1 - R/utilities.R | 13 +++++++++++++ 2 files changed, 13 insertions(+), 1 deletion(-) diff --git a/R/analyse.R b/R/analyse.R index 8338e2d23..314ae173c 100644 --- a/R/analyse.R +++ b/R/analyse.R @@ -704,7 +704,6 @@ analysis_info <- function(example, name_of_meta = 'meta') { } } - base_bind_rows <- function(L) as.data.frame(do.call(rbind, L)) base_left_join <- function(x, y, by) merge(x, y, by = by, all.x=TRUE) all_pars <- append(pars_with_meta, pars_no_meta) diff --git a/R/utilities.R b/R/utilities.R index 7d2db99cd..7e3d736ef 100644 --- a/R/utilities.R +++ b/R/utilities.R @@ -580,3 +580,16 @@ order_list_by_name <- function(L, v) { ordered_pos <- ordered_pos[!is.na(ordered_pos)] L[ordered_pos] } + +#' Convert nested list to data.frame +#' +#' @param nestlist A nested list to be converted to data.frame +#' @return A data.frame binding each sublist as row in the data.frame and with NA filled for missing values +base_bind_rows <- function(nestlist) { + nms <- unique(unlist(lapply(nestlist, names))) + frmls <- as.list(setNames(rep(NA, length(nms)), nms)) + dflst <- setNames(lapply(nms, function(x) call("unlist", as.symbol(x))), nms) + make_df <- as.function(c(frmls, call("do.call", "data.frame", dflst))) + + do.call(rbind, lapply(nestlist, function(x) do.call(make_df, x))) +} From cde28a1279fc3d6274852d57e4e81c329864c044 Mon Sep 17 00:00:00 2001 From: Guanya Peng Date: Wed, 11 May 2022 13:48:19 +0200 Subject: [PATCH 21/84] move namechecker function from analyse.R to utilities.R since it is more general --- R/analyse.R | 57 ++++++++------------------------------------------- R/utilities.R | 47 ++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 56 insertions(+), 48 deletions(-) diff --git a/R/analyse.R b/R/analyse.R index 314ae173c..47e2cfe40 100644 --- a/R/analyse.R +++ b/R/analyse.R @@ -592,56 +592,17 @@ as_analysis_result <- function(x, ...) { as_class(ordered_x, c("analysis_result", "list")) } -#' Create name checkers with message passing dispatch -#' -#' @param ... Character vectors for the reference to check against -#' @param optional Character vector of optional name. Default: NULL -#' @return A constructor to create checker functions with message passing dispatch -namechecker <- function(..., optional = NULL) { - - # compile the musthave list at the top level so that easier to maintain and update - musthave <- c(...) - - # message passing as a dispatch - function(msg) { - - # generic function to check if elements in list X exist in Y - XsInYs <- function(x, y) vapply(x, purrr::partial(is.element, ... =, y), logical(1)) - - # generic wrapper to swap oder of formal parameter of binary function - swap <- function(f) { - function(x, y) f(y, x) - } - - # higher-order function to create template for checkers/validators - chker_template <- function(musthave, wrapper=identity, f = XsInYs, .optional = optional) { - function(...) { - wrapper(f)(append(musthave, .optional), names(...)) - } - } - - # Validator to check if elements in musthave present in the object's name - # checker does not check against optional names. Only names in musthave have to be presented in the object - musthave_in_objnames <- chker_template(musthave, .optional = NULL) - - # Validator to check if object's name belongs to musthave + optional names (simply swap the order of arguments from present) - objnames_in_musthave <- chker_template(musthave, swap) - - dispatch <- list( - musthave_in_objnames = musthave_in_objnames, - objnames_in_musthave = objnames_in_musthave, - musthave = musthave, - optional = optional, - all = append(musthave, optional) - ) - - dispatch[[msg]] - } -} - -#' Name checker for analysis function +#' Name checker for analysis_result object #' #' @param msg Character vector representing which checker to return +#' @example +#' \dontrun{ +#' anares_names_in_musthave <- ana_name_chker('objnames_in_musthave') +#' musthave_in_anares_names <- ana_name_chker('musthave_in_objnames') +#' musthave_names <- ana_name_chker('musthave') +#' optional_names <- ana_name_chker('optional') +#' all_names <- ana_name_chker('all') +#' } ana_name_chker <- namechecker('name', 'est', 'se', optional = c('df', 'meta')) #' Check if an object is in class analysis_result diff --git a/R/utilities.R b/R/utilities.R index 7e3d736ef..e9bfc7a15 100644 --- a/R/utilities.R +++ b/R/utilities.R @@ -593,3 +593,50 @@ base_bind_rows <- function(nestlist) { do.call(rbind, lapply(nestlist, function(x) do.call(make_df, x))) } + +#' Create name checkers for object with message passing dispatch +#' +#' @param ... Character vectors for the reference to check against +#' @param optional Character vector of optional name. Default: NULL +#' @return A constructor to create checker functions with message passing dispatch +namechecker <- function(..., optional = NULL) { + + # compile the musthave list at the top level so that easier to maintain and update + musthave <- c(...) + + # message passing as a dispatch + function(msg) { + + # function to check if elements in list X exist in Y + XsInYs <- function(x, y) vapply(x, purrr::partial(is.element, ... =, y), logical(1)) + + # wrapper to swap order of formal parameter of binary function + swap <- function(f) { + function(x, y) f(y, x) + } + + # higher-order function to create template for validators + chker_template <- function(musthave, wrapper=identity, f = XsInYs, .optional = optional) { + function(...) { + wrapper(f)(append(musthave, .optional), names(...)) + } + } + + # Validator to check if elements in musthave present in the object's name + # checker does not check against optional names. Only names in musthave have to be presented in the object + musthave_in_objnames <- chker_template(musthave, .optional = NULL) + + # Validator to check if object's name belongs to musthave + optional names (simply swap the order of arguments from present) + objnames_in_musthave <- chker_template(musthave, swap) + + dispatch <- list( + musthave_in_objnames = musthave_in_objnames, + objnames_in_musthave = objnames_in_musthave, + musthave = musthave, + optional = optional, + all = append(musthave, optional) + ) + + dispatch[[msg]] + } +} From 453f13a8f6c374e4256bf6dada7d78dc9501bd07 Mon Sep 17 00:00:00 2001 From: Guanya Peng Date: Wed, 11 May 2022 14:03:09 +0200 Subject: [PATCH 22/84] use assert_that instead of stopifnot --- R/analyse.R | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/R/analyse.R b/R/analyse.R index 47e2cfe40..38e9e440f 100644 --- a/R/analyse.R +++ b/R/analyse.R @@ -579,7 +579,8 @@ as_analysis_result <- function(x, ...) { } # after updating check if all required elements are presented - stopifnot(all(present(updated_x))) + assert_that(all(present(updated_x)), + msg = "Required parameters are not presented after updating") # order the list by names ordered_x <- order_list_by_name(updated_x, ana_name_chker('all')) From 02f37be56f8c0d9df633b3b09330ba4f8feed337 Mon Sep 17 00:00:00 2001 From: Guanya Peng Date: Wed, 11 May 2022 15:06:46 +0200 Subject: [PATCH 23/84] lazily evaluate namechecker to avoid name error --- R/analyse.R | 22 ++++++++++++---------- 1 file changed, 12 insertions(+), 10 deletions(-) diff --git a/R/analyse.R b/R/analyse.R index 38e9e440f..b1ce5eb1c 100644 --- a/R/analyse.R +++ b/R/analyse.R @@ -563,7 +563,7 @@ as_analysis_result <- function(x, ...) { # coercion with generic function x <- as.list(x) - present <- ana_name_chker('musthave_in_objnames') + present <- ana_name_chker()('musthave_in_objnames') names_not_presented <- names(present(x))[!present(x)] @@ -583,7 +583,7 @@ as_analysis_result <- function(x, ...) { msg = "Required parameters are not presented after updating") # order the list by names - ordered_x <- order_list_by_name(updated_x, ana_name_chker('all')) + ordered_x <- order_list_by_name(updated_x, ana_name_chker()('all')) # set attributes: meta & class if ('meta' %in% names(ordered_x)) { @@ -595,16 +595,18 @@ as_analysis_result <- function(x, ...) { #' Name checker for analysis_result object #' -#' @param msg Character vector representing which checker to return +#' A higher order function returns an analysis name checker which is again a higher order function takes character vector as +#' type of dispatch message and returns selected check function or properties. +#' This function takes no argument. The point is to delay the evaluation and evaluate only when it is needed, similar idea as shiny ractive #' @example #' \dontrun{ -#' anares_names_in_musthave <- ana_name_chker('objnames_in_musthave') -#' musthave_in_anares_names <- ana_name_chker('musthave_in_objnames') -#' musthave_names <- ana_name_chker('musthave') -#' optional_names <- ana_name_chker('optional') +#' anares_names_in_musthave <- ana_name_chker()('objnames_in_musthave') +#' musthave_in_anares_names <- ana_name_chker()('musthave_in_objnames') +#' musthave_names <- ana_name_chker()('musthave') +#' optional_names <- ana_name_chker()('optional') #' all_names <- ana_name_chker('all') #' } -ana_name_chker <- namechecker('name', 'est', 'se', optional = c('df', 'meta')) +ana_name_chker <- function() namechecker('name', 'est', 'se', optional = c('df', 'meta')) #' Check if an object is in class analysis_result #' @@ -622,8 +624,8 @@ is.analysis_result <- function(x) { is.object(x), 'analysis_result' %in% attr(x, 'class'), typeof(x) == 'list', - all(ana_name_chker('objnames_in_musthave')(x)), - all(ana_name_chker('musthave_in_objnames')(x)) + all(ana_name_chker()('objnames_in_musthave')(x)), + all(ana_name_chker()('musthave_in_objnames')(x)) ) } From ac964980b4d67cd1f497136958e8466beae70b5c Mon Sep 17 00:00:00 2001 From: Guanya Peng Date: Wed, 11 May 2022 20:10:28 +0200 Subject: [PATCH 24/84] fix header --- R/utilities.R | 1 + 1 file changed, 1 insertion(+) diff --git a/R/utilities.R b/R/utilities.R index e9bfc7a15..b3467d1c9 100644 --- a/R/utilities.R +++ b/R/utilities.R @@ -570,6 +570,7 @@ make_chain <- function(relation, ...) { #' @param L A list to be ordered #' @param v A character contains the names in order #' @return A list with names in order +#' @examples #' \dontrun{ #' L_ordered <- order_list_by_name(list(a=1,b='x',c=TRUE), c("c", "a", "d", "x", "b", "t")) #' # returns a list `list(c=TRUE, a=1, b='x)` From 1dc88fd78c752374297a9963adee75525e250691 Mon Sep 17 00:00:00 2001 From: Guanya Peng Date: Wed, 11 May 2022 20:12:19 +0200 Subject: [PATCH 25/84] update header --- R/ancova.R | 28 ++++++++++++++++++++-------- 1 file changed, 20 insertions(+), 8 deletions(-) diff --git a/R/ancova.R b/R/ancova.R index 75249a64a..621bfca53 100644 --- a/R/ancova.R +++ b/R/ancova.R @@ -28,16 +28,28 @@ #' If no value for `visits` is provided then it will be set to #' `unique(data[[vars$visit]])`. #' -#' In order to meet the formatting standards set by [analyse()] the results will be collapsed -#' into a single list suffixed by the visit name, e.g.: +#' Visits as part of the meta information of the `analysis_result` object from results of [analyse()] can be accessed individually and are +#' are displayed in a column from the `print.analysis` output such like +#' ``` +#' ===================================== +#' name est se df visit +#' ------------------------------------- +#' trt -0.513 0.505 197 1 +#' trt -2.366 0.675 197 4 +#' lsm_ref 7.51 0.477 197 4 +#' lsm_alt 5.144 0.477 197 4 +#' ------------------------------------- +#' +#' ``` +#' Then list in analysis results has structure such as following. Each individual result is in class `analysis_result` #'``` #'list( -#' trt_visit_1 = list(est = ...), -#' lsm_ref_visit_1 = list(est = ...), -#' lsm_alt_visit_1 = list(est = ...), -#' trt_visit_2 = list(est = ...), -#' lsm_ref_visit_2 = list(est = ...), -#' lsm_alt_visit_2 = list(est = ...), +#' trt = analysis_result(name =, est = ..., meta = list(visit=1, ...)), +#' lsm_ref = analysis_result(name =, est = ..., meta = list(visit=1, ...)), +#' lsm_alt = analysis_result(name =, est = ..., meta = list(visit=1, ...)), +#' trt = analysis_result(name =, est = ..., meta = list(visit=2, ...)), +#' lsm_ref = analysis_result(name =, est = ..., meta = list(visit=2, ...)), +#' lsm_alt = analysis_result(name =, est = ..., meta = list(visit=2, ...)), #' ... #') #'``` From 2e282c1b7c9cbb62033b56cf212fb502234407d7 Mon Sep 17 00:00:00 2001 From: Guanya Peng Date: Wed, 11 May 2022 20:13:29 +0200 Subject: [PATCH 26/84] use base R instead of rlang. add more paramters to function --- R/analyse.R | 36 ++++++++++++++++++++++-------------- 1 file changed, 22 insertions(+), 14 deletions(-) diff --git a/R/analyse.R b/R/analyse.R index b1ce5eb1c..d55a603b1 100644 --- a/R/analyse.R +++ b/R/analyse.R @@ -526,7 +526,17 @@ analysis_result <- function (name = character(), assert_type(meta, is.list_or_null) # validators - if (se < 0) stop("SE must greater or equal to 0", .call = FALSE) + assert_that( + se >= 0, + msg = "SE must be greater or equal to 0" + ) + + if (!is.null(df) & !is.na(df)) { + assert_that( + df >= 0, + msg = "DF must be greater or equal to 0" + ) + } value <- list(name = name, est = est, @@ -558,7 +568,7 @@ analysis_result <- function (name = character(), #' } #' @export as_analysis_result <- function(x, ...) { - dots <- rlang::enquos(...) + new_pars <- list(...) # coercion with generic function x <- as.list(x) @@ -569,12 +579,9 @@ as_analysis_result <- function(x, ...) { # update list if required elements are not presented or if the element is 'meta' updated_x <- x - for (i in seq_along(dots)) { - name <- names(dots)[[i]] - dot <- dots[[i]] - - if (is.element(name, names_not_presented) | name == 'meta') { - updated_x[[name]] <- rlang::eval_tidy(dot) + for (name in names(new_pars)) { + if (name %in% names_not_presented | name %in% ana_name_chker()('optional')) { + updated_x[[name]] <- new_pars[[name]] } } @@ -598,7 +605,7 @@ as_analysis_result <- function(x, ...) { #' A higher order function returns an analysis name checker which is again a higher order function takes character vector as #' type of dispatch message and returns selected check function or properties. #' This function takes no argument. The point is to delay the evaluation and evaluate only when it is needed, similar idea as shiny ractive -#' @example +#' @examples #' \dontrun{ #' anares_names_in_musthave <- ana_name_chker()('objnames_in_musthave') #' musthave_in_anares_names <- ana_name_chker()('musthave_in_objnames') @@ -633,14 +640,15 @@ is.analysis_result <- function(x) { #' #' The example should not be the complete result of analysis object but a subset of it such as `anaObj$results[[1]]` #' @param example A list of analysis result A subset of the result of the analysis object for getting enough info to print -#' @param name_of_meta A character variable for the name of meta data in the result of analysis. Default: 'meta' +#' @param example A character variable for the name of var in result of analysis which is defined from `analysis_result`. Default: 'name' +#' @param name_of_meta A character variable for the name of meta data in the result of analysis which is defined from `analysis_result`. Default: 'meta' #' @return A data.frame containing the information of the analysis result from the example #' @examples #' \dontrun{ -#' analysis_info(dat, name_of_meta = 'meta') +#' analysis_info(dat, name_of_var = 'name', name_of_meta = 'meta') #' } #' @importFrom assertthat has_attr -analysis_info <- function(example, name_of_meta = 'meta') { +analysis_info <- function(example, name_of_var = 'name', name_of_meta = 'meta') { pars_no_meta <- list() pars_with_meta <- list() @@ -661,7 +669,7 @@ analysis_info <- function(example, name_of_meta = 'meta') { if (has_attr(item, name_of_meta)){ meta <- append(meta, index(i, item[[name_of_meta]])) - var <- append(var, list(item['name'])) + var <- append(var, list(item[name_of_var])) pars_with_meta <- append(pars_with_meta, index(i, item[names(item) != name_of_meta])) } else { pars_no_meta <- append(pars_no_meta, index(i, item)) @@ -677,7 +685,7 @@ analysis_info <- function(example, name_of_meta = 'meta') { meta_df <- cbind(base_bind_rows(var), base_bind_rows(meta)) info_df <- tryCatch( - base_left_join(res_df, meta_df, by = c('index', 'name')), + base_left_join(res_df, meta_df, by = c('index', name_of_var)), error=function(e) res_df ) From d0b3cffff84fe4c45a0c67df29a11d30bbca1bb8 Mon Sep 17 00:00:00 2001 From: Guanya Peng Date: Wed, 11 May 2022 20:14:00 +0200 Subject: [PATCH 27/84] update doc --- man/ana_name_chker.Rd | 20 ++++++++++++++------ man/analysis_info.Rd | 8 ++++---- man/ancova.Rd | 27 +++++++++++++++++++-------- man/base_bind_rows.Rd | 17 +++++++++++++++++ man/namechecker.Rd | 6 +++--- man/order_list_by_name.Rd | 8 +++++--- 6 files changed, 62 insertions(+), 24 deletions(-) create mode 100644 man/base_bind_rows.Rd diff --git a/man/ana_name_chker.Rd b/man/ana_name_chker.Rd index 31dd6e151..70920c531 100644 --- a/man/ana_name_chker.Rd +++ b/man/ana_name_chker.Rd @@ -2,13 +2,21 @@ % Please edit documentation in R/analyse.R \name{ana_name_chker} \alias{ana_name_chker} -\title{Name checker for analysis function} +\title{Name checker for analysis_result object} \usage{ -ana_name_chker(msg) -} -\arguments{ -\item{msg}{Character vector representing which checker to return} +ana_name_chker() } \description{ -Name checker for analysis function +A higher order function returns an analysis name checker which is again a higher order function takes character vector as +type of dispatch message and returns selected check function or properties. +This function takes no argument. The point is to delay the evaluation and evaluate only when it is needed, similar idea as shiny ractive +} +\examples{ +\dontrun{ +anares_names_in_musthave <- ana_name_chker()('objnames_in_musthave') +musthave_in_anares_names <- ana_name_chker()('musthave_in_objnames') +musthave_names <- ana_name_chker()('musthave') +optional_names <- ana_name_chker()('optional') +all_names <- ana_name_chker('all') +} } diff --git a/man/analysis_info.Rd b/man/analysis_info.Rd index 6fb0f3da9..3bae01ab6 100644 --- a/man/analysis_info.Rd +++ b/man/analysis_info.Rd @@ -4,12 +4,12 @@ \alias{analysis_info} \title{Get printable analysis information from an example of analysis result} \usage{ -analysis_info(example, name_of_meta = "meta") +analysis_info(example, name_of_var = "name", name_of_meta = "meta") } \arguments{ -\item{example}{A list of analysis result A subset of the result of the analysis object for getting enough info to print} +\item{example}{A character variable for the name of var in result of analysis which is defined from \code{analysis_result}. Default: 'name'} -\item{name_of_meta}{A character variable for the name of meta data in the result of analysis. Default: 'meta'} +\item{name_of_meta}{A character variable for the name of meta data in the result of analysis which is defined from \code{analysis_result}. Default: 'meta'} } \value{ A data.frame containing the information of the analysis result from the example @@ -19,6 +19,6 @@ The example should not be the complete result of analysis object but a subset of } \examples{ \dontrun{ -analysis_info(dat, name_of_meta = 'meta') +analysis_info(dat, name_of_var = 'name', name_of_meta = 'meta') } } diff --git a/man/ancova.Rd b/man/ancova.Rd index 48af509e7..c1fa3843a 100644 --- a/man/ancova.Rd +++ b/man/ancova.Rd @@ -39,14 +39,25 @@ The function works as follows: If no value for \code{visits} is provided then it will be set to \code{unique(data[[vars$visit]])}. -In order to meet the formatting standards set by \code{\link[=analyse]{analyse()}} the results will be collapsed -into a single list suffixed by the visit name, e.g.:\preformatted{list( - trt_visit_1 = list(est = ...), - lsm_ref_visit_1 = list(est = ...), - lsm_alt_visit_1 = list(est = ...), - trt_visit_2 = list(est = ...), - lsm_ref_visit_2 = list(est = ...), - lsm_alt_visit_2 = list(est = ...), +Visits as part of the meta information of the \code{analysis_result} object from results of \code{\link[=analyse]{analyse()}} can be accessed individually and are +are displayed in a column from the \code{print.analysis} output such like\preformatted{ ===================================== + name est se df visit + ------------------------------------- + trt -0.513 0.505 197 1 + trt -2.366 0.675 197 4 + lsm_ref 7.51 0.477 197 4 + lsm_alt 5.144 0.477 197 4 + ------------------------------------- + +} + +Then list in analysis results has structure such as following. Each individual result is in class \code{analysis_result}\preformatted{list( + trt = analysis_result(name =, est = ..., meta = list(visit=1, ...)), + lsm_ref = analysis_result(name =, est = ..., meta = list(visit=1, ...)), + lsm_alt = analysis_result(name =, est = ..., meta = list(visit=1, ...)), + trt = analysis_result(name =, est = ..., meta = list(visit=2, ...)), + lsm_ref = analysis_result(name =, est = ..., meta = list(visit=2, ...)), + lsm_alt = analysis_result(name =, est = ..., meta = list(visit=2, ...)), ... ) } diff --git a/man/base_bind_rows.Rd b/man/base_bind_rows.Rd new file mode 100644 index 000000000..009879be5 --- /dev/null +++ b/man/base_bind_rows.Rd @@ -0,0 +1,17 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utilities.R +\name{base_bind_rows} +\alias{base_bind_rows} +\title{Convert nested list to data.frame} +\usage{ +base_bind_rows(nestlist) +} +\arguments{ +\item{nestlist}{A nested list to be converted to data.frame} +} +\value{ +A data.frame binding each sublist as row in the data.frame and with NA filled for missing values +} +\description{ +Convert nested list to data.frame +} diff --git a/man/namechecker.Rd b/man/namechecker.Rd index 9bfe0b3be..1d03c55c4 100644 --- a/man/namechecker.Rd +++ b/man/namechecker.Rd @@ -1,8 +1,8 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/analyse.R +% Please edit documentation in R/utilities.R \name{namechecker} \alias{namechecker} -\title{Create name checkers with message passing dispatch} +\title{Create name checkers for object with message passing dispatch} \usage{ namechecker(..., optional = NULL) } @@ -15,5 +15,5 @@ namechecker(..., optional = NULL) A constructor to create checker functions with message passing dispatch } \description{ -Create name checkers with message passing dispatch +Create name checkers for object with message passing dispatch } diff --git a/man/order_list_by_name.Rd b/man/order_list_by_name.Rd index 0eaa9f13b..8395bff29 100644 --- a/man/order_list_by_name.Rd +++ b/man/order_list_by_name.Rd @@ -13,12 +13,14 @@ order_list_by_name(L, v) } \value{ A list with names in order +} +\description{ +Order a named list by its names according to given character vector +} +\examples{ \dontrun{ L_ordered <- order_list_by_name(list(a=1,b='x',c=TRUE), c("c", "a", "d", "x", "b", "t")) # returns a list `list(c=TRUE, a=1, b='x)` } } -\description{ -Order a named list by its names according to given character vector -} From 4d276e4d3d17cfd207977010401c4a41a408ccca Mon Sep 17 00:00:00 2001 From: Guanya Peng Date: Wed, 11 May 2022 20:24:40 +0200 Subject: [PATCH 28/84] update header and comment --- R/analyse.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/analyse.R b/R/analyse.R index d55a603b1..0805d8137 100644 --- a/R/analyse.R +++ b/R/analyse.R @@ -577,7 +577,7 @@ as_analysis_result <- function(x, ...) { names_not_presented <- names(present(x))[!present(x)] - # update list if required elements are not presented or if the element is 'meta' + # update list if required elements are not presented or if the provided name is an optional element of analysis_result object updated_x <- x for (name in names(new_pars)) { if (name %in% names_not_presented | name %in% ana_name_chker()('optional')) { @@ -611,7 +611,7 @@ as_analysis_result <- function(x, ...) { #' musthave_in_anares_names <- ana_name_chker()('musthave_in_objnames') #' musthave_names <- ana_name_chker()('musthave') #' optional_names <- ana_name_chker()('optional') -#' all_names <- ana_name_chker('all') +#' all_names <- ana_name_chker()('all') #' } ana_name_chker <- function() namechecker('name', 'est', 'se', optional = c('df', 'meta')) From e6f6091a9721df340dc96fa086936b8da807a8c6 Mon Sep 17 00:00:00 2001 From: Guanya Peng Date: Wed, 11 May 2022 21:01:37 +0200 Subject: [PATCH 29/84] use anonymous function instead of partial function to avoid using purrr --- R/utilities.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/utilities.R b/R/utilities.R index b3467d1c9..bf0908451 100644 --- a/R/utilities.R +++ b/R/utilities.R @@ -609,7 +609,7 @@ namechecker <- function(..., optional = NULL) { function(msg) { # function to check if elements in list X exist in Y - XsInYs <- function(x, y) vapply(x, purrr::partial(is.element, ... =, y), logical(1)) + XsInYs <- function(x, y) vapply(x, function(.x) .x %in% y, logical(1)) # wrapper to swap order of formal parameter of binary function swap <- function(f) { From 5b51468d28d1ad24e28b97da56c53eb5a9a9b3da Mon Sep 17 00:00:00 2001 From: Guanya Peng Date: Wed, 11 May 2022 21:16:38 +0200 Subject: [PATCH 30/84] change keyword parameter to position parameter so that when required parameter is missing error pops up --- R/analyse.R | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/R/analyse.R b/R/analyse.R index 0805d8137..0ab5b9fff 100644 --- a/R/analyse.R +++ b/R/analyse.R @@ -508,9 +508,9 @@ validate_analyse_pars <- function(results, pars) { #' ana_res_obj <- analysis_result(name = 'trt', est = 1, se = 2, df = as.integer(3), meta = list(visit = 1)) #' } #' @export -analysis_result <- function (name = character(), - est = numeric(), - se = numeric(), +analysis_result <- function (name, + est, + se, df = NULL, meta = NULL) { From 23d23e1b6e2538f895e7984d7e8093dcd1f7f015 Mon Sep 17 00:00:00 2001 From: Guanya Peng Date: Wed, 11 May 2022 23:36:52 +0200 Subject: [PATCH 31/84] add assert functions --- R/analyse.R | 4 +++- R/utilities.R | 29 ++++++++++++++++++++++++++++- 2 files changed, 31 insertions(+), 2 deletions(-) diff --git a/R/analyse.R b/R/analyse.R index 0ab5b9fff..be252d3ab 100644 --- a/R/analyse.R +++ b/R/analyse.R @@ -524,8 +524,10 @@ analysis_result <- function (name, assert_type(se, is.numeric) assert_type(df, is.numeric_or_NA_or_NULL) assert_type(meta, is.list_or_null) + assert_anares_length(name, 1) + assert_anares_length(est, 1) + assert_anares_length(se, 1) - # validators assert_that( se >= 0, msg = "SE must be greater or equal to 0" diff --git a/R/utilities.R b/R/utilities.R index bf0908451..08d11657f 100644 --- a/R/utilities.R +++ b/R/utilities.R @@ -546,10 +546,37 @@ assert_type <- function(what, type <- (function(s) sub(".*\\.", "", s))(howname) assert_that(how(what), - msg = sprintf("%s of analysis_result `%s` is not %s", whatname, what, prettier(type)) + msg = sprintf("%s of analysis_result is not %s", whatname, prettier(type)) ) } +#' Create assert function comparing value +#' +#' @param how A function to generate value from the object to be asserted +#' @param where A character variable indicating the origin of the object to be asserted. Default: `NULL` +#' @param howname A character variable indicating the name of the how function. Default: `deparse(substitute(how))` +assert_value <- function(how, where = NULL, howname = deparse(substitute(how))) { + inwhere <- '' + if (!is.null(where)) inwhere <- paste(' in', where) + function(what, + should, + whatname = deparse(substitute(what))) { + + prettier <- function(x) paste(x, collapse = " ") + + assert_that(how(what) == should, + msg = sprintf("%s of %s%s `%s` is not %s", howname, whatname, inwhere, prettier(how(what)), prettier(should)) + ) + } +} + +#' Assert length of the element in analysis_result +#' +#' @param what The element to be asserted +#' @param should The length expected +#' @param whatname The name of the element. Default: `deparse(substitute(what))` +assert_anares_length <- assert_value(length, where = 'analysis_result') + #' Make a chain of function calls with certain relation function #' @param relation A relation function: `any` or `all` #' @param ... Functions to be chained From 0cfd00c6af10867a5d5281775d61211cfedfc075 Mon Sep 17 00:00:00 2001 From: Guanya Peng Date: Wed, 11 May 2022 23:38:40 +0200 Subject: [PATCH 32/84] update doc --- man/ana_name_chker.Rd | 2 +- man/analysis_result.Rd | 8 +------- man/assert_anares_length.Rd | 18 ++++++++++++++++++ man/assert_value.Rd | 18 ++++++++++++++++++ 4 files changed, 38 insertions(+), 8 deletions(-) create mode 100644 man/assert_anares_length.Rd create mode 100644 man/assert_value.Rd diff --git a/man/ana_name_chker.Rd b/man/ana_name_chker.Rd index 70920c531..f05023210 100644 --- a/man/ana_name_chker.Rd +++ b/man/ana_name_chker.Rd @@ -17,6 +17,6 @@ anares_names_in_musthave <- ana_name_chker()('objnames_in_musthave') musthave_in_anares_names <- ana_name_chker()('musthave_in_objnames') musthave_names <- ana_name_chker()('musthave') optional_names <- ana_name_chker()('optional') -all_names <- ana_name_chker('all') +all_names <- ana_name_chker()('all') } } diff --git a/man/analysis_result.Rd b/man/analysis_result.Rd index 1f5c74dcd..dac96d161 100644 --- a/man/analysis_result.Rd +++ b/man/analysis_result.Rd @@ -4,13 +4,7 @@ \alias{analysis_result} \title{Constructor of analysis result} \usage{ -analysis_result( - name = character(), - est = numeric(), - se = numeric(), - df = NULL, - meta = NULL -) +analysis_result(name, est, se, df = NULL, meta = NULL) } \arguments{ \item{name}{A character variable for the group name} diff --git a/man/assert_anares_length.Rd b/man/assert_anares_length.Rd new file mode 100644 index 000000000..549828546 --- /dev/null +++ b/man/assert_anares_length.Rd @@ -0,0 +1,18 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utilities.R +\name{assert_anares_length} +\alias{assert_anares_length} +\title{Assert length of the element in analysis_result} +\usage{ +assert_anares_length(what, should, whatname = deparse(substitute(what))) +} +\arguments{ +\item{what}{The element to be asserted} + +\item{should}{The length expected} + +\item{whatname}{The name of the element. Default: \code{deparse(substitute(what))}} +} +\description{ +Assert length of the element in analysis_result +} diff --git a/man/assert_value.Rd b/man/assert_value.Rd new file mode 100644 index 000000000..c595fa7e6 --- /dev/null +++ b/man/assert_value.Rd @@ -0,0 +1,18 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utilities.R +\name{assert_value} +\alias{assert_value} +\title{Create assert function comparing value} +\usage{ +assert_value(how, where = NULL, howname = deparse(substitute(how))) +} +\arguments{ +\item{how}{A function to generate value from the object to be asserted} + +\item{where}{A character variable indicating the origin of the object to be asserted. Default: \code{NULL}} + +\item{howname}{A character variable indicating the name of the how function. Default: \code{deparse(substitute(how))}} +} +\description{ +Create assert function comparing value +} From eff5d4a98c7343246591cdb7b60d26c36cf50fce Mon Sep 17 00:00:00 2001 From: Guanya Peng Date: Thu, 12 May 2022 19:35:17 +0200 Subject: [PATCH 33/84] add test --- R/utilities.R | 9 +++-- tests/testthat/test-utilities.R | 68 +++++++++++++++++++++++++++++++++ 2 files changed, 73 insertions(+), 4 deletions(-) diff --git a/R/utilities.R b/R/utilities.R index 08d11657f..f639e4cdb 100644 --- a/R/utilities.R +++ b/R/utilities.R @@ -517,11 +517,12 @@ as_dataframe <- function(x) { #' #' @param name The name of the element to be added to meta #' @param ... The values of the element to be added to meta -#' This function used only internally for ancova +#' This function is used only internally for ancova add_meta <- function (var_names, var_values) { + prettier <- function(x) paste(x, collapse = ' ') assert_that( !is.null(var_names) & !is.null(var_values) & length(var_names) == length(var_values), - msg = paste("Invalid parameters:", var_names, var_values) + msg = sprintf("Invalid parameters: `%s`, `%s`", prettier(var_names), prettier(var_values)) ) out <- as.list(as.character(var_values)) @@ -564,7 +565,7 @@ assert_value <- function(how, where = NULL, howname = deparse(substitute(how))) prettier <- function(x) paste(x, collapse = " ") - assert_that(how(what) == should, + assert_that(all(how(what) == should), msg = sprintf("%s of %s%s `%s` is not %s", howname, whatname, inwhere, prettier(how(what)), prettier(should)) ) } @@ -590,7 +591,7 @@ assert_anares_length <- assert_value(length, where = 'analysis_result') #' } make_chain <- function(relation, ...) { fs <- c(...) - function(...) relation(sapply(fs, function(f) f(...))) + function(...) relation(sapply(fs, function(f) isTRUE(f(...)))) } #' Order a named list by its names according to given character vector diff --git a/tests/testthat/test-utilities.R b/tests/testthat/test-utilities.R index 05da2027b..cb4341862 100644 --- a/tests/testthat/test-utilities.R +++ b/tests/testthat/test-utilities.R @@ -241,3 +241,71 @@ test_that("Stack", { expect_equal(mstack$pop(3), list(7)) expect_error(mstack$pop(1), "items to return") }) + + +test_that("add_meta", { + expect_equal(add_meta('a', 1), list(a='1')) + expect_equal(add_meta(c('a','b','c'), c(1,2,3)), list(a='1', b='2',c='3')) + expect_error(add_meta(c('a','b','c'), 1)) + expect_error(add_meta('a', character())) +}) + + +test_that("assert_type", { + expect_true(assert_type('a', is.character)) + expect_true(assert_type(c('a', 'b', 'c'), is.character)) + expect_true(assert_type(1, is.numeric)) + expect_true(assert_type(c(1,2,3), is.numeric)) + expect_true(assert_type(NA, is.na)) + expect_true(assert_type(NULL, is.null)) + expect_true(assert_type(list(), is.list)) + expect_true(assert_type(data.frame(), is.data.frame)) + expect_true(assert_type(environment(), is.environment)) + expect_true(assert_type(function() NULL, is.function)) + expect_true(assert_type(factor(), is.factor)) + expect_error(assert_type(factor('a'), is.character)) + expect_error(assert_type('a', is.numeric)) + expect_error(assert_type(1, is.null)) + v1 <- NULL + expect_error(assert_type(v1, is.character)) + v2 <- NA + expect_error(assert_type(v2, is.numeric)) + expect_error(assert_type(1, length)) +}) + + +test_that("assert_value", { + expect_true(assert_value(max)(c(1,2,3), 3)) + expect_true(assert_value(length)(list(1,2), 2)) + expect_true(assert_value(names)(list(a=1,b=2,c=3), c('a', 'b', 'c'))) + expect_true(assert_value(mean)(c(a=1,b=2,c=3), 2)) + expect_true(assert_value(abs)(c(a=-1,b=2,c=-3), c(1,2,3))) + f <- function(x) x * 5 + expect_true(assert_value(f)(c(a=1,b=2,c=3), c(a=5,b=10,c=15))) + expect_error(assert_value(identity)(list(a=1,b=2,c=3), list(a=1,b=2,c=3))) + expect_error(assert_value(min)(c(a=1,b=2,c=3), 7)) + expect_error(assert_value(median)(c(a=1,b=2,c=3), 1)) +}) + +test_that("assert_anares_length", { + expect_true(assert_anares_length('a', 1)) + expect_true(assert_anares_length(c(1,2), 2)) + expect_true(assert_anares_length(list(a=1,b=2), 2)) + expect_true(assert_anares_length(data.frame(a=1, b=2), 2)) + expect_true(assert_anares_length(list(), 0)) + expect_true(assert_anares_length(NULL, 0)) + expect_error(assert_anares_length(c('a', 'b', 'c'), 2)) + expect_error(assert_anares_length(c(1,2,3), 2)) + expect_error(assert_anares_length(list(), 2)) + expect_error(assert_anares_length(1, 2)) + expect_error(assert_anares_length(NA, 2)) +}) + +test_that("make_chain", { + is.numeric_or_na <- make_chain(any, is.numeric, is.na) + expect_true(is.numeric_or_na(NA)) + expect_true(is.numeric_or_na(1)) + expect_false(is.numeric_or_na('a')) + expect_false(is.numeric_or_na(list())) + expect_error(make_chain(any, is.numeric, 'a')(1)) +}) From 5453a167ef8463c7645d61c1ddbf7601ca0209f9 Mon Sep 17 00:00:00 2001 From: Guanya Peng Date: Thu, 12 May 2022 21:33:18 +0200 Subject: [PATCH 34/84] update test --- tests/testthat/test-utilities.R | 37 +++++++++++++++++++++++++++++++++ 1 file changed, 37 insertions(+) diff --git a/tests/testthat/test-utilities.R b/tests/testthat/test-utilities.R index cb4341862..9a28dd7cd 100644 --- a/tests/testthat/test-utilities.R +++ b/tests/testthat/test-utilities.R @@ -309,3 +309,40 @@ test_that("make_chain", { expect_false(is.numeric_or_na(list())) expect_error(make_chain(any, is.numeric, 'a')(1)) }) + +test_that("order_list_by_name", { + expect_equal(order_list_by_name(list(a=1,b='x',c=TRUE), c("c", "a", "d", "x", "b", "t"))[[3]], 'x') + expect_true(names(order_list_by_name(list(t=1,v='x'), c("c", "a", "d", "x", "b", "t"))) == 't') + expect_true(all(names(order_list_by_name(list(t=1,v='x',z=2,m=list(), q='t', w=data.frame()), c("z", "t","q", "m"))) == c("z", "t","q", "m"))) + expect_length(order_list_by_name(list(u=1,v='x'), c("c", "a", "d", "x", "b", "t")), 0) + expect_length(order_list_by_name(list(u=1,v='x'), c("c")), 0) +}) + +test_that("base_bind_rows", { + l1 <- list(list(a=1,b=2), list(b=3, c=4)) + expect_equal(nrow(base_bind_rows(l1)), 2) + expect_equal(ncol(base_bind_rows(l1)), 3) + expect_equal(base_bind_rows(l1)[1, 2], 2) + l2 <- list(list(a=1,b=2, c=3), list(a=1, b=3, c=4), list(a=9, b=10, c=12)) + expect_equal(nrow(base_bind_rows(l2)), 3) + expect_equal(base_bind_rows(l2)[2,3], 4) + expect_true(is.na(base_bind_rows(l1)[3,1])) + expect_error(base_bind_rows(list(list(a=1,b=2), list(b=3, c=data.frame())))) + l3 <- list(c(a=1,b=2), c(a=3, c=4)) + expect_error(base_bind_rows(l3)) +}) + +test_that("namechecker", { + chker <- namechecker('a', 'b', 'c', optional = c('d', 'e', 'f')) + expect_type(chker, "closure") + expect_equal(chker('musthave'), c('a', 'b', 'c')) + expect_equal(chker('optional'), c('d', 'e', 'f')) + expect_equal(chker('all'), c('a', 'b', 'c', 'd', 'e', 'f')) + expect_type(chker('musthave_in_objnames'), "closure") + expect_type(chker('objnames_in_musthave'), "closure") + expect_true(all(chker('musthave_in_objnames')(list(a=1)) == list(a=TRUE, b=FALSE, c=FALSE))) + expect_true(all(chker('musthave_in_objnames')(list(a=1, b = 2, c = 3, d = 4)) == list(a=TRUE, b=TRUE, c=TRUE))) + expect_true(all(chker('objnames_in_musthave')(list(b=2, a = 1, d = 2, e = 4, x = 5)) == list(b=TRUE, a=TRUE, d=TRUE, e = TRUE, x = FALSE))) + expect_true(all(chker('objnames_in_musthave')(list(f = 1, x = list(a=2))) == list(f=TRUE, x=FALSE))) + expect_true(all(chker('objnames_in_musthave')(list(y = 1, x = list(a=2))) == list(y=FALSE, x=FALSE))) +}) From 2f6f9b56bf9d6701b4d3689d67b0ab45eb4db438 Mon Sep 17 00:00:00 2001 From: Guanya Peng Date: Fri, 13 May 2022 12:08:15 +0200 Subject: [PATCH 35/84] use better variable name and update function header --- R/analyse.R | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/R/analyse.R b/R/analyse.R index be252d3ab..289ff4693 100644 --- a/R/analyse.R +++ b/R/analyse.R @@ -640,17 +640,16 @@ is.analysis_result <- function(x) { #' Get printable analysis information from an example of analysis result #' -#' The example should not be the complete result of analysis object but a subset of it such as `anaObj$results[[1]]` -#' @param example A list of analysis result A subset of the result of the analysis object for getting enough info to print -#' @param example A character variable for the name of var in result of analysis which is defined from `analysis_result`. Default: 'name' +#' @param example A subset of the result of the analysis object for getting enough info to print. It should not be the complete result of analysis object but a subset of it such as `anaObj$results[[1]]` +#' @param name_of_group A character variable for the name of group variable in the result of analysis which is defined from `analysis_result`. Default: `'name'` #' @param name_of_meta A character variable for the name of meta data in the result of analysis which is defined from `analysis_result`. Default: 'meta' #' @return A data.frame containing the information of the analysis result from the example #' @examples #' \dontrun{ -#' analysis_info(dat, name_of_var = 'name', name_of_meta = 'meta') +#' analysis_info(dat, name_of_group = 'name', name_of_meta = 'meta') #' } #' @importFrom assertthat has_attr -analysis_info <- function(example, name_of_var = 'name', name_of_meta = 'meta') { +analysis_info <- function(example, name_of_group = 'name', name_of_meta = 'meta') { pars_no_meta <- list() pars_with_meta <- list() @@ -671,7 +670,7 @@ analysis_info <- function(example, name_of_var = 'name', name_of_meta = 'meta') if (has_attr(item, name_of_meta)){ meta <- append(meta, index(i, item[[name_of_meta]])) - var <- append(var, list(item[name_of_var])) + var <- append(var, list(item[name_of_group])) pars_with_meta <- append(pars_with_meta, index(i, item[names(item) != name_of_meta])) } else { pars_no_meta <- append(pars_no_meta, index(i, item)) @@ -687,7 +686,7 @@ analysis_info <- function(example, name_of_var = 'name', name_of_meta = 'meta') meta_df <- cbind(base_bind_rows(var), base_bind_rows(meta)) info_df <- tryCatch( - base_left_join(res_df, meta_df, by = c('index', name_of_var)), + base_left_join(res_df, meta_df, by = c('index', name_of_group)), error=function(e) res_df ) From ecb1e6e3d2499436a8e5f7b99e5f18a0fd6a2ed4 Mon Sep 17 00:00:00 2001 From: Guanya Peng Date: Fri, 13 May 2022 12:11:46 +0200 Subject: [PATCH 36/84] udpate add_meta to change how parameter is called and make it more robust --- R/utilities.R | 18 +++++++++++------- man/add_meta.Rd | 9 ++++----- tests/testthat/test-utilities.R | 12 ++++++++---- 3 files changed, 23 insertions(+), 16 deletions(-) diff --git a/R/utilities.R b/R/utilities.R index f639e4cdb..0e23430d8 100644 --- a/R/utilities.R +++ b/R/utilities.R @@ -515,19 +515,23 @@ as_dataframe <- function(x) { #' Add meta information to customerize analysis function #' -#' @param name The name of the element to be added to meta -#' @param ... The values of the element to be added to meta #' This function is used only internally for ancova -add_meta <- function (var_names, var_values) { +#' +#' @param var_name A character variable of the names of the elements to be added to meta +#' @param ... The values of the element to be added to meta. The number of items should be equal to the length of the name parameter +add_meta <- function (var_names, ...) { + var_values <- list(...) prettier <- function(x) paste(x, collapse = ' ') assert_that( - !is.null(var_names) & !is.null(var_values) & length(var_names) == length(var_values), + all(!is.null(var_names), + !is.null(var_values), + all(Vectorize(isTRUE)(!is.na(var_names))), + length(var_names) == length(var_values)), msg = sprintf("Invalid parameters: `%s`, `%s`", prettier(var_names), prettier(var_values)) ) - out <- as.list(as.character(var_values)) - names(out) <- var_names - out + names(var_values) <- var_names + var_values } #' Assert variable's type diff --git a/man/add_meta.Rd b/man/add_meta.Rd index 5f579ddc0..fbb10eaf4 100644 --- a/man/add_meta.Rd +++ b/man/add_meta.Rd @@ -4,14 +4,13 @@ \alias{add_meta} \title{Add meta information to customerize analysis function} \usage{ -add_meta(var_names, var_values) +add_meta(var_names, ...) } \arguments{ -\item{name}{The name of the element to be added to meta} +\item{...}{The values of the element to be added to meta. The number of items should be equal to the length of the name parameter} -\item{...}{The values of the element to be added to meta -This function used only internally for ancova} +\item{var_name}{A character variable of the names of the elements to be added to meta} } \description{ -Add meta information to customerize analysis function +This function is used only internally for ancova } diff --git a/tests/testthat/test-utilities.R b/tests/testthat/test-utilities.R index 9a28dd7cd..2f309391f 100644 --- a/tests/testthat/test-utilities.R +++ b/tests/testthat/test-utilities.R @@ -244,10 +244,14 @@ test_that("Stack", { test_that("add_meta", { - expect_equal(add_meta('a', 1), list(a='1')) - expect_equal(add_meta(c('a','b','c'), c(1,2,3)), list(a='1', b='2',c='3')) - expect_error(add_meta(c('a','b','c'), 1)) - expect_error(add_meta('a', character())) + expect_equal(add_meta('a', 1), list(a=1)) + expect_equal(add_meta(c('a','b','c'), '1','2',3), list(a='1', b='2',c=3)) + expect_equal(add_meta(list('a'), 1), list(a=1)) + expect_error(add_meta(c('a','b','c'), 1, 'c')) + expect_error(add_meta(c('a','b','c'))) + expect_error(add_meta(NULL, 'a')) + expect_error(add_meta(NA, 'a')) + expect_error(add_meta(c('a', NA), 1, 2)) }) From 0e16edb24394a4ba3256b01f8c044472d78c7daa Mon Sep 17 00:00:00 2001 From: Guanya Peng Date: Fri, 13 May 2022 13:34:58 +0200 Subject: [PATCH 37/84] allow NA for se and use anyNA instead of is.na to be more robust --- R/analyse.R | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/R/analyse.R b/R/analyse.R index 289ff4693..9d6558b07 100644 --- a/R/analyse.R +++ b/R/analyse.R @@ -521,19 +521,21 @@ analysis_result <- function (name, assert_type(name, is.character) assert_type(est, is.numeric) - assert_type(se, is.numeric) + assert_type(se, is.numeric_or_NA) assert_type(df, is.numeric_or_NA_or_NULL) assert_type(meta, is.list_or_null) assert_anares_length(name, 1) assert_anares_length(est, 1) assert_anares_length(se, 1) - assert_that( + if (!anyNA(se)) { + assert_that( se >= 0, msg = "SE must be greater or equal to 0" ) + } - if (!is.null(df) & !is.na(df)) { + if (!is.null(df) & !anyNA(df)) { assert_that( df >= 0, msg = "DF must be greater or equal to 0" From dd8a6c5549d49406cca045e76da36d7acbc8a104 Mon Sep 17 00:00:00 2001 From: Guanya Peng Date: Fri, 13 May 2022 15:28:12 +0200 Subject: [PATCH 38/84] change se from required to optional parameter for analysis_result --- R/analyse.R | 33 +++++++++++++++++++++++---------- 1 file changed, 23 insertions(+), 10 deletions(-) diff --git a/R/analyse.R b/R/analyse.R index 9d6558b07..0ef9534bf 100644 --- a/R/analyse.R +++ b/R/analyse.R @@ -510,25 +510,32 @@ validate_analyse_pars <- function(results, pars) { #' @export analysis_result <- function (name, est, - se, + se = NULL, df = NULL, meta = NULL) { # constraints is.numeric_or_NA <- make_chain(any, is.numeric, anyNA) is.numeric_or_NA_or_NULL <- make_chain(any, is.numeric_or_NA, is.null) - is.list_or_null <- make_chain(any, is.list, is.null) + is.list_or_NULL <- make_chain(any, is.list, is.null) + # asssert type for required parameter (directly assert type) assert_type(name, is.character) assert_type(est, is.numeric) - assert_type(se, is.numeric_or_NA) + + # assert type for optional parameter (always include NULL) + assert_type(se, is.numeric_or_NA_or_NULL) assert_type(df, is.numeric_or_NA_or_NULL) - assert_type(meta, is.list_or_null) + assert_type(meta, is.list_or_NULL) + + # assert length for required parameter assert_anares_length(name, 1) assert_anares_length(est, 1) - assert_anares_length(se, 1) - if (!anyNA(se)) { + # assert properties of optional parameters + if (!is.null(se) & !anyNA(se)) { + assert_anares_length(se, 1) + assert_that( se >= 0, msg = "SE must be greater or equal to 0" @@ -536,6 +543,8 @@ analysis_result <- function (name, } if (!is.null(df) & !anyNA(df)) { + assert_anares_length(df, 1) + assert_that( df >= 0, msg = "DF must be greater or equal to 0" @@ -543,13 +552,17 @@ analysis_result <- function (name, } value <- list(name = name, - est = est, - se = se) + est = est) + + # optional parameters + if (!is.null(se)) { + value[['se']] <- se + } - # optional values if (!is.null(df)) { value[['df']] <- df } + if (!is.null(meta)) { value[['meta']] <- meta } @@ -617,7 +630,7 @@ as_analysis_result <- function(x, ...) { #' optional_names <- ana_name_chker()('optional') #' all_names <- ana_name_chker()('all') #' } -ana_name_chker <- function() namechecker('name', 'est', 'se', optional = c('df', 'meta')) +ana_name_chker <- function() namechecker('name', 'est', optional = c('se', 'df', 'meta')) #' Check if an object is in class analysis_result #' From 059a2cb14653dd53a034f4a90cdaff62fecf2b34 Mon Sep 17 00:00:00 2001 From: Guanya Peng Date: Fri, 13 May 2022 15:32:06 +0200 Subject: [PATCH 39/84] update header and doc --- R/analyse.R | 6 +++--- man/analysis_result.Rd | 8 ++++---- 2 files changed, 7 insertions(+), 7 deletions(-) diff --git a/R/analyse.R b/R/analyse.R index 0ef9534bf..e69bf3460 100644 --- a/R/analyse.R +++ b/R/analyse.R @@ -500,12 +500,12 @@ validate_analyse_pars <- function(results, pars) { #' @param df An integer type of numeric variable #' @param meta A list type of variable as meta information #' @details -#' - `se` must be numeric values greater or equal to 0 -#' - `meta` is optional +#' - `se`, `df` and `meta` is optional +#' - `se` and `df` if given must be numeric values greater or equal to 0 #' @return An object of "analysis_result" class #' @examples #' \dontrun{ -#' ana_res_obj <- analysis_result(name = 'trt', est = 1, se = 2, df = as.integer(3), meta = list(visit = 1)) +#' ana_res_obj <- analysis_result(name = 'trt', est = 1, se = 2, df = 3, meta = list(visit = 1)) #' } #' @export analysis_result <- function (name, diff --git a/man/analysis_result.Rd b/man/analysis_result.Rd index dac96d161..52b9d3306 100644 --- a/man/analysis_result.Rd +++ b/man/analysis_result.Rd @@ -4,7 +4,7 @@ \alias{analysis_result} \title{Constructor of analysis result} \usage{ -analysis_result(name, est, se, df = NULL, meta = NULL) +analysis_result(name, est, se = NULL, df = NULL, meta = NULL) } \arguments{ \item{name}{A character variable for the group name} @@ -25,12 +25,12 @@ Construct an analysis result class object whose base type is a list } \details{ \itemize{ -\item \code{se} must be numeric values greater or equal to 0 -\item \code{meta} is optional +\item \code{se}, \code{df} and \code{meta} is optional +\item \code{se} and \code{df} if given must be numeric values greater or equal to 0 } } \examples{ \dontrun{ -ana_res_obj <- analysis_result(name = 'trt', est = 1, se = 2, df = as.integer(3), meta = list(visit = 1)) +ana_res_obj <- analysis_result(name = 'trt', est = 1, se = 2, df = 3, meta = list(visit = 1)) } } From 1e4a8fce6c592b32967c0aa259f17d7013342914 Mon Sep 17 00:00:00 2001 From: Guanya Peng Date: Fri, 13 May 2022 15:32:42 +0200 Subject: [PATCH 40/84] update doc --- man/analysis_info.Rd | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/man/analysis_info.Rd b/man/analysis_info.Rd index 3bae01ab6..830097e15 100644 --- a/man/analysis_info.Rd +++ b/man/analysis_info.Rd @@ -4,10 +4,12 @@ \alias{analysis_info} \title{Get printable analysis information from an example of analysis result} \usage{ -analysis_info(example, name_of_var = "name", name_of_meta = "meta") +analysis_info(example, name_of_group = "name", name_of_meta = "meta") } \arguments{ -\item{example}{A character variable for the name of var in result of analysis which is defined from \code{analysis_result}. Default: 'name'} +\item{example}{A subset of the result of the analysis object for getting enough info to print. It should not be the complete result of analysis object but a subset of it such as \code{anaObj$results[[1]]}} + +\item{name_of_group}{A character variable for the name of group variable in the result of analysis which is defined from \code{analysis_result}. Default: \code{'name'}} \item{name_of_meta}{A character variable for the name of meta data in the result of analysis which is defined from \code{analysis_result}. Default: 'meta'} } @@ -15,10 +17,10 @@ analysis_info(example, name_of_var = "name", name_of_meta = "meta") A data.frame containing the information of the analysis result from the example } \description{ -The example should not be the complete result of analysis object but a subset of it such as \code{anaObj$results[[1]]} +Get printable analysis information from an example of analysis result } \examples{ \dontrun{ -analysis_info(dat, name_of_var = 'name', name_of_meta = 'meta') +analysis_info(dat, name_of_group = 'name', name_of_meta = 'meta') } } From fe8977ecfde033707a61688ad4a035f00cb388be Mon Sep 17 00:00:00 2001 From: Guanya Peng Date: Wed, 18 May 2022 23:09:32 +0200 Subject: [PATCH 41/84] not export as_analysis_result --- R/analyse.R | 1 - 1 file changed, 1 deletion(-) diff --git a/R/analyse.R b/R/analyse.R index e69bf3460..2cee151c8 100644 --- a/R/analyse.R +++ b/R/analyse.R @@ -583,7 +583,6 @@ analysis_result <- function (name, #' \dontrun{ #' ana_res_obj <- as_analysis_result(list(est = 1, se = 2, df = 3), name = 'trt') #' } -#' @export as_analysis_result <- function(x, ...) { new_pars <- list(...) From 09b4b585602a8b3bf18c080bdf4b0bd93af20e33 Mon Sep 17 00:00:00 2001 From: Guanya Peng Date: Wed, 18 May 2022 23:10:03 +0200 Subject: [PATCH 42/84] add test for new analysis functions --- tests/testthat/test-analysis_result.R | 231 ++++++++++++++++++++++++++ 1 file changed, 231 insertions(+) create mode 100644 tests/testthat/test-analysis_result.R diff --git a/tests/testthat/test-analysis_result.R b/tests/testthat/test-analysis_result.R new file mode 100644 index 000000000..c0eed6ccb --- /dev/null +++ b/tests/testthat/test-analysis_result.R @@ -0,0 +1,231 @@ +# Test functions relavent to analysis_result class + +test_that("basic constructions of `analysis_result` work as expected", { + + expect_general <- function(x) { + expect_s3_class(x, c('analysis_result', 'list')) + expect_type(x, 'list') + expect_named(x) + } + + # with optional elements: df, meta + x <- analysis_result(name = 'trt', + est = 1, + se = 2, + df = 3, + meta = list(visit = 1)) + expect_general(x) + expect_length(x, 5) + expect_equal(names(x), c('name', 'est', 'se', 'df', 'meta')) + expect_true(assertthat::has_attr(x, 'meta')) + expect_equal(x$name, 'trt') + expect_equal(x$df, 3) + expect_equal(x$meta, list(visit = 1)) + + # without optional elements + x <- analysis_result(name = 'trt', + est = 1, + se = 2, + meta = list(visit = 1)) + expect_general(x) + expect_length(x, 4) + expect_equal(names(x), c('name', 'est', 'se', 'meta')) + expect_true(has_attr(x, 'meta')) + expect_equal(x$name, 'trt') + expect_equal(x$meta, list(visit = 1)) + + # without optional elements + x <- analysis_result(name = 'trt', + est = 1) + expect_general(x) + expect_length(x, 2) + expect_equal(names(x), c('name', 'est')) + expect_false(has_attr(x, 'meta')) + expect_equal(x$name, 'trt') + expect_equal(x$est, 1) + + # special input: se = NA + x <- analysis_result(name = 'trt', + est = 1, + se = NA) + expect_general(x) + + expect_length(x, 3) + expect_equal(names(x), c('name', 'est', 'se')) + expect_true(is.na(x$se)) + + # special input: df = NA + x <- analysis_result(name = 'trt', + est = 1, + se = 2, + df = NA) + expect_general(x) + expect_length(x, 4) + expect_equal(names(x), c('name', 'est', 'se', 'df')) + expect_true(is.na(x$df)) +}) + + +test_that("incorrect constructions of analysis_result fail", { + + # test parameter type + expect_error( + analysis_result(name = 1, + est = 1, + se = 2, + df = 3, + meta = list(visit = 1)), + "name of analysis_result is not character" + ) + + expect_error( + analysis_result(name = 'a', + est = 'b', + se = 2, + df = 3, + meta = list(visit = 1)), + "est of analysis_result is not numeric" + ) + + expect_error( + analysis_result(name = 'a', + est = 1, + se = list(), + df = 3, + meta = list(visit = 1)), + "se of analysis_result is not numeric or NA or NULL" + ) + + expect_error( + analysis_result(name = 'a', + est = 1, + se = 2, + df = data.frame(), + meta = list(visit = 1)), + "df of analysis_result is not numeric or NA or NULL" + ) + + expect_error( + analysis_result(name = 'a', + est = 1, + se = 2, + df = 3, + meta = 'b'), + "meta of analysis_result is not list or NULL" + ) + + # test parameter length + expect_error( + analysis_result(name = c('a', 'b'), + est = 1, + se = 2, + df = 3, + meta = list(visit = 1)), + "length of name in analysis_result `2` is not 1" + ) + + expect_error( + analysis_result(name = 'a', + est = c(1,2,3), + se = 2, + df = 3, + meta = list(visit = 1)), + "length of est in analysis_result `3` is not 1" + ) + + expect_error( + analysis_result(name = 'a', + est = 1, + se = c(1,2,3,4), + df = 3, + meta = list(visit = 1)), + "length of se in analysis_result `4` is not 1" + ) + + expect_error( + analysis_result(name = 'a', + est = 1, + se = 2, + df = c(1,2,3,4,5), + meta = list(visit = 1)), + "length of df in analysis_result `5` is not 1" + ) +}) + +# Test for as_analysis_result +# This test needs to be updated accordingly if ana_name_chker has been udpated +test_that("as_analysis_result works as expected", { + expect_general <- function(x) { + expect_s3_class(x, c("analysis_result", "list")) + expect_equal(typeof(x), "list") + expect_equal(x$name, 'a') + expect_equal(x$est, 1) + expect_equal(x$se, 2) + } + + x <- as_analysis_result(list(name='a', est=1, se = 2)) + expect_general(x) + + x <- as_analysis_result(list(name='a', est=1, se = 2, meta = list(visit = 1))) + expect_general(x) + expect_true(has_attr(x, 'meta')) + + # Test error input + expect_error(as_analysis_result(list(name='a'))) + expect_false('met' %in% names(as_analysis_result(list(name='a', est=1, se = 2, met = list(visit = 1))))) + } +) + + +test_that("ana_name_chker works as expected", { + f <- ana_name_chker() + expect_equal(class(f), "function") + expect_equal(class(f('musthave_in_objnames')), 'function') + expect_equal(class(f('objnames_in_musthave')), 'function') + expect_equal(typeof(f('musthave')), 'character') + expect_equal(typeof(f('optional')), 'character') +}) + +test_that("is.analysis_result works as expected", { + x <- analysis_result(name = 'trt', + est = 1, + se = 2, + df = 3, + meta = list(visit = 1)) + expect_true(is.analysis_result(x)) + expect_false(is.analysis_result(list(a=1))) + expect_false(is.analysis_result(structure(list(a=1), class=c('analyis_result', 'list')))) +}) + +test_that("analysis_info works as expected", { + + # check for normal input + test_names <- c('a', 'b', 'c', 'd', 'e', 'f', 'g') + test_ests <- seq(length(test_names)) + test_ses <- test_ests * 0.1 + test_dfs<- test_ests * 5 + test_metas <- lapply(test_ests, function(x) list(visit=x)) + + tab <- mapply(function(a,b,c,d,e) analysis_result(name=a, est=b, se=c, df=d, meta=e), + test_names, test_ests, test_ses, test_dfs, test_metas, SIMPLIFY = FALSE) + + x <- analysis_info(tab) + + expect_equal(class(x), "data.frame") + expect_equal(nrow(x), 7) + expect_equal(ncol(x), 5) + + + # check for NA and NULL input + test_ses[[2]] <- NA + test_dfs[[4]] <- NA + + tab <- mapply(function(a,b,c,d,e) analysis_result(name=a, est=b, se=c, df=d, meta=e), + test_names, test_ests, test_ses, test_dfs, test_metas, SIMPLIFY = FALSE) + tab[[1]] <- tab[[1]][-5] + tab[[1]] <- as_analysis_result(tab[[1]]) + x <- analysis_info(tab) + expect_true(is.na(x[[2, 3]])) + expect_true(is.na(x[[4, 4]])) + expect_true(is.na(x[[1, 5]])) +}) From a687a2c1c7715e5a610d5c7c73c77bedbd0b0bde Mon Sep 17 00:00:00 2001 From: Guanya Peng Date: Thu, 19 May 2022 16:36:39 +0200 Subject: [PATCH 43/84] modify test for original analysis functions --- tests/testthat/test-analyse.R | 113 +++++++++++++++++----------------- 1 file changed, 55 insertions(+), 58 deletions(-) diff --git a/tests/testthat/test-analyse.R b/tests/testthat/test-analyse.R index 697d2ada1..53aaf1dd8 100644 --- a/tests/testthat/test-analyse.R +++ b/tests/testthat/test-analyse.R @@ -10,8 +10,8 @@ test_that("basic constructions of `analysis` work as expected",{ x <- as_analysis( results = list( - list(p1 = list("est" = 1)), - list(p1 = list("est" = 2)) + list(analysis_result(name = 'p1', est = 1)), # A nested structure is necessary here. The top level is a full result list. The 2nd level is each imputation. The 3rd level is each individual analysis result inside each imputation. + list(analysis_result(name = 'p1', est = 2)) ), method = method_condmean(n_samples = 1) ) @@ -20,8 +20,8 @@ test_that("basic constructions of `analysis` work as expected",{ x <- as_analysis( results = list( - list(p1 = list("est" = 1)), - list(p1 = list("est" = 2)) + list(analysis_result(name = 'p1', est = 1)), + list(analysis_result(name = 'p1', est = 2)) ), method = method_condmean(type = "jackknife") ) @@ -30,8 +30,8 @@ test_that("basic constructions of `analysis` work as expected",{ x <- as_analysis( results = list( - list(p1 = list("est" = 1, "df" = 4, "se" = 1)), - list(p1 = list("est" = 2, "df" = 3, "se" = 3)) + list(analysis_result(name = 'p1', est = 1, df = 4, se = 1)), + list(analysis_result(name = 'p1', est = 2, df = 3, se = 3)) ), method = method_bayes(n_samples = 2) ) @@ -40,8 +40,8 @@ test_that("basic constructions of `analysis` work as expected",{ x <- as_analysis( results = list( - list(p1 = list("est" = 1, "df" = 4, "se" = 1)), - list(p1 = list("est" = 2, "df" = 3, "se" = 3)) + list(analysis_result(name = 'p1', est = 1, df = 4, se = 1)), + list(analysis_result(name = 'p1', est = 2, df = 3, se = 3)) ), method = method_approxbayes(n_samples = 2) ) @@ -50,8 +50,8 @@ test_that("basic constructions of `analysis` work as expected",{ x <- as_analysis( results = list( - list(p1 = list("est" = 1, "df" = 4, "se" = NA)), - list(p1 = list("est" = 2, "df" = 3, "se" = NA)) + list(analysis_result(name = 'p1', est = 1, df = 4, se = NA)), + list(analysis_result(name = 'p1', est = 2, df = 3, se = NA)) ), method = method_bayes(n_samples = 2) ) @@ -60,13 +60,12 @@ test_that("basic constructions of `analysis` work as expected",{ x <- as_analysis( results = list( - list(p1 = list("est" = 1, "df" = 4, "se" = NA)), - list(p1 = list("est" = 2, "df" = 3, "se" = NA)) + list(analysis_result(name = 'p1', est = 1, df = 4, se = NA)), + list(analysis_result(name = 'p1', est = 2, df = 3, se = NA)) ), method = method_approxbayes(n_samples = 2) ) expect_true(validate(x)) - }) @@ -76,8 +75,7 @@ test_that("incorrect constructions of as_analysis fail", { expect_error( as_analysis( results = list( - list(p1 = list("est" = 1)), - list(p1 = list("est" = 2)) + list(analysis_result(name = 'p1', est = 1), analysis_result(name = 'p1', est = 2)) ), method = method_condmean(n_samples = 2) ), @@ -87,8 +85,8 @@ test_that("incorrect constructions of as_analysis fail", { expect_error( as_analysis( results = list( - list(p1 = list("est" = 1, "df" = 4, "se" = 1)), - list(p1 = list("est" = 2, "df" = 3, "se" = 3)) + list(analysis_result(name = 'p1', est = 1, df = 4, se = 1)), + list(analysis_result(name = 'p1', est = 2, df = 3, se = 3)) ), method = method_bayes(n_samples = 3) ), @@ -98,8 +96,8 @@ test_that("incorrect constructions of as_analysis fail", { expect_error( as_analysis( results = list( - list(p1 = list("est" = 1, "df" = 4, "se" = 1)), - list(p1 = list("est" = 2, "df" = 3, "se" = 3)) + list(analysis_result(name = 'p1', est = 1, df = 4, se = 1)), + list(analysis_result(name = 'p1', est = 2, df = 3, se = 3)) ), method = method_approxbayes(n_samples = 3) ), @@ -111,80 +109,79 @@ test_that("incorrect constructions of as_analysis fail", { expect_error( as_analysis( results = list( - list(p1 = list("est1" = 1)), - list(p1 = list("est1" = 2)) + list(analysis_result(name = 'p1', est1 = 1), analysis_result(name = 'p1', est1 = 2)), ), method = method_condmean(n_samples = 1) ), - "`est`" + "unused argument \\(est1 = 1\\)" ) expect_error( as_analysis( results = list( - list(p1 = list("est" = 1, "df1" = 4, "se" = 1)), - list(p1 = list("est" = 2, "df1" = 3, "se" = 3)) + list(analysis_result(name = 'p1', est = 1, df1 = 4, se = 1)), + list(analysis_result(name = 'p1', est = 2, df1 = 3, se = 3)) ), method = method_approxbayes(n_samples = 2) ), - "`df`" + "unused argument \\(df1 = 4\\)" ) expect_error( as_analysis( results = list( - list(p1 = list("est" = 1, "df1" = 4, "se" = 1)), - list(p1 = list("est" = 2, "df1" = 3, "se" = 3)) + list(analysis_result(name = 'p1', est = 1, df1 = 4, se = 1)), + list(analysis_result(name = 'p1', est = 2, df1 = 3, se = 3)) ), method = method_bayes(n_samples = 2) ), - "`df`" + "unused argument \\(df1 = 4\\)" ) expect_error( as_analysis( results = list( - list(p1 = list("est" = 1, "df" = 4, "se1" = 1)), - list(p1 = list("est" = 2, "df" = 3, "se1" = 3)) + list(analysis_result(name = 'p1', est = 1, df = 4, se1 = 1)), + list(analysis_result(name = 'p1', est = 2, df = 3, se1 = 3)) ), method = method_bayes(n_samples = 2) ), - "`se`" + "unused argument \\(se1 = 1\\)" ) expect_error( as_analysis( results = list( - list(p1 = list("est" = 1, "df" = 4, "se1" = 1)), - list(p1 = list("est1" = 2, "df" = 3, "se1" = 3)) + list(analysis_result(name = 'p1', est = 1, df = 4, se1 = 1)), + list(analysis_result(name = 'p1', est1 = 2, df = 3, se1 = 3)) ), method = method_condmean(type = "jackknife") ), - "`est`" + "unused argument \\(se1 = 1\\)" ) - ### Inconsistent analysis parameters - expect_error( - as_analysis( - results = list( - list(p1 = list("est" = 1)), - list(p2 = list("est" = 2)) - ), - method = method_condmean(n_sample = 1) - ), - "identically named elements" - ) + ### Inconsistent analysis parameters ## Not sure what this is supposed to test + # expect_error( + # as_analysis( + # results = list( + # list(p1 = list("est" = 1)), + # list(p2 = list("est" = 2)) + # ), + # method = method_condmean(n_sample = 1) + # ), + # "identically named elements" + # ) expect_error( as_analysis( results = list( list(list("est" = 1)), - list(p1 = list("est" = 2)) + list(analysis_result(name = 'p1', est = 2)) ), method = method_condmean(n_sample = 1) ), - "results must be named lists" + "Individual analysis result must be type of analysis_result" ) expect_error( @@ -195,37 +192,37 @@ test_that("incorrect constructions of as_analysis fail", { ), method = method_condmean(n_sample = 1) ), - "results must be named lists" + "Individual analysis result must be type of analysis_result" ) ### Invalid values expect_error( as_analysis( results = list( - list(p1 = list("est" = NA)), - list(p1 = list("est" = 2)) + list(analysis_result(name = 'p1', est = NA)), + list(analysis_result(name = 'p1', est = 2)) ), method = method_condmean(n_sample = 1) ), - "`est` contains missing values" + "est of analysis_result is not numeric" ) expect_error( as_analysis( results = list( - list(p1 = list("est" = "a")), - list(p1 = list("est" = 2)) + list(analysis_result(name = 'p1', est = 'a')), + list(analysis_result(name = 'p1', est = 2)) ), method = method_condmean(n_sample = 1) ), - "result is type 'character'" + "est of analysis_result is not numeric" ) expect_error( as_analysis( results = list( - list(p1 = list("est" = 1, "df" = 4, "se" = NA)), - list(p1 = list("est" = 2, "df" = 3, "se" = 3)) + list(analysis_result(name = 'p1', est = 1, df = 4, se = NA)), + list(analysis_result(name = 'p1', est = 2, df = 3, se = 3)) ), method = method_bayes(n_sample = 2) ), @@ -234,8 +231,8 @@ test_that("incorrect constructions of as_analysis fail", { x <- as_analysis( results = list( - list(p1 = list("est" = 1, "df" = 4, "se" = NA)), - list(p1 = list("est" = 2, "df" = 3, "se" = 3)) + list(analysis_result(name = 'p1', est = 1, df = 4, se = NA)), + list(analysis_result(name = 'p1', est = 2, df = 3, se = 3)) ), method = method_condmean(n_sample = 1) ) From 74ba1d6087404d4473a2696c42f4803b097546d0 Mon Sep 17 00:00:00 2001 From: Guanya Peng Date: Thu, 19 May 2022 16:37:30 +0200 Subject: [PATCH 44/84] update namespace --- NAMESPACE | 1 - 1 file changed, 1 deletion(-) diff --git a/NAMESPACE b/NAMESPACE index 9d32fdca9..587092b8c 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -39,7 +39,6 @@ export(add_class) export(analyse) export(analysis_result) export(ancova) -export(as_analysis_result) export(as_class) export(as_vcov) export(delta_template) From 7de156f2b6a197310339642cfc44f0b180653623 Mon Sep 17 00:00:00 2001 From: Guanya Peng Date: Fri, 20 May 2022 12:55:20 +0200 Subject: [PATCH 45/84] update utils --- R/utilities.R | 52 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 52 insertions(+) diff --git a/R/utilities.R b/R/utilities.R index 0e23430d8..840cc501a 100644 --- a/R/utilities.R +++ b/R/utilities.R @@ -673,3 +673,55 @@ namechecker <- function(..., optional = NULL) { dispatch[[msg]] } } + +#' Higher-order function to compose function n-times +#' +#' Taking a function as f argument, this function convert it to another function apply this function n-times: +#' n = 1: f(x) ==> f(x) +#' n = 2: f(x) ==> f(f(x)) +#' n = 4: f(x) ==> f(f(f(f(x))) +#' @param f function to be converted to composed version +#' @param n times to be composed +#' @examples +#' \dontrun{ +#' add_one <- function (x) x + 1 +#' add_two <- compose_n(add_one, 2) +#' add_two(5) # This equivalents to add_one(add_one(5)) and returns 7 +#' +#' } +compose_n <- function(f, n) { + function(x) { + if (n <= 0) x + else f(compose_n(f, n-1)(x)) + } +} + +#' Apply function at last N levels of a nested list +#' +#' Recursively traverse a nested list and apply a function at the Nth level backward counting from deepest level +#' @param lst a list to be applied by the function +#' @param f a function to apply on `lst` +#' @param n a numeric value indicating the nth level to be applied backward counting from deepest level +#' @examples +#' \dontrun{ +#' dt <- list(a1=list( +#' b11=list(c111=1, c112=2,c113=3), +#' b12=list(c121=4, c122=5,c123=6)), +#' a2=list( +#' b21=list(c211=7, c212=8,c213=9), +#' b22=list(c221=10, c222=11,c223=12)) +#' ) +#' ) +#' +#' back_apply_at(dt, function(x) x+1, 1) # This will apply `function(x) x+1` to the deepest level of `dt`, i.e. 1st level counting backward from deepest level +#' +#'} +back_apply_at <- function(lst, f, n) { + lapply(lst, + function(sublst) { + nextNlevel <- compose_n(function(x) x[[1]], n-1) + if (!is.list(nextNlevel(sublst))) f(sublst) + else back_apply_at(sublst, f, n) + } + ) +} From 9330ff8b16c40fd7060069726c4d854e0db149b8 Mon Sep 17 00:00:00 2001 From: Guanya Peng Date: Fri, 20 May 2022 12:55:56 +0200 Subject: [PATCH 46/84] doc for new utils funcionts --- man/back_apply_at.Rd | 33 +++++++++++++++++++++++++++++++++ man/compose_n.Rd | 27 +++++++++++++++++++++++++++ 2 files changed, 60 insertions(+) create mode 100644 man/back_apply_at.Rd create mode 100644 man/compose_n.Rd diff --git a/man/back_apply_at.Rd b/man/back_apply_at.Rd new file mode 100644 index 000000000..a658c7925 --- /dev/null +++ b/man/back_apply_at.Rd @@ -0,0 +1,33 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utilities.R +\name{back_apply_at} +\alias{back_apply_at} +\title{Apply function at last N levels of a nested list} +\usage{ +back_apply_at(lst, f, n) +} +\arguments{ +\item{lst}{a list to be applied by the function} + +\item{f}{a function to apply on \code{lst}} + +\item{n}{a numeric value indicating the nth level to be applied backward counting from deepest level} +} +\description{ +Recursively traverse a nested list and apply a function at the Nth level backward counting from deepest level +} +\examples{ +\dontrun{ +dt <- list(a1=list( + b11=list(c111=1, c112=2,c113=3), + b12=list(c121=4, c122=5,c123=6)), + a2=list( + b21=list(c211=7, c212=8,c213=9), + b22=list(c221=10, c222=11,c223=12)) + ) + ) + +back_apply_at(dt, function(x) x+1, 1) # This will apply `function(x) x+1` to the deepest level of `dt`, i.e. 1st level counting backward from deepest level + +} +} diff --git a/man/compose_n.Rd b/man/compose_n.Rd new file mode 100644 index 000000000..1d06537cf --- /dev/null +++ b/man/compose_n.Rd @@ -0,0 +1,27 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utilities.R +\name{compose_n} +\alias{compose_n} +\title{Higher-order function to compose function n-times} +\usage{ +compose_n(f, n) +} +\arguments{ +\item{f}{function to be converted to composed version} + +\item{n}{times to be composed} +} +\description{ +Taking a function as f argument, this function convert it to another function apply this function n-times: +n = 1: f(x) ==> f(x) +n = 2: f(x) ==> f(f(x)) +n = 4: f(x) ==> f(f(f(f(x))) +} +\examples{ +\dontrun{ +add_one <- function (x) x + 1 +add_two <- compose_n(add_one, 2) +add_two(5) # This equivalents to add_one(add_one(5)) and returns 7 + +} +} From bbdc1707f3fe84dd6c4c145ec42da6f6c8da190f Mon Sep 17 00:00:00 2001 From: Guanya Peng Date: Fri, 20 May 2022 12:57:13 +0200 Subject: [PATCH 47/84] update check in as_analysis --- R/analyse.R | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/R/analyse.R b/R/analyse.R index 2cee151c8..ecd5a2802 100644 --- a/R/analyse.R +++ b/R/analyse.R @@ -443,12 +443,13 @@ validate_analyse_pars <- function(results, pars) { assert_that( length(results[[1]]) != 0, - all(vapply(results, function(Xs) all(vapply(Xs, function(X) is.analysis_result(X), logical(1))), logical(1))), + all(vapply(results, function(Xs) + all(vapply(Xs, function(X) is.analysis_result(X), logical(1))), logical(1))), msg = "Individual analysis result must be type of analysis_result" ) - results_names <- lapply(results, function(x) unique(names(x))) - results_names_flat <- unlist(results_names, use.names = FALSE) + results_names <- back_apply_at(results, function(x) x[['name']], 2) # get the "name" element of 2nd deepest level list which corresponds to analysis_result + results_names_flat <- unique(unlist(results_names, use.names = FALSE)) results_names_count <- table(results_names_flat) assert_that( From 1a0d47cc22b3c3902b37428ce3300f986045ba12 Mon Sep 17 00:00:00 2001 From: Guanya Peng Date: Fri, 20 May 2022 12:57:40 +0200 Subject: [PATCH 48/84] update test for analysis functions --- tests/testthat/test-analyse.R | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/tests/testthat/test-analyse.R b/tests/testthat/test-analyse.R index 53aaf1dd8..6b5729b0c 100644 --- a/tests/testthat/test-analyse.R +++ b/tests/testthat/test-analyse.R @@ -162,16 +162,16 @@ test_that("incorrect constructions of as_analysis fail", { ### Inconsistent analysis parameters ## Not sure what this is supposed to test - # expect_error( - # as_analysis( - # results = list( - # list(p1 = list("est" = 1)), - # list(p2 = list("est" = 2)) - # ), - # method = method_condmean(n_sample = 1) - # ), - # "identically named elements" - # ) + expect_error( + as_analysis( + results = list( + list(analysis_result(name = 'p1', est = 1)), # 1st imputation contains one analysis with name "p1" + list(analysis_result(name = 'p2', est = 2)) # 2nd imputation contains one analysis with name "p2" + ), + method = method_condmean(n_sample = 1) + ), + "identically named elements" + ) expect_error( as_analysis( From f0e88b154ebc39f831b5ca380e638476f1d01671 Mon Sep 17 00:00:00 2001 From: Guanya Peng Date: Fri, 20 May 2022 13:12:52 +0200 Subject: [PATCH 49/84] fix wrong counting of analysis names --- R/analyse.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/analyse.R b/R/analyse.R index ecd5a2802..522466026 100644 --- a/R/analyse.R +++ b/R/analyse.R @@ -449,7 +449,7 @@ validate_analyse_pars <- function(results, pars) { ) results_names <- back_apply_at(results, function(x) x[['name']], 2) # get the "name" element of 2nd deepest level list which corresponds to analysis_result - results_names_flat <- unique(unlist(results_names, use.names = FALSE)) + results_names_flat <- unlist(results_names, use.names = FALSE) results_names_count <- table(results_names_flat) assert_that( From 2f7956db51e32d61de78f5469df5afad0b32a84e Mon Sep 17 00:00:00 2001 From: Guanya Peng Date: Sat, 21 May 2022 15:15:18 +0200 Subject: [PATCH 50/84] add test for util functions compose_n and back_apply_at --- tests/testthat/test-utilities.R | 46 +++++++++++++++++++++++++++++++++ 1 file changed, 46 insertions(+) diff --git a/tests/testthat/test-utilities.R b/tests/testthat/test-utilities.R index 2f309391f..a9c273f26 100644 --- a/tests/testthat/test-utilities.R +++ b/tests/testthat/test-utilities.R @@ -350,3 +350,49 @@ test_that("namechecker", { expect_true(all(chker('objnames_in_musthave')(list(f = 1, x = list(a=2))) == list(f=TRUE, x=FALSE))) expect_true(all(chker('objnames_in_musthave')(list(y = 1, x = list(a=2))) == list(y=FALSE, x=FALSE))) }) + +test_that("compose_n", { + # addition + add_one <- function (x) x + 1 + add_five <- compose_n(add_one, 5) + expect_equal(add_five(3), 8) + + # yin yang + flip <- function(x) -x + odd_numbers <- seq(1, 99, 2) + even_numbers <- seq(2, 100, 2) + yin <- sapply(odd_numbers, function(x) compose_n(flip, x)) + yang <- sapply(even_numbers, function(x) compose_n(flip, x)) + expect_true(all(sapply(yin, do.call, list(100)) < 0)) + expect_true(all(sapply(yang, do.call, list(100)) > 0)) + + # base case + expect_equal(compose_n(abs, 0)(-5), -5) +}) + +test_that("back_apply_at", { + x <- list( + a1=list( + b11=list(c111=1, c112=2,c113=3), + b12=list(c121=4, c122=5,c123=6)), + a2=list( + b21=list(c211=7, c212=8,c213=9), + b22=list(c221=10, c222=11,c223=12)) + ) + + y <- back_apply_at(x, function(x) x+1, 1) + expect_equal(y$a2$b22$c221, 11) + expect_equal(y$a1$b11$c113, 4) + expect_identical(y$a1$b12, list(c121=5, c122=6,c123=7)) + + z <- back_apply_at(x, class, 2) + expect_equal(z$a1$b11, "list") + expect_equal(z$a2$b21, "list") + expect_error(z$a1$b11$c111) + + zz <- back_apply_at(x, length, 3) + expect_equal(zz$a1, 2) + expect_equal(zz$a2, 2) + expect_error(zz$a2$b21) + expect_error(zz$a1$b12$c121) +}) From 56e9b653ad1719fb4399fd2d3f59e189321cd787 Mon Sep 17 00:00:00 2001 From: Guanya Peng Date: Sun, 22 May 2022 00:03:26 +0200 Subject: [PATCH 51/84] add extract analysis result function --- R/analyse.R | 66 +++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 66 insertions(+) diff --git a/R/analyse.R b/R/analyse.R index 522466026..729e29bb7 100644 --- a/R/analyse.R +++ b/R/analyse.R @@ -707,3 +707,69 @@ analysis_info <- function(example, name_of_group = 'name', name_of_meta = 'meta' subset(info_df, select = -index) } + +#' Extract analysis_result from a list of analysis_results by matching names and values +#' +#' The function returns a list of all analysis_results in the input list that match the values with names specified via keywords parameters of the function. +#' If no value matches the specified name in any analysis_result containing in the given list or +#' the specified name does not existed in any analysis_result, the function returns an empty list `list()`. +#' +#' @param results A list of analysis_result +#' @param ... Keywords parameters with the name and value matching the element in analysis result to be extracted +#' @return A list of matched analysis results +#' @examples +#' \dontrun{ +#' results <- list( +#' analysis_result( +#' name = 'trt', +#' est = 1, +#' se = 2, +#' df = 3, +#' meta = list(visit = 'vis1') +#' ) +#' ) +#' +#' extract_analysis_result(results, name = 'trt') +#' extract_analysis_result(results, est = 1) +#' extract_analysis_result(results, name = 'trt', meta = list(visit = 'vis1')) +#' extract_analysis_result(results, name = 'trt2') +# +#' } +extract_analysis_result <- function(results, ...){ + dots <- list(...) + meta <- list() + has_meta <- FALSE + if ('meta' %in% names(dots)) { + meta <- dots[['meta']] + dots[['meta']] <- NULL + has_meta <- TRUE + } + + names_match_values <- function(obj, named_values=dots) { + mapply(function(label, value) obj[[label]] == value, + names(named_values), named_values, SIMPLIFY = TRUE, USE.NAMES = FALSE) + } + + extract_match <- function(obj, named_values=dots, constrain = identity) { + Filter(function(item) all( + names_match_values(constrain(item), named_values)), + obj) + } + + search_in_meta <- function(obj) obj[['meta']] + + extract_meta <- function(obj) extract_match(obj, named_values = meta, constrain = search_in_meta) + + tryCatch({ + matches_except_meta <- extract_match(results) + + if (has_meta) { + extract_meta(matches_except_meta) + } else { + matches_except_meta + } + }, + warning = function(w) { + list() + }) +} From 5b4b53a59c10539b3707ea9422046ebdc8d23675 Mon Sep 17 00:00:00 2001 From: Guanya Peng Date: Sun, 22 May 2022 00:06:04 +0200 Subject: [PATCH 52/84] update test-ancova --- tests/testthat/test-ancova.R | 16 ++++++++++------ 1 file changed, 10 insertions(+), 6 deletions(-) diff --git a/tests/testthat/test-ancova.R b/tests/testthat/test-ancova.R index eee1f1a49..dfecca768 100644 --- a/tests/testthat/test-ancova.R +++ b/tests/testthat/test-ancova.R @@ -29,16 +29,20 @@ test_that("ancova", { mod <- lm(out ~ age1 + age2 + grp, data = dat) result_expected <- list( - "trt_vis1" = list( - "est" = mod$coefficients[[4]], - "se" = sqrt(vcov(mod)[4, 4]), - "df" = df.residual(mod) + analysis_result( + name = 'trt', + est = mod$coefficients[[4]], + se = sqrt(vcov(mod)[4, 4]), + df = df.residual(mod), + meta = list(visit = 'vis1') ) ) - result_actual <- ancova( + results_actual <- ancova( dat, list(outcome = "out", group = "grp", covariates = c("age1", "age2"), visit = "visit") - )["trt_vis1"] + ) + + result_actual <- extract_analysis_result(results_actual, name = 'trt', meta = list(visit = 'vis1')) expect_equal(result_expected, result_actual) From 302f3515a7986d3dee77439289272b0508e42c5a Mon Sep 17 00:00:00 2001 From: Guanya Peng Date: Sun, 22 May 2022 09:56:21 +0200 Subject: [PATCH 53/84] add assertation to extract_analysis_result --- R/analyse.R | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/R/analyse.R b/R/analyse.R index 729e29bb7..e8bce04f2 100644 --- a/R/analyse.R +++ b/R/analyse.R @@ -737,6 +737,11 @@ analysis_info <- function(example, name_of_group = 'name', name_of_meta = 'meta' #' } extract_analysis_result <- function(results, ...){ dots <- list(...) + assert_that(all(!is.null(names(dots)), + length(names(dots)) > 0, + !any(grepl("^$", names(dots)))), + msg = "Invalide parameters. Only key-word parameters are valide.") + meta <- list() has_meta <- FALSE if ('meta' %in% names(dots)) { @@ -746,9 +751,9 @@ extract_analysis_result <- function(results, ...){ } names_match_values <- function(obj, named_values=dots) { - mapply(function(label, value) obj[[label]] == value, + mapply(function(label, value) isTRUE(obj[[label]] == value), names(named_values), named_values, SIMPLIFY = TRUE, USE.NAMES = FALSE) - } + } # When SIMPLIFY = TRUE, coercion can happen on logical(0) which generates WARNINGS. isTRUE is used to avoid coercion and make the code more robust extract_match <- function(obj, named_values=dots, constrain = identity) { Filter(function(item) all( From 02975cbf1c6409b575116378ad6c723da16fa20e Mon Sep 17 00:00:00 2001 From: Guanya Peng Date: Sun, 22 May 2022 10:59:28 +0200 Subject: [PATCH 54/84] update test ancova --- tests/testthat/test-ancova.R | 30 +++++++++++++++++++----------- 1 file changed, 19 insertions(+), 11 deletions(-) diff --git a/tests/testthat/test-ancova.R b/tests/testthat/test-ancova.R index dfecca768..24c1a4f8c 100644 --- a/tests/testthat/test-ancova.R +++ b/tests/testthat/test-ancova.R @@ -67,13 +67,17 @@ test_that("ancova", { mod <- lm(out ~ grp, data = dat) result_expected <- list( - "trt_ 1" = list( - "est" = mod$coefficients[[2]], - "se" = sqrt(vcov(mod)[2, 2]), - "df" = df.residual(mod) + analysis_result( + name = "trt", + est = mod$coefficients[[2]], + se = sqrt(vcov(mod)[2, 2]), + df = df.residual(mod), + meta = list(visit = " 1") ) ) - result_actual <- ancova(dat, list(outcome = "out", group = "grp", visit = "ivis"))["trt_ 1"] + results_actual <- ancova(dat, list(outcome = "out", group = "grp", visit = "ivis")) + + result_actual <- extract_analysis_result(results_actual, name = "trt", meta = list(visit = " 1")) expect_equal(result_expected, result_actual) @@ -97,14 +101,16 @@ test_that("ancova", { mod <- lm(out ~ age1 + age2 + grp, data = dat) result_expected <- list( - "trt_visit 1" = list( - "est" = mod$coefficients[[4]], - "se" = sqrt(vcov(mod)[4, 4]), - "df" = df.residual(mod) + analysis_result( + name = "trt", + est = mod$coefficients[[4]], + se = sqrt(vcov(mod)[4, 4]), + df = df.residual(mod), + meta = list(visit = "visit 1") ) ) - result_actual <- ancova( + results_actual <- ancova( dat, list( outcome = "out", @@ -113,7 +119,9 @@ test_that("ancova", { visit = "vis" ), visits = "visit 1" - )["trt_visit 1"] + ) + + result_actual <- extract_analysis_result(results_actual, name = "trt", meta = list(visit = "visit 1")) expect_equal(result_expected, result_actual) From ebc556fd6972a07521d3246d38d80a062fff411f Mon Sep 17 00:00:00 2001 From: Guanya Peng Date: Mon, 23 May 2022 21:05:29 +0200 Subject: [PATCH 55/84] update all tests functions in test-ancova --- tests/testthat/test-ancova.R | 53 ++++++++++++++++++++++-------------- 1 file changed, 32 insertions(+), 21 deletions(-) diff --git a/tests/testthat/test-ancova.R b/tests/testthat/test-ancova.R index 24c1a4f8c..fbb524f6d 100644 --- a/tests/testthat/test-ancova.R +++ b/tests/testthat/test-ancova.R @@ -144,14 +144,16 @@ test_that("ancova", { mod <- lm(out ~ age1 + age2 + grp, data = filter(dat, vis == "visit 1")) result_expected <- list( - "trt_visit 1" = list( - "est" = mod$coefficients[[4]], - "se" = sqrt(vcov(mod)[4, 4]), - "df" = df.residual(mod) + analysis_result( + name = 'trt', + est = mod$coefficients[[4]], + se = sqrt(vcov(mod)[4, 4]), + df = df.residual(mod), + meta = list(visit = 'visit 1') ) ) - result_actual <- ancova( + results_actual <- ancova( dat, list( outcome = "out", @@ -160,11 +162,13 @@ test_that("ancova", { visit = "vis" ), visits = "visit 1" - )["trt_visit 1"] + ) + + result_actual <- extract_analysis_result(results_actual, name = "trt", meta = list(visit = "visit 1")) expect_equal(result_expected, result_actual) - result_actual <- ancova( + result_actuals <- ancova( dat, list( outcome = "out", @@ -173,11 +177,13 @@ test_that("ancova", { visit = "vis" ), visits = c("visit 1", "visit 2") - )["trt_visit 1"] + ) + + result_actual <- extract_analysis_result(results_actual, name = "trt", meta = list(visit = "visit 1")) expect_equal(result_expected, result_actual) - result_actual <- ancova( + results_actual <- ancova( dat, list( outcome = "out", @@ -191,22 +197,27 @@ test_that("ancova", { mod <- lm(out ~ age1 + age2 + grp, data = filter(dat, vis == "visit 2")) result_expected <- list( - "trt_visit 2" = list( - "est" = mod$coefficients[[4]], - "se" = sqrt(vcov(mod)[4, 4]), - "df" = df.residual(mod) + analysis_result( + name = "trt", + est = mod$coefficients[[4]], + se = sqrt(vcov(mod)[4, 4]), + df = df.residual(mod), + meta = list(visit = "visit 2") ) ) - expect_equal(result_expected, result_actual["trt_visit 2"]) + result_actual <- extract_analysis_result(results_actual, name = "trt", meta = list(visit = "visit 2")) - expect_equal( - names(result_actual), - c( - "trt_visit 1", "lsm_ref_visit 1", "lsm_alt_visit 1", - "trt_visit 2", "lsm_ref_visit 2", "lsm_alt_visit 2" - ) - ) + expect_equal(result_expected, result_actual) + + expect_equal(sapply(results_actual, function(x) x[['name']]), + c("trt","lsm_ref", "lsm_alt","trt","lsm_ref","lsm_alt")) + + expect_equal(sapply(results_actual, function(x) x[['meta']]), + list(visit = "visit 1", visit = "visit 1", visit = "visit 1", visit = "visit 2", visit ="visit 2", visit ="visit 2")) + + expect_equal(sapply(results_actual, function(x) attr(x, 'meta')), + list(visit = "visit 1", visit = "visit 1", visit = "visit 1", visit = "visit 2", visit ="visit 2", visit ="visit 2")) ################## # From b074bf85f1f20d71c4dc2c07ec0a8c3e79eab579 Mon Sep 17 00:00:00 2001 From: Guanya Peng Date: Tue, 24 May 2022 15:50:43 +0200 Subject: [PATCH 56/84] make extract_analysis_result more robust --- R/analyse.R | 49 ++++++++++++++++++++++++++++++++++++++++--------- 1 file changed, 40 insertions(+), 9 deletions(-) diff --git a/R/analyse.R b/R/analyse.R index e8bce04f2..48b4d5561 100644 --- a/R/analyse.R +++ b/R/analyse.R @@ -737,23 +737,53 @@ analysis_info <- function(example, name_of_group = 'name', name_of_meta = 'meta' #' } extract_analysis_result <- function(results, ...){ dots <- list(...) - assert_that(all(!is.null(names(dots)), - length(names(dots)) > 0, - !any(grepl("^$", names(dots)))), - msg = "Invalide parameters. Only key-word parameters are valide.") + + assert_keyword <- function(obj, msg) { + assert_that(all(!is.null(names(obj)), + length(names(obj)) > 0, + !any(grepl("^$", names(dots)))), + msg = msg) + } + + assert_keyword(dots, "Invalide parameters. Only key-word parameters are valide. -- EXTRACT_ANALYSIS_RESULT") meta <- list() has_meta <- FALSE - if ('meta' %in% names(dots)) { + if (('meta' %in% names(dots)) & is.list(dots[['meta']])) { + assert_keyword(dots[['meta']], + "Invalide parameters. When `meta` specified as a list, it must be a named list -- EXTRACT_ANALYSIS_RESULT") meta <- dots[['meta']] dots[['meta']] <- NULL has_meta <- TRUE } + # decorator to make a high-order function returns TRUE/FALSE instead of logical(0) + logical0_to_TrueFalse <- function(f) { + function(...) { + g <- f(...) + function(...) isTRUE(g(...)) + } + } + + # check if object's element with given name matches to specified value + objname_match_value <- function(obj) { + function(name, value) { + if (is.null(value)) { + is.null(obj[[name]]) + } else if (is.na(value)){ + is.na(obj[[name]]) + } else { + obj[[name]] == value + } + } + } + + # decorated version of objname_match_value + is_objname_match_value <- logical0_to_TrueFalse(objname_match_value) + names_match_values <- function(obj, named_values=dots) { - mapply(function(label, value) isTRUE(obj[[label]] == value), - names(named_values), named_values, SIMPLIFY = TRUE, USE.NAMES = FALSE) - } # When SIMPLIFY = TRUE, coercion can happen on logical(0) which generates WARNINGS. isTRUE is used to avoid coercion and make the code more robust + mapply(is_objname_match_value(obj), names(named_values), named_values, SIMPLIFY = TRUE, USE.NAMES = FALSE) + } # When SIMPLIFY = TRUE, coercion can happen on logical(0) which generates WARNINGS. is_objname_match_value is decorated with isTRUE to be more robust extract_match <- function(obj, named_values=dots, constrain = identity) { Filter(function(item) all( @@ -772,9 +802,10 @@ extract_analysis_result <- function(results, ...){ extract_meta(matches_except_meta) } else { matches_except_meta - } + } }, warning = function(w) { + message(w) list() }) } From 2496b6af6e5fd6e5a5cbcbe6842592d48870a2b2 Mon Sep 17 00:00:00 2001 From: Guanya Peng Date: Tue, 24 May 2022 15:51:14 +0200 Subject: [PATCH 57/84] add test for extract_analysis_result --- tests/testthat/test-analysis_result.R | 182 ++++++++++++++++++++++++++ 1 file changed, 182 insertions(+) diff --git a/tests/testthat/test-analysis_result.R b/tests/testthat/test-analysis_result.R index c0eed6ccb..40183ad72 100644 --- a/tests/testthat/test-analysis_result.R +++ b/tests/testthat/test-analysis_result.R @@ -229,3 +229,185 @@ test_that("analysis_info works as expected", { expect_true(is.na(x[[4, 4]])) expect_true(is.na(x[[1, 5]])) }) + +test_that("extract_analysis_result works as expected", { + + x1 <- analysis_result(name ='a', est = 1, se = 2) + x2 <- analysis_result(name ='b', est = 2) + x3 <- analysis_result(name ='c', est = 3, se = NA, meta = list(visit = 5)) + x4 <- analysis_result(name ='d', est = 4, se = 3, meta = list(visit = 15)) + x5 <- analysis_result(name ='e', est = 5, se = 4, df = 1, meta = list(visit = 20, abc = 7)) + x6 <- analysis_result(name ='f', est = 6, se = 5, df = 2, meta = list(visit = 25, abc = 14)) + x7 <- analysis_result(name ='g', est = 7, se = 5, df = 3, meta = list(visit = 30, abc = 14)) + x8 <- analysis_result(name ='h', est = 8, se = 5, df = 3, meta = list(abc = 21, efg = 8)) + x9 <- analysis_result(name ='i', est = 8, se = 5, df = 3, meta = list(visit = 20, abc = 28, efg = 16)) + x10 <- analysis_result(name ='a', est = 8, meta = list(mfn = 1, klt = 's')) + x11 <- analysis_result(name ='b', est = 9, meta = list(mfn = 2, klt = 's1')) + x12 <- analysis_result(name ='m', est = 10, meta = list(mfn = 2, klt = 's2')) + + x <-list(x1, x2, x3, + x4, x5, x6, + x7, x8, x9, + x10, x11, x12) + + # single match + actual <- extract_analysis_result(x, name = 'a') + expect <- list(x1, x10) + expect_equal(actual, expect) + + actual <- extract_analysis_result(x, name = 'd') + expect <- list(x4) + expect_equal(actual, expect) + + actual <- extract_analysis_result(x, est = 2) + expect <- list(x2) + expect_equal(actual, expect) + + actual <- extract_analysis_result(x, est = 7) + expect <- list(x7) + expect_equal(actual, expect) + + actual <- extract_analysis_result(x, est = 8) + expect <- list(x8, x9, x10) + expect_equal(actual, expect) + + actual <- extract_analysis_result(x, se = 3) + expect <- list(x4) + expect_equal(actual, expect) + + actual <- extract_analysis_result(x, se = 5) + expect <- list(x6, x7, x8, x9) + expect_equal(actual, expect) + + actual <- extract_analysis_result(x, df = 1) + expect <- list(x5) + expect_equal(actual, expect) + + actual <- extract_analysis_result(x, df = 3) + expect <- list(x7, x8, x9) + expect_equal(actual, expect) + + actual <- extract_analysis_result(x, meta = list(visit = 5)) + expect <- list(x3) + expect_equal(actual, expect) + + actual <- extract_analysis_result(x, meta = list(visit = 15)) + expect <- list(x4) + expect_equal(actual, expect) + + actual <- extract_analysis_result(x, meta = list(visit = 20)) + expect <- list(x5, x9) + expect_equal(actual, expect) + + actual <- extract_analysis_result(x, meta = list(abc = 28)) + expect <- list(x9) + expect_equal(actual, expect) + + actual <- extract_analysis_result(x, meta = list(abc = 14)) + expect <- list(x6, x7) + expect_equal(actual, expect) + + actual <- extract_analysis_result(x, name = 'g', meta = list(abc = 14)) + expect <- list(x7) + expect_equal(actual, expect) + + actual <- extract_analysis_result(x, meta = list(efg = 16)) + expect <- list(x9) + expect_equal(actual, expect) + + actual <- extract_analysis_result(x, meta = list(mfn = 1)) + expect <- list(x10) + expect_equal(actual, expect) + + actual <- extract_analysis_result(x, meta = list(mfn = 2)) + expect <- list(x11, x12) + expect_equal(actual, expect) + + actual <- extract_analysis_result(x, meta = list(klt = 's1')) + expect <- list(x11) + expect_equal(actual, expect) + + # multiple match + actual <- extract_analysis_result(x, name = 'a', se = 2) + expect <- list(x1) + expect_equal(actual, expect) + + actual <- extract_analysis_result(x, name = 'a', meta = list(klt = 's')) + expect <- list(x10) + expect_equal(actual, expect) + + actual <- extract_analysis_result(x, name = 'a', est = 1, meta = list(klt = 's')) + expect <- list() + expect_equal(actual, expect) + + actual <- extract_analysis_result(x, se = 5, df = 3) + expect <- list(x7, x8, x9) + expect_equal(actual, expect) + + actual <- extract_analysis_result(x, se = 5, df = 3, meta = list(abc = 28)) + expect <- list(x9) + expect_equal(actual, expect) + + actual <- extract_analysis_result(x, name = 'b', meta = list(mfn = 2)) + expect <- list(x11) + expect_equal(actual, expect) + + actual <- extract_analysis_result(x, est = 9, se = 5, df = 2, meta = list(visit = 25)) + expect <- list() + expect_equal(actual, expect) + + actual <- extract_analysis_result(x, meta = list(visit = 30, abc = 14)) + expect <- list(x7) + expect_equal(actual, expect) + + actual <- extract_analysis_result(x, se = NA, meta = list(visit = 5)) + expect <- list(x3) + expect_equal(actual, expect) + + actual <- extract_analysis_result(x, se = NA, meta = list(visit = 5, abc = 'q')) + expect <- list() + expect_equal(actual, expect) + + actual <- extract_analysis_result(x, name ='a', est = 8, meta = list(klt = 's')) + expect <- list(x10) + expect_equal(actual, expect) + + actual <- extract_analysis_result(x, name ='a', est = 8, meta = list(klt = 's1')) + expect <- list() + expect_equal(actual, expect) + + # Special input + actual <- extract_analysis_result(x, se = NA) + expect <- list(x3) + expect_equal(actual, expect) + + actual <- extract_analysis_result(x, se = NULL) + expect <- list(x2, x10, x11, x12) + expect_equal(actual, expect) + + actual <- extract_analysis_result(x, se = NULL, df = NULL) + expect <- list(x2, x10, x11, x12) + expect_equal(actual, expect) + + actual <- extract_analysis_result(x, meta = NULL) + expect <- list(x1, x2) + expect_equal(actual, expect) + + actual <- extract_analysis_result(x, meta = NA) + expect <- list() + expect_equal(actual, expect) + + actual <- extract_analysis_result(x, meta = 'abc') + expect <- list() + expect_equal(actual, expect) + + expect_error(extract_analysis_result(x, meta = list('abc')), + "Invalide parameters") + + expect_error(extract_analysis_result(x, meta = list(NULL)), + "Invalide parameters") + + expect_error(extract_analysis_result(x, meta = list(NA)), + "Invalide parameters") + } +) From aea6e8320b2de86cabec4b27464c70769011fa6d Mon Sep 17 00:00:00 2001 From: Guanya Peng Date: Tue, 24 May 2022 16:00:14 +0200 Subject: [PATCH 58/84] code formating --- R/analyse.R | 18 ++++++++++++------ 1 file changed, 12 insertions(+), 6 deletions(-) diff --git a/R/analyse.R b/R/analyse.R index 48b4d5561..70650facc 100644 --- a/R/analyse.R +++ b/R/analyse.R @@ -742,7 +742,8 @@ extract_analysis_result <- function(results, ...){ assert_that(all(!is.null(names(obj)), length(names(obj)) > 0, !any(grepl("^$", names(dots)))), - msg = msg) + msg = msg + ) } assert_keyword(dots, "Invalide parameters. Only key-word parameters are valide. -- EXTRACT_ANALYSIS_RESULT") @@ -782,13 +783,18 @@ extract_analysis_result <- function(results, ...){ is_objname_match_value <- logical0_to_TrueFalse(objname_match_value) names_match_values <- function(obj, named_values=dots) { - mapply(is_objname_match_value(obj), names(named_values), named_values, SIMPLIFY = TRUE, USE.NAMES = FALSE) - } # When SIMPLIFY = TRUE, coercion can happen on logical(0) which generates WARNINGS. is_objname_match_value is decorated with isTRUE to be more robust + mapply( + is_objname_match_value(obj), + names(named_values), + named_values, + SIMPLIFY = TRUE, USE.NAMES = FALSE) + } # When SIMPLIFY = TRUE, coercion can happen on logical(0) which generates WARNINGS. `is_objname_match_value` is decorated with `isTRUE` to be more robust extract_match <- function(obj, named_values=dots, constrain = identity) { - Filter(function(item) all( - names_match_values(constrain(item), named_values)), - obj) + Filter( + function(item) all(names_match_values(constrain(item), named_values)), + obj + ) } search_in_meta <- function(obj) obj[['meta']] From 6a990b385cff6058502fc0a4044d8af54d5ed848 Mon Sep 17 00:00:00 2001 From: Guanya Peng Date: Wed, 25 May 2022 14:08:24 +0200 Subject: [PATCH 59/84] fix variable name --- R/analyse.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/analyse.R b/R/analyse.R index 70650facc..8b0e02c98 100644 --- a/R/analyse.R +++ b/R/analyse.R @@ -741,7 +741,7 @@ extract_analysis_result <- function(results, ...){ assert_keyword <- function(obj, msg) { assert_that(all(!is.null(names(obj)), length(names(obj)) > 0, - !any(grepl("^$", names(dots)))), + !any(grepl("^$", names(obj)))), msg = msg ) } From 778309159ba2899dfecaeb6913a58fe2bfa74351 Mon Sep 17 00:00:00 2001 From: Guanya Peng Date: Mon, 30 May 2022 21:23:32 +0200 Subject: [PATCH 60/84] fix duplicate names --- R/analyse.R | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/R/analyse.R b/R/analyse.R index 8b0e02c98..9fb666d6a 100644 --- a/R/analyse.R +++ b/R/analyse.R @@ -448,7 +448,15 @@ validate_analyse_pars <- function(results, pars) { msg = "Individual analysis result must be type of analysis_result" ) - results_names <- back_apply_at(results, function(x) x[['name']], 2) # get the "name" element of 2nd deepest level list which corresponds to analysis_result + compose <- function(f, g) function(...) f(g(...)) + + process_2nd_last_level <- function(process) function (nestlst) back_apply_at(nestlst, process, 2) + get_names <- process_2nd_last_level(function(x) x [['name']]) + dedup <- process_2nd_last_level(unique) + + get_unique_names <- compose(dedup, get_names) + + results_names <- get_unique_names(results) results_names_flat <- unlist(results_names, use.names = FALSE) results_names_count <- table(results_names_flat) From 8a8d9f3efa53b744394b88db2ae3d795fa829e6a Mon Sep 17 00:00:00 2001 From: Guanya Peng Date: Thu, 2 Jun 2022 15:04:12 +0200 Subject: [PATCH 61/84] update doc for extract_analysis_result --- man/extract_analysis_result.Rd | 39 ++++++++++++++++++++++++++++++++++ 1 file changed, 39 insertions(+) create mode 100644 man/extract_analysis_result.Rd diff --git a/man/extract_analysis_result.Rd b/man/extract_analysis_result.Rd new file mode 100644 index 000000000..85f8d0131 --- /dev/null +++ b/man/extract_analysis_result.Rd @@ -0,0 +1,39 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/analyse.R +\name{extract_analysis_result} +\alias{extract_analysis_result} +\title{Extract analysis_result from a list of analysis_results by matching names and values} +\usage{ +extract_analysis_result(results, ...) +} +\arguments{ +\item{results}{A list of analysis_result} + +\item{...}{Keywords parameters with the name and value matching the element in analysis result to be extracted} +} +\value{ +A list of matched analysis results +} +\description{ +The function returns a list of all analysis_results in the input list that match the values with names specified via keywords parameters of the function. +If no value matches the specified name in any analysis_result containing in the given list or +the specified name does not existed in any analysis_result, the function returns an empty list \code{list()}. +} +\examples{ +\dontrun{ +results <- list( + analysis_result( + name = 'trt', + est = 1, + se = 2, + df = 3, + meta = list(visit = 'vis1') + ) +) + +extract_analysis_result(results, name = 'trt') +extract_analysis_result(results, est = 1) +extract_analysis_result(results, name = 'trt', meta = list(visit = 'vis1')) +extract_analysis_result(results, name = 'trt2') +} +} From 9e209ae767a6cbce2e6bc6527eed9dbf50086bee Mon Sep 17 00:00:00 2001 From: Guanya Peng Date: Thu, 2 Jun 2022 15:04:41 +0200 Subject: [PATCH 62/84] update pool --- R/pool.R | 54 +++++++++++++++++++++------------------- man/transpose_results.Rd | 36 ++++++++++++++++++--------- 2 files changed, 53 insertions(+), 37 deletions(-) diff --git a/R/pool.R b/R/pool.R index 98eb74524..e4e8d7d58 100644 --- a/R/pool.R +++ b/R/pool.R @@ -618,23 +618,31 @@ parametric_ci <- function(point, se, alpha, alternative, qfun, pfun, ...) { #' ``` #' x <- list( #' list( -#' "trt1" = list( +#' analysis_result( +#' name = 'trt', #' est = 1, -#' se = 2 +#' se = 2, +#' meta = list(visit = 1) #' ), -#' "trt2" = list( +#' analysis_result( +#' name = 'trt', #' est = 3, -#' se = 4 +#' se = 4, +#' meta = list(visit = 2) #' ) #' ), #' list( -#' "trt1" = list( +#' analysis_result( +#' name = 'trt', #' est = 5, -#' se = 6 +#' se = 6, +#' meta = list(visit = 1) #' ), -#' "trt2" = list( -#' est = 7, -#' se = 8 +#' analysis_result( +#' name = 'trt', +#' est = 7, +#' se = 8, +#' meta = list(visit = 2) #' ) #' ) #' ) @@ -644,30 +652,26 @@ parametric_ci <- function(point, se, alpha, alternative, qfun, pfun, ...) { #' #' ``` #' list( -#' trt1 = list( +#' trt.1 = data.frame( +#' list( #' est = c(1,5), #' se = c(2,6) +#' ), #' ), -#' trt2 = list( +#' trt.2 = data.frame( +#' list( #' est = c(3,7), #' se = c(4,8) -#' ) +#' ) +#' ) #' ) #' ``` transpose_results <- function(results, components) { - elements <- names(results[[1]]) - results_transpose <- list() - for (element in elements) { - results_transpose[[element]] <- list() - for (comp in components) { - results_transpose[[element]][[comp]] <- vapply( - results, - function(x) x[[element]][[comp]], - numeric(1) - ) - } - } - return(results_transpose) + lsts2df <- function(lsts) base_bind_rows(lapply(lsts, analysis_info)) + results_df <- lsts2df(results) + keys <- setdiff(names(results_df), components) + vec2form <- function(vec) eval(parse(text = paste("~", paste(vec, collapse = ' + ')))) + split(results_df, vec2form(keys)) } diff --git a/man/transpose_results.Rd b/man/transpose_results.Rd index 128272945..88f4cdb70 100644 --- a/man/transpose_results.Rd +++ b/man/transpose_results.Rd @@ -19,37 +19,49 @@ the same estimates together into vectors. \details{ Essentially this function takes an object of the format:\preformatted{x <- list( list( - "trt1" = list( + analysis_result( + name = 'trt', est = 1, - se = 2 + se = 2, + meta = list(visit = 1) ), - "trt2" = list( + analysis_result( + name = 'trt', est = 3, - se = 4 + se = 4, + meta = list(visit = 2) ) ), list( - "trt1" = list( + analysis_result( + name = 'trt', est = 5, - se = 6 + se = 6, + meta = list(visit = 1) ), - "trt2" = list( - est = 7, - se = 8 + analysis_result( + name = 'trt', + est = 7, + se = 8, + meta = list(visit = 2) ) ) ) } and produces:\preformatted{list( - trt1 = list( + trt.1 = data.frame( + list( est = c(1,5), se = c(2,6) + ), ), - trt2 = list( + trt.2 = data.frame( + list( est = c(3,7), se = c(4,8) - ) + ) + ) ) } } From 9df6e990daa98bca63b146d02e434ab287848bb9 Mon Sep 17 00:00:00 2001 From: Guanya Peng Date: Thu, 2 Jun 2022 15:53:17 +0200 Subject: [PATCH 63/84] update transpose results --- R/pool.R | 15 ++++++--------- man/transpose_results.Rd | 6 +++--- 2 files changed, 9 insertions(+), 12 deletions(-) diff --git a/R/pool.R b/R/pool.R index e4e8d7d58..715e321a3 100644 --- a/R/pool.R +++ b/R/pool.R @@ -72,10 +72,7 @@ pool <- function( pool_type <- class(results$results)[[1]] - results_transpose <- transpose_results( - results$results, - get_pool_components(pool_type) - ) + results_transpose <- transpose_results(results$results) pars <- lapply( results_transpose, @@ -608,8 +605,8 @@ parametric_ci <- function(point, se, alpha, alternative, qfun, pfun, ...) { #' the same estimates together into vectors. #' #' @param results A list of results. -#' @param components a character vector of components to extract -#' (i.e. `"est", "se"`). +#' @param non_group_keys a character vector of variables that are not used to group results usually variables of the numeric analysis results +#' (Default: `"est", "se", "df`). #' #' @details #' @@ -666,12 +663,12 @@ parametric_ci <- function(point, se, alpha, alternative, qfun, pfun, ...) { #' ) #' ) #' ``` -transpose_results <- function(results, components) { +transpose_results <- function(results, non_group_keys=c("est", "se", "df")) { lsts2df <- function(lsts) base_bind_rows(lapply(lsts, analysis_info)) results_df <- lsts2df(results) - keys <- setdiff(names(results_df), components) + group_keys <- setdiff(names(results_df), non_group_keys) vec2form <- function(vec) eval(parse(text = paste("~", paste(vec, collapse = ' + ')))) - split(results_df, vec2form(keys)) + split(results_df, vec2form(group_keys)) } diff --git a/man/transpose_results.Rd b/man/transpose_results.Rd index 88f4cdb70..d29fe1bc2 100644 --- a/man/transpose_results.Rd +++ b/man/transpose_results.Rd @@ -4,13 +4,13 @@ \alias{transpose_results} \title{Transpose results object} \usage{ -transpose_results(results, components) +transpose_results(results, non_group_keys = c("est", "se", "df")) } \arguments{ \item{results}{A list of results.} -\item{components}{a character vector of components to extract -(i.e. \verb{"est", "se"}).} +\item{non_group_keys}{a character vector of variables that are not used to group results usually variables of the numeric analysis results +(Default: \verb{"est", "se", "df}).} } \description{ Transposes a Results object (as created by \code{\link[=analyse]{analyse()}}) in order to group From cc9e85947100c9597ecfa1847d1373f0b198a996 Mon Sep 17 00:00:00 2001 From: Guanya Peng Date: Thu, 2 Jun 2022 16:08:46 +0200 Subject: [PATCH 64/84] update test for new pool function --- tests/testthat/test-pool.R | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/tests/testthat/test-pool.R b/tests/testthat/test-pool.R index 5e866a389..4d5b5073d 100644 --- a/tests/testthat/test-pool.R +++ b/tests/testthat/test-pool.R @@ -179,7 +179,7 @@ test_that("pool", { vals <- rnorm(n, mu, sd) runanalysis <- function(x) { - list("p1" = list(est = mean(x), se = sqrt(var(x) / length(x)), df = NA)) + list(analysis_result(name = "p1", est = mean(x), se = sqrt(var(x) / length(x)), df = NA)) } @@ -247,7 +247,7 @@ test_that("pool", { test_that("Pool (Rubin) works as expected when se = NA in analysis model", { set.seed(101) - + mu <- 0 sd <- 1 n <- 2000 @@ -255,7 +255,7 @@ test_that("Pool (Rubin) works as expected when se = NA in analysis model", { real_mu <- mean(vals) runanalysis <- function(x) { - list("p1" = list(est = mean(x), se = NA, df = NA)) + list(analysis_result(name = "p1", est = mean(x), se = NA, df = NA)) } results_bayes <- as_analysis( @@ -298,7 +298,7 @@ test_that("Pool (Rubin) works as expected when se = NA in analysis model", { ) runanalysis <- function(x) { - list("p1" = list(est = mean(x), se = NA, df = Inf)) + list(analysis_result(name = "p1", est = mean(x), se = NA, df = Inf)) } results_bayes <- as_analysis( @@ -340,7 +340,7 @@ test_that("Pool (Rubin) works as expected when se = NA in analysis model", { tolerance = 1e-2 ) }) - + test_that("pool BMLMI estimates", { set.seed(100) @@ -366,7 +366,7 @@ test_that("Pool (Rubin) works as expected when se = NA in analysis model", { ), recursive = FALSE) runanalysis <- function(x) { - list("p1" = list(est = mean(x), se = sqrt(var(x) / length(x)), df = NA)) + list(analysis_result(name = "p1", est = mean(x), se = sqrt(var(x) / length(x)), df = NA)) } @@ -830,7 +830,7 @@ test_that("condmean doesn't use first element in CI", { n <- 200 runanalysis <- function(x) { - list("p1" = list(est = mean(x))) + list(analysis_result(name = "p1", est = mean(x))) } set.seed(2040) @@ -845,12 +845,12 @@ test_that("condmean doesn't use first element in CI", { pooled_1 <- pool(x) - expect_equal(pooled_1$pars$p1$est, x$results[[1]]$p1$est) + expect_equal(pooled_1$pars$p1$est, extract_analysis_result(x$results[[1]], name = 'p1')[[1]]$est) - x$results[[1]]$p1$est <- 9999 + x$results[[1]][[1]]$est <- 9999 pooled_2 <- pool(x) - expect_equal(pooled_2$pars$p1$est, x$results[[1]]$p1$est) + expect_equal(pooled_2$pars$p1$est, extract_analysis_result(x$results[[1]], name = 'p1')[[1]]$est) pooled_1$pars$p1$est <- NULL pooled_2$pars$p1$est <- NULL From 3a5c84d12383c76b2ef58a9afd6c472600f27f1a Mon Sep 17 00:00:00 2001 From: Guanya Peng Date: Thu, 2 Jun 2022 16:40:17 +0200 Subject: [PATCH 65/84] update comment --- R/utilities.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/utilities.R b/R/utilities.R index 840cc501a..e3556fba8 100644 --- a/R/utilities.R +++ b/R/utilities.R @@ -659,7 +659,7 @@ namechecker <- function(..., optional = NULL) { # checker does not check against optional names. Only names in musthave have to be presented in the object musthave_in_objnames <- chker_template(musthave, .optional = NULL) - # Validator to check if object's name belongs to musthave + optional names (simply swap the order of arguments from present) + # Validator to check if object's name belongs to musthave + optional names (simply swap the order of arguments in musthave_in_objnames: B_in_A = swap(A_in_B)) objnames_in_musthave <- chker_template(musthave, swap) dispatch <- list( From 2a5318cf712278982d70fb692c41dfaa79bdbc10 Mon Sep 17 00:00:00 2001 From: Guanya Peng Date: Mon, 13 Jun 2022 17:30:38 +0200 Subject: [PATCH 66/84] update pool --- R/pool.R | 73 +++++++++++++++++++++++++------------- tests/testthat/test-pool.R | 18 ++++++---- 2 files changed, 60 insertions(+), 31 deletions(-) diff --git a/R/pool.R b/R/pool.R index 715e321a3..f6bb70982 100644 --- a/R/pool.R +++ b/R/pool.R @@ -72,10 +72,10 @@ pool <- function( pool_type <- class(results$results)[[1]] - results_transpose <- transpose_results(results$results) + prepool <- make_poolable(results$results) - pars <- lapply( - results_transpose, + par_values <- lapply( + prepool$results, function(x, ...) pool_internal(as_class(x, pool_type), ...), conf.level = conf.level, alternative = alternative, @@ -83,6 +83,8 @@ pool <- function( D = results$method$D ) + pars <- mapply(function(x, y) append(x, y), prepool$meta, par_values, SIMPLIFY = FALSE) + if (pool_type == "bootstrap") { method <- sprintf("%s (%s)", pool_type, type) } else { @@ -94,7 +96,8 @@ pool <- function( conf.level = conf.level, alternative = alternative, N = length(results$results), - method = method + method = method, + metakeys = prepool$metakeys ) class(ret) <- "pool" return(ret) @@ -599,10 +602,10 @@ parametric_ci <- function(point, se, alpha, alternative, qfun, pfun, ...) { -#' Transpose results object +#' Convert analysis results to a poolable object #' -#' Transposes a Results object (as created by [analyse()]) in order to group -#' the same estimates together into vectors. +#' Covert Results object (as created by [analyse()]) in order to group +#' the same estimates together into vectors. The return object is in poolable class containing the results, meta information and the key names for the mata information #' #' @param results A list of results. #' @param non_group_keys a character vector of variables that are not used to group results usually variables of the numeric analysis results @@ -610,7 +613,7 @@ parametric_ci <- function(point, se, alpha, alternative, qfun, pfun, ...) { #' #' @details #' -#' Essentially this function takes an object of the format: +#' The format of analysis results are converted from: #' #' ``` #' x <- list( @@ -645,46 +648,66 @@ parametric_ci <- function(point, se, alpha, alternative, qfun, pfun, ...) { #' ) #' ``` #' -#' and produces: +#' to the following format and stored in the `$$results` element of the poolable object. The element `$meta` contains meta information. +#' The element `$metakey` contains the column names of the meta information as a character vector #' #' ``` #' list( #' trt.1 = data.frame( #' list( +#' name = 'trt', #' est = c(1,5), -#' se = c(2,6) +#' se = c(2,6), +#' visit = c(1,1) #' ), #' ), #' trt.2 = data.frame( #' list( +#' name = 'trt', #' est = c(3,7), -#' se = c(4,8) +#' se = c(4,8), +#' visit = c(2,2) #' ) #' ) #' ) #' ``` -transpose_results <- function(results, non_group_keys=c("est", "se", "df")) { +make_poolable <- function(results, non_group_keys=c("est", "se", "df")) { + assert_map <- function(f, assert_f, logic = all) { + function(lst, ...) { + out <- lapply(lst, f, ...) + conds <- lapply(out, assert_f) + assert_that(logic(unlist(conds))) + out + } + } + + extract_aggregate <- function(lst, keys) unique(lst[keys]) + extract_aggragates <- assert_map(extract_aggregate, function(x) nrow(x) == 1) + lsts2df <- function(lsts) base_bind_rows(lapply(lsts, analysis_info)) results_df <- lsts2df(results) group_keys <- setdiff(names(results_df), non_group_keys) - vec2form <- function(vec) eval(parse(text = paste("~", paste(vec, collapse = ' + ')))) - split(results_df, vec2form(group_keys)) + + results <- split(results_df, vec2form(group_keys)) + meta <- extract_aggragates(results, group_keys) + + structure(list(results = results, + meta = meta, + metakeys = group_keys), + class = 'poolable') } #' @rdname pool #' @export as.data.frame.pool <- function(x, ...) { - data.frame( - parameter = names(x$pars), - est = vapply(x$pars, function(x) x$est, numeric(1)), - se = vapply(x$pars, function(x) x$se, numeric(1)), - lci = vapply(x$pars, function(x) x$ci[[1]], numeric(1)), - uci = vapply(x$pars, function(x) x$ci[[2]], numeric(1)), - pval = vapply(x$pars, function(x) x$pvalue, numeric(1)), - stringsAsFactors = FALSE, - row.names = NULL - ) + pars_df <- reduce_df(base_bind_rows(x$pars), keys = x$metakeys, split = TRUE) + assert_that(any(grepl('ci', tolower(names(pars_df))))) + + names(pars_df)[tolower(names(pars_df)) == "ci.1"] <- "lci" + names(pars_df)[tolower(names(pars_df)) == "ci.2"] <- "uci" + row.names(pars_df) <- NULL + pars_df } @@ -708,7 +731,7 @@ print.pool <- function(x, ...) { sprintf("Alternative: %s", x$alternative), "", "Results:", - as_ascii_table(as.data.frame(x), pcol = "pval"), + as_ascii_table(as.data.frame(x), pcol = "pvalue"), "" ) diff --git a/tests/testthat/test-pool.R b/tests/testthat/test-pool.R index 4d5b5073d..e943c5113 100644 --- a/tests/testthat/test-pool.R +++ b/tests/testthat/test-pool.R @@ -272,7 +272,8 @@ test_that("Pool (Rubin) works as expected when se = NA in analysis model", { expect_equal( bayes$pars$p1, - list(est = real_mu, + list(name = 'p1', + est = real_mu, ci = as.numeric(c(NA, NA)), se = as.numeric(NA), pvalue = as.numeric(NA)), @@ -281,7 +282,8 @@ test_that("Pool (Rubin) works as expected when se = NA in analysis model", { expect_equal( bayes2$pars$p1, - list(est = real_mu, + list(name = 'p1', + est = real_mu, ci = as.numeric(c(NA, NA)), se = as.numeric(NA), pvalue = as.numeric(NA)), @@ -290,7 +292,8 @@ test_that("Pool (Rubin) works as expected when se = NA in analysis model", { expect_equal( bayes3$pars$p1, - list(est = real_mu, + list(name = 'p1', + est = real_mu, ci = as.numeric(c(NA, NA)), se = as.numeric(NA), pvalue = as.numeric(NA)), @@ -315,7 +318,8 @@ test_that("Pool (Rubin) works as expected when se = NA in analysis model", { expect_equal( bayes$pars$p1, - list(est = real_mu, + list(name = 'p1', + est = real_mu, ci = as.numeric(c(NA, NA)), se = as.numeric(NA), pvalue = as.numeric(NA)), @@ -324,7 +328,8 @@ test_that("Pool (Rubin) works as expected when se = NA in analysis model", { expect_equal( bayes2$pars$p1, - list(est = real_mu, + list(name = 'p1', + est = real_mu, ci = as.numeric(c(NA, NA)), se = as.numeric(NA), pvalue = as.numeric(NA)), @@ -333,7 +338,8 @@ test_that("Pool (Rubin) works as expected when se = NA in analysis model", { expect_equal( bayes3$pars$p1, - list(est = real_mu, + list(name = 'p1', + est = real_mu, ci = as.numeric(c(NA, NA)), se = as.numeric(NA), pvalue = as.numeric(NA)), From c35f4b66fa19eb5415e60f7f8ef98cb3706d146f Mon Sep 17 00:00:00 2001 From: Guanya Peng Date: Mon, 13 Jun 2022 17:38:50 +0200 Subject: [PATCH 67/84] fix typo in header and comment --- R/pool.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/pool.R b/R/pool.R index f6bb70982..d1b039c00 100644 --- a/R/pool.R +++ b/R/pool.R @@ -648,8 +648,8 @@ parametric_ci <- function(point, se, alpha, alternative, qfun, pfun, ...) { #' ) #' ``` #' -#' to the following format and stored in the `$$results` element of the poolable object. The element `$meta` contains meta information. -#' The element `$metakey` contains the column names of the meta information as a character vector +#' to the following format and stored in the `$results` element of the poolable object. The element `$meta` contains meta information. +#' The element `$metakeys` contains the names of the meta information as a character vector #' #' ``` #' list( From a32ec182d59767fa03dab4136d4e9ba9ac8f6046 Mon Sep 17 00:00:00 2001 From: Guanya Peng Date: Mon, 13 Jun 2022 17:40:51 +0200 Subject: [PATCH 68/84] add utility functions --- R/utilities.R | 33 +++++++++++++++++++++++++++++++++ 1 file changed, 33 insertions(+) diff --git a/R/utilities.R b/R/utilities.R index e3556fba8..33a610ab2 100644 --- a/R/utilities.R +++ b/R/utilities.R @@ -725,3 +725,36 @@ back_apply_at <- function(lst, f, n) { } ) } + +#' Convert vector to formula +#' +#' Convert character vector c('a1', 'a2') to formula ~ a1 + a2 +#' +#' @param chr character vector to be converted +#' @param bothside A logical variable indicating whether to generate fomula with both right and left side. Default: FALSE - only right side formula will be generated +#' @return an object of formula class representing formula ~ chr[[1]] + chr[[2]] + ... +vec2form <- function(chr, bothside = FALSE) { + prefix = '~' + if (bothside) prefix = paste('.', prefix) + eval(parse(text = paste(prefix, paste(chr, collapse = ' + ')))) +} + + +#' Reduce a dataframe +#' +#' Reduce a data.frame row-wisely by concatenating values within group to list or multiple columns +#' +#' @param df A data frame to be reduced +#' @param keys A character vectors of the group keys when reducing +#' @param split A logical variable indicating whether to concatenate row-wise information to a list in single column or create multiple columns for each individual rows within group +#' @return A data frame with reduced information +reduce_df <- function(df, keys, split = FALSE) { + make_concat <- function(f) function(x) f(unique(x)) + concat <- ife(split, make_concat(c), make_concat(list)) + pos_process <- ife(split, function(x) do.call(data.frame, x), identity) + pos_process( + aggregate(vec2form(keys, bothside = TRUE), data = df, FUN = concat) + ) +} + + From 18cd5fe2af9d043b650bfa1cd73c9e47d1ccbc5d Mon Sep 17 00:00:00 2001 From: Guanya Peng Date: Mon, 13 Jun 2022 17:41:18 +0200 Subject: [PATCH 69/84] update doc --- man/make_poolable.Rd | 72 ++++++++++++++++++++++++++++++++++++++++++++ man/reduce_df.Rd | 21 +++++++++++++ man/vec2form.Rd | 19 ++++++++++++ 3 files changed, 112 insertions(+) create mode 100644 man/make_poolable.Rd create mode 100644 man/reduce_df.Rd create mode 100644 man/vec2form.Rd diff --git a/man/make_poolable.Rd b/man/make_poolable.Rd new file mode 100644 index 000000000..ee1225104 --- /dev/null +++ b/man/make_poolable.Rd @@ -0,0 +1,72 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/pool.R +\name{make_poolable} +\alias{make_poolable} +\title{Convert analysis results to a poolable object} +\usage{ +make_poolable(results, non_group_keys = c("est", "se", "df")) +} +\arguments{ +\item{results}{A list of results.} + +\item{non_group_keys}{a character vector of variables that are not used to group results usually variables of the numeric analysis results +(Default: \verb{"est", "se", "df}).} +} +\description{ +Covert Results object (as created by \code{\link[=analyse]{analyse()}}) in order to group +the same estimates together into vectors. The return object is in poolable class containing the results, meta information and the key names for the mata information +} +\details{ +The format of analysis results are converted from:\preformatted{x <- list( + list( + analysis_result( + name = 'trt', + est = 1, + se = 2, + meta = list(visit = 1) + ), + analysis_result( + name = 'trt', + est = 3, + se = 4, + meta = list(visit = 2) + ) + ), + list( + analysis_result( + name = 'trt', + est = 5, + se = 6, + meta = list(visit = 1) + ), + analysis_result( + name = 'trt', + est = 7, + se = 8, + meta = list(visit = 2) + ) + ) +) +} + +to the following format and stored in the \verb{$results} element of the poolable object. The element \verb{$meta} contains meta information. +The element \verb{$metakeys} contains the names of the meta information as a character vector\preformatted{list( + trt.1 = data.frame( + list( + name = 'trt', + est = c(1,5), + se = c(2,6), + visit = c(1,1) + ), + ), + trt.2 = data.frame( + list( + name = 'trt', + est = c(3,7), + se = c(4,8), + visit = c(2,2) + ) + ) +) +} +} diff --git a/man/reduce_df.Rd b/man/reduce_df.Rd new file mode 100644 index 000000000..6e141f415 --- /dev/null +++ b/man/reduce_df.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utilities.R +\name{reduce_df} +\alias{reduce_df} +\title{Reduce a dataframe} +\usage{ +reduce_df(df, keys, split = FALSE) +} +\arguments{ +\item{df}{A data frame to be reduced} + +\item{keys}{A character vectors of the group keys when reducing} + +\item{split}{A logical variable indicating whether to concatenate row-wise information to a list in single column or create multiple columns for each individual rows within group} +} +\value{ +A data frame with reduced information +} +\description{ +Reduce a data.frame row-wisely by concatenating values within group to list or multiple columns +} diff --git a/man/vec2form.Rd b/man/vec2form.Rd new file mode 100644 index 000000000..36d6f46ef --- /dev/null +++ b/man/vec2form.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utilities.R +\name{vec2form} +\alias{vec2form} +\title{Convert vector to formula} +\usage{ +vec2form(chr, bothside = FALSE) +} +\arguments{ +\item{chr}{character vector to be converted} + +\item{bothside}{A logical variable indicating whether to generate fomula with both right and left side. Default: FALSE - only right side formula will be generated} +} +\value{ +an object of formula class representing formula ~ chr[\link{1}] + chr[\link{2}] + ... +} +\description{ +Convert character vector c('a1', 'a2') to formula ~ a1 + a2 +} From f398167c270aa16d9eea798463e4bff7ab2e82b8 Mon Sep 17 00:00:00 2001 From: Guanya Peng Date: Mon, 13 Jun 2022 17:42:27 +0200 Subject: [PATCH 70/84] remove deprecated doc --- man/transpose_results.Rd | 67 ---------------------------------------- 1 file changed, 67 deletions(-) delete mode 100644 man/transpose_results.Rd diff --git a/man/transpose_results.Rd b/man/transpose_results.Rd deleted file mode 100644 index d29fe1bc2..000000000 --- a/man/transpose_results.Rd +++ /dev/null @@ -1,67 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/pool.R -\name{transpose_results} -\alias{transpose_results} -\title{Transpose results object} -\usage{ -transpose_results(results, non_group_keys = c("est", "se", "df")) -} -\arguments{ -\item{results}{A list of results.} - -\item{non_group_keys}{a character vector of variables that are not used to group results usually variables of the numeric analysis results -(Default: \verb{"est", "se", "df}).} -} -\description{ -Transposes a Results object (as created by \code{\link[=analyse]{analyse()}}) in order to group -the same estimates together into vectors. -} -\details{ -Essentially this function takes an object of the format:\preformatted{x <- list( - list( - analysis_result( - name = 'trt', - est = 1, - se = 2, - meta = list(visit = 1) - ), - analysis_result( - name = 'trt', - est = 3, - se = 4, - meta = list(visit = 2) - ) - ), - list( - analysis_result( - name = 'trt', - est = 5, - se = 6, - meta = list(visit = 1) - ), - analysis_result( - name = 'trt', - est = 7, - se = 8, - meta = list(visit = 2) - ) - ) -) -} - -and produces:\preformatted{list( - trt.1 = data.frame( - list( - est = c(1,5), - se = c(2,6) - ), - ), - trt.2 = data.frame( - list( - est = c(3,7), - se = c(4,8) - ) - ) -) -} -} From a2f7af2babb57ee69bddc7500413be6eddb41a6f Mon Sep 17 00:00:00 2001 From: Guanya Peng Date: Mon, 13 Jun 2022 17:46:37 +0200 Subject: [PATCH 71/84] update doc --- man/vec2form.Rd | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/man/vec2form.Rd b/man/vec2form.Rd index 36d6f46ef..ce7f92fd0 100644 --- a/man/vec2form.Rd +++ b/man/vec2form.Rd @@ -9,11 +9,11 @@ vec2form(chr, bothside = FALSE) \arguments{ \item{chr}{character vector to be converted} -\item{bothside}{A logical variable indicating whether to generate fomula with both right and left side. Default: FALSE - only right side formula will be generated} +\item{bothside}{A logical variable indicating whether to generate fomula with both right and left side. Default: \code{FALSE} - only right side formula will be generated} } \value{ -an object of formula class representing formula ~ chr[\link{1}] + chr[\link{2}] + ... +an object of formula class representing formula \code{~ chr[[1]] + chr[[2]] + ...} } \description{ -Convert character vector c('a1', 'a2') to formula ~ a1 + a2 +Convert character vector \code{c('a1', 'a2')} to formula \code{~ a1 + a2} } From 35b6d0f43bf30e71bebe9597373ba1f336b7cbc1 Mon Sep 17 00:00:00 2001 From: Guanya Peng Date: Mon, 13 Jun 2022 18:30:41 +0200 Subject: [PATCH 72/84] update test for utilities --- R/utilities.R | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/R/utilities.R b/R/utilities.R index 33a610ab2..87ae8c0ef 100644 --- a/R/utilities.R +++ b/R/utilities.R @@ -728,11 +728,11 @@ back_apply_at <- function(lst, f, n) { #' Convert vector to formula #' -#' Convert character vector c('a1', 'a2') to formula ~ a1 + a2 +#' Convert character vector `c('a1', 'a2')` to formula `~ a1 + a2` #' #' @param chr character vector to be converted -#' @param bothside A logical variable indicating whether to generate fomula with both right and left side. Default: FALSE - only right side formula will be generated -#' @return an object of formula class representing formula ~ chr[[1]] + chr[[2]] + ... +#' @param bothside A logical variable indicating whether to generate fomula with both right and left side. Default: `FALSE` - only right side formula will be generated +#' @return an object of formula class representing formula `~ chr[[1]] + chr[[2]] + ...` vec2form <- function(chr, bothside = FALSE) { prefix = '~' if (bothside) prefix = paste('.', prefix) From c8a1438a1c7ed85fdea94f4f0ebb353db911ed08 Mon Sep 17 00:00:00 2001 From: Guanya Peng Date: Mon, 13 Jun 2022 18:31:21 +0200 Subject: [PATCH 73/84] update test --- tests/testthat/test-utilities.R | 35 +++++++++++++++++++++++++++++++++ 1 file changed, 35 insertions(+) diff --git a/tests/testthat/test-utilities.R b/tests/testthat/test-utilities.R index a9c273f26..75c953c07 100644 --- a/tests/testthat/test-utilities.R +++ b/tests/testthat/test-utilities.R @@ -396,3 +396,38 @@ test_that("back_apply_at", { expect_error(zz$a2$b21) expect_error(zz$a1$b12$c121) }) + + +test_that("vec2form", { + x <- vec2form(c('a1', 'a2')) + expect_equal(class(x), 'formula') + expect_true(is.call(x[2])) + expect_equal(deparse(x), "~a1 + a2") + } +) + +test_that("reduce_df", { + x <- data.frame(a=1, b=c(1,2,3), c=5) + + # concatenate rows to vector + y <- reduce_df(x, keys = 'a') + expect_equal(y$a, 1) + expect_equal(y$b[[1]], c(1,2,3)) + expect_equal(y$c[[1]], 5) + + y <- reduce_df(x, keys = 'b') + expect_equal(y$a, list(1,1,1)) + expect_equal(y$b, c(1,2,3)) + expect_equal(y$c, list(5,5,5)) + + # split rows to columns + y <- reduce_df(x, keys = 'a', split = TRUE) + expect_equal(ncol(y), 5) + expect_length(grep('b', names(y)), 3) + expect_equal(names(y), c('a', 'b.1', 'b.2', 'b.3', 'c')) + expect_equal(y$a, 1) + expect_equal(y$b.1, 1) + expect_equal(y$b.2, 2) + expect_equal(y$b.3, 3) + expect_equal(y$c, 5) +}) From fea589518fb556925c11baa9b92668b61e5ae5c1 Mon Sep 17 00:00:00 2001 From: Guanya Peng Date: Tue, 14 Jun 2022 13:33:10 +0200 Subject: [PATCH 74/84] update test --- tests/testthat/test-fullusage.R | 37 ++++++++++++++++++--------------- 1 file changed, 20 insertions(+), 17 deletions(-) diff --git a/tests/testthat/test-fullusage.R b/tests/testthat/test-fullusage.R index e12f8f92e..68c70e3dd 100644 --- a/tests/testthat/test-fullusage.R +++ b/tests/testthat/test-fullusage.R @@ -16,7 +16,7 @@ sigma <- as_vcov(c(2, 1, 0.7), c(0.5, 0.3, 0.2)) nsamp <- 200 -expect_pool_est <- function(po, expected, param = "trt_visit_3") { +expect_pool_est <- function(po, expected, param = "trt.visit_3") { expect_contains( po$pars[[param]]$ci, expected @@ -27,8 +27,8 @@ expect_pool_est <- function(po, expected, param = "trt_visit_3") { po$pars[[param]]$est ) - if ("lsm_alt_visit_3" %in% names(po$pars)) { - lsm_trt <- (po$pars$lsm_alt_visit_3$est - po$pars$lsm_ref_visit_3$est) + if ("lsm_alt.visit_3" %in% names(po$pars)) { + lsm_trt <- (po$pars$lsm_alt.visit_3$est - po$pars$lsm_ref.visit_3$est) expect_within( lsm_trt - po$pars[[param]]$est, @@ -205,7 +205,7 @@ test_that("Basic Usage - Bayesian", { -test_that("Basic Usage - Condmean", { +test_that("Basic Usage - Condmean", { skip_if_not(is_full_test()) @@ -348,10 +348,11 @@ test_that("Custom Strategies and Custom analysis functions", { dat <- dat %>% filter(visit == "visit_3") mod <- lm(data = dat, outcome ~ group + age + sex) list( - "treatment_effect" = list( - "est" = coef(mod)[[2]], - "se" = sqrt(vcov(mod)[2,2]), - "df" = df.residual(mod) + analysis_result( + name = "treatment_effect", + est = coef(mod)[[2]], + se = sqrt(vcov(mod)[2,2]), + df = df.residual(mod) ) ) } @@ -527,7 +528,7 @@ test_that("Multiple imputation references / groups work as expected (end to end vars2$group <- "group" x_ana <- analyse(x_imp, ancova, vars = vars2) x_pl <- pool(x_ana, conf.level = 0.98) - x_pl$pars$trt_visit_3$ci + x_pl$pars$trt.visit_3$ci } set.seed(2351) @@ -685,7 +686,8 @@ test_that("rbmi works for one arm trials", { data_anal <- data[data[[vars$visit]] == "visit_3",][[vars$outcome]] res <- list( - mean = list( + analysis_result( + name = 'mean', est = mean(data_anal), se = sd(data_anal) / sqrt(length(data_anal)), df = length(data_anal) - 1 @@ -738,7 +740,7 @@ test_that("rbmi works for one arm trials", { mutate(strategy = "MAR") runtest <- function(dat, dat_ice, vars, vars_wrong, vars_wrong2, vars_wrong3, method) { - + draw_obj <- draws( data = dat, data_ice = dat_ice, @@ -806,10 +808,10 @@ test_that("rbmi works for one arm trials", { pooled <- pool(anl_obj) } - expect_length(pooled$pars$mean, 4) + expect_length(pooled$pars$mean, 5) expect_true(all(!is.null(unlist(pooled$pars$mean)))) expect_true(all(!is.na(unlist(pooled$pars$mean)))) - expect_true(all(is.double(unlist(pooled$pars$mean)))) + expect_true(all(is.double(unlist(pooled$pars$mean[names(pooled$pars$mean) != 'name'])))) } method <- method_condmean(type = "jackknife") @@ -848,10 +850,11 @@ test_that("Three arms trial runs smoothly and gives expected results", { data_temp$group <- factor(data_temp$group, levels = c("A", "C")) resC <- ancova(data_temp, ...) - ret_obj <- list( - trtB = resB$trt_visit_3, - trtC = resC$trt_visit_3 - ) + trtB <- extract_analysis_result(resB, name = 'trt', meta = list(visit = 'visit_3'))[[1]] + + trtC <- extract_analysis_result(resC, name = 'trt', meta = list(visit = 'visit_3'))[[1]] + + ret_obj <- list(trtB, trtC) return(ret_obj) From b1a295c8879ff6bd9823425c591faefbb3713c0a Mon Sep 17 00:00:00 2001 From: Guanya Peng Date: Tue, 14 Jun 2022 13:34:18 +0200 Subject: [PATCH 75/84] update analyse --- R/analyse.R | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/R/analyse.R b/R/analyse.R index 9fb666d6a..0de4ac18d 100644 --- a/R/analyse.R +++ b/R/analyse.R @@ -725,6 +725,7 @@ analysis_info <- function(example, name_of_group = 'name', name_of_meta = 'meta' #' @param results A list of analysis_result #' @param ... Keywords parameters with the name and value matching the element in analysis result to be extracted #' @return A list of matched analysis results +#' @export #' @examples #' \dontrun{ #' results <- list( @@ -754,20 +755,20 @@ extract_analysis_result <- function(results, ...){ ) } - assert_keyword(dots, "Invalide parameters. Only key-word parameters are valide. -- EXTRACT_ANALYSIS_RESULT") + assert_keyword(dots, "Invalid parameters. Only key-word parameters are valide. -- EXTRACT_ANALYSIS_RESULT") meta <- list() has_meta <- FALSE if (('meta' %in% names(dots)) & is.list(dots[['meta']])) { assert_keyword(dots[['meta']], - "Invalide parameters. When `meta` specified as a list, it must be a named list -- EXTRACT_ANALYSIS_RESULT") + "Invalid parameters. When `meta` specified as a list, it must be a named list -- EXTRACT_ANALYSIS_RESULT") meta <- dots[['meta']] dots[['meta']] <- NULL has_meta <- TRUE } - # decorator to make a high-order function returns TRUE/FALSE instead of logical(0) - logical0_to_TrueFalse <- function(f) { + # decorator to make a high-order function returns TRUE/FALSE instead of logical(0) or other types of logical value + TRUE_or_FALSE <- function(f) { function(...) { g <- f(...) function(...) isTRUE(g(...)) @@ -788,7 +789,7 @@ extract_analysis_result <- function(results, ...){ } # decorated version of objname_match_value - is_objname_match_value <- logical0_to_TrueFalse(objname_match_value) + is_objname_match_value <- TRUE_or_FALSE(objname_match_value) names_match_values <- function(obj, named_values=dots) { mapply( From 0a9798a6dce68fd1f66aa7fa6aa860be6c548b49 Mon Sep 17 00:00:00 2001 From: Guanya Peng Date: Tue, 14 Jun 2022 13:34:45 +0200 Subject: [PATCH 76/84] update namespace --- NAMESPACE | 1 + 1 file changed, 1 insertion(+) diff --git a/NAMESPACE b/NAMESPACE index 587092b8c..ad2e24554 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -45,6 +45,7 @@ export(delta_template) export(draws) export(expand) export(expand_locf) +export(extract_analysis_result) export(extract_imputed_dfs) export(fill_locf) export(getStrategies) From 95a8dbf8290688c6dba365b5f361a4bede3de448 Mon Sep 17 00:00:00 2001 From: Guanya Peng Date: Thu, 16 Jun 2022 19:51:53 +0200 Subject: [PATCH 77/84] update analysis functions --- R/analyse.R | 73 ++++++++++++++++++++++++++++++++++++++++++----------- 1 file changed, 58 insertions(+), 15 deletions(-) diff --git a/R/analyse.R b/R/analyse.R index 0de4ac18d..24b865674 100644 --- a/R/analyse.R +++ b/R/analyse.R @@ -661,18 +661,18 @@ is.analysis_result <- function(x) { ) } -#' Get printable analysis information from an example of analysis result +#' Convert a list of analysis_result objects to data.frame #' -#' @param example A subset of the result of the analysis object for getting enough info to print. It should not be the complete result of analysis object but a subset of it such as `anaObj$results[[1]]` -#' @param name_of_group A character variable for the name of group variable in the result of analysis which is defined from `analysis_result`. Default: `'name'` -#' @param name_of_meta A character variable for the name of meta data in the result of analysis which is defined from `analysis_result`. Default: 'meta' -#' @return A data.frame containing the information of the analysis result from the example +#' @param analst A list of `analysis_result` objects. It should not be the complete result of analysis object but a subset of it such as `anaObj$results[[1]]` +#' @param name_of_group A `character` variable for the name of group variable in the result of analysis which is defined from `analysis_result`. Default: `'name'` +#' @param name_of_meta A `character` variable for the name of meta data in the result of analysis which is defined from `analysis_result`. Default: `'meta'` +#' @return A `data.frame` containing the information of the analysis result from the `analst` #' @examples #' \dontrun{ #' analysis_info(dat, name_of_group = 'name', name_of_meta = 'meta') #' } #' @importFrom assertthat has_attr -analysis_info <- function(example, name_of_group = 'name', name_of_meta = 'meta') { +analysis_info <- function(analst, name_of_group = 'name', name_of_meta = 'meta') { pars_no_meta <- list() pars_with_meta <- list() @@ -685,11 +685,11 @@ analysis_info <- function(example, name_of_group = 'name', name_of_meta = 'meta' ) } - for (i in seq_along(example)) { - item <- example[[i]] + for (i in seq_along(analst)) { + item <- analst[[i]] assert_that(is.analysis_result(item), - msg = "Object in example is not in analysis_result class") + msg = "Object in `analst` is not in `analysis_result` class") if (has_attr(item, name_of_meta)){ meta <- append(meta, index(i, item[[name_of_meta]])) @@ -716,14 +716,50 @@ analysis_info <- function(example, name_of_group = 'name', name_of_meta = 'meta' subset(info_df, select = -index) } -#' Extract analysis_result from a list of analysis_results by matching names and values +#' Convert analysis results to a data.frame #' -#' The function returns a list of all analysis_results in the input list that match the values with names specified via keywords parameters of the function. -#' If no value matches the specified name in any analysis_result containing in the given list or -#' the specified name does not existed in any analysis_result, the function returns an empty list `list()`. +#' @param analst Results of analysis object (`anaObj$results`) +#' @param index logical variable indicating whether to add index column for imputation dataset. Default: `FALSE` - no index column will be added. +#' @return A data frame each row of which corresponds to a analysis result +analst2df <- function(analst, index = FALSE) { + + add_index <- function(dt, i) cbind(dt, 'dt_num' = i) + + binarize <- function(f, side = 'left') { + laze <- function(x) function() x + trivial <- function(x, y) list(left=x, right=y)[[side]] + function(g = trivial) { + function(x, y) { + list( + left = laze(g(f(x), y)), + right = laze(g(x, f(y))) + )[[side]]() + } + } + } + + anainfo <- binarize(analysis_info) + ana2df <- ife(index, anainfo(add_index), anainfo()) + + base_bind_rows(mapply(ana2df, analst, seq_along(analst), SIMPLIFY = FALSE)) +} + +#' @rdname analyse +#' @export +as.data.frame.analysis <- function(x, ...) { + analst2df(x$results, index = TRUE) +} + +#' Extract analysis results from a list of analysis_results by matching names and values +#' +#' The function returns a list of all analysis results in the input list that match the values with names specified via keywords parameters of the function. +#' If no value matches the specified name in any sub list of analysis result or +#' the specified name does not existed, the function returns an empty list `list()`. +#' This function has general application for any type of nested list with named sublist that can be treated as analysis result. +#' For example, `extract_analysis_result(poolObj$pars, name = 'p1', visit = 1)` would extract the result from the parameters of the pool object with `name` as `'p1'` and `visit` as `1`. #' -#' @param results A list of analysis_result -#' @param ... Keywords parameters with the name and value matching the element in analysis result to be extracted +#' @param results A list of analysis results. It can be a list of `analysis_result` objects or more generally a nested list with named sublists which can be treated as analysis result such `poolObj$pars` +#' @param ... Keywords parameters with the name and value matching the element of the `analysis_result` objects inside the `results` #' @return A list of matched analysis results #' @export #' @examples @@ -735,6 +771,13 @@ analysis_info <- function(example, name_of_group = 'name', name_of_meta = 'meta' #' se = 2, #' df = 3, #' meta = list(visit = 'vis1') +#' ), +#' analysis_result( +#' name = 'trt2', +#' est = 3, +#' se = 4, +#' df = 5, +#' meta = list(visit = 'vis2') #' ) #' ) #' From 243392f2f6439db0faf12e6fd2b4afad560b2299 Mon Sep 17 00:00:00 2001 From: Guanya Peng Date: Thu, 16 Jun 2022 19:52:50 +0200 Subject: [PATCH 78/84] update pool --- R/pool.R | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/R/pool.R b/R/pool.R index d1b039c00..dc4e6762b 100644 --- a/R/pool.R +++ b/R/pool.R @@ -684,11 +684,10 @@ make_poolable <- function(results, non_group_keys=c("est", "se", "df")) { extract_aggregate <- function(lst, keys) unique(lst[keys]) extract_aggragates <- assert_map(extract_aggregate, function(x) nrow(x) == 1) - lsts2df <- function(lsts) base_bind_rows(lapply(lsts, analysis_info)) - results_df <- lsts2df(results) + results_df <- analst2df(results) group_keys <- setdiff(names(results_df), non_group_keys) - results <- split(results_df, vec2form(group_keys)) + results <- unname(split(results_df, vec2form(group_keys))) meta <- extract_aggragates(results, group_keys) structure(list(results = results, From df823e74ab6bd18efce282b1eab303f0d2c951d9 Mon Sep 17 00:00:00 2001 From: Guanya Peng Date: Thu, 16 Jun 2022 19:53:28 +0200 Subject: [PATCH 79/84] update utilities --- R/utilities.R | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/R/utilities.R b/R/utilities.R index 87ae8c0ef..9540cab5d 100644 --- a/R/utilities.R +++ b/R/utilities.R @@ -753,8 +753,6 @@ reduce_df <- function(df, keys, split = FALSE) { concat <- ife(split, make_concat(c), make_concat(list)) pos_process <- ife(split, function(x) do.call(data.frame, x), identity) pos_process( - aggregate(vec2form(keys, bothside = TRUE), data = df, FUN = concat) + aggregate(vec2form(keys, bothside = TRUE), data = df, FUN = concat, na.action=na.pass) ) } - - From 3f36cbd9f64449927f209327f186eafc17b43a7e Mon Sep 17 00:00:00 2001 From: Guanya Peng Date: Thu, 16 Jun 2022 19:54:07 +0200 Subject: [PATCH 80/84] update tests --- tests/testthat/test-lsmeans.R | 28 +++++++++++++++++++++------- tests/testthat/test-pool.R | 26 ++++++++++++++------------ 2 files changed, 35 insertions(+), 19 deletions(-) diff --git a/tests/testthat/test-lsmeans.R b/tests/testthat/test-lsmeans.R index 29954b9bf..daf36af78 100644 --- a/tests/testthat/test-lsmeans.R +++ b/tests/testthat/test-lsmeans.R @@ -28,7 +28,8 @@ test_that("Least square means works as expected - Part 1", { expect_equal( coef(mod)[["grpB"]], - mod2$lsm_alt_1$est - mod2$lsm_ref_1$est + extract_analysis_result(mod2, name = 'lsm_alt', meta = list(visit = 1))[[1]]$est - + extract_analysis_result(mod2, name = 'lsm_ref', meta = list(visit = 1))[[1]]$est ) @@ -116,11 +117,18 @@ test_that("Least square means works as expected - Part 2", { outcome = "outcome", group = "trt" ) - )[c("lsm_ref_vis1", "lsm_alt_vis1")] + ) + + result_actual <- append( + extract_analysis_result(result_actual, name = 'lsm_ref', meta = list(visit = 'vis1')), + extract_analysis_result(result_actual, name = 'lsm_alt', meta = list(visit = 'vis1')) + ) + result_expected <- list( - "lsm_ref_vis1" = lsm1, - "lsm_alt_vis1" = lsm2 + as_analysis_result(lsm1, name = 'lsm_ref', meta = add_meta('visit', 'vis1')), + as_analysis_result(lsm2, name = 'lsm_alt', meta = add_meta('visit', 'vis1')) ) + expect_equal(result_actual, result_expected) @@ -155,10 +163,16 @@ test_that("Least square means works as expected - Part 2", { group = "trt" ), weights = "equal" - )[c("lsm_ref_vis1", "lsm_alt_vis1")] + ) + + result_actual <- append( + extract_analysis_result(result_actual, name = 'lsm_ref', meta = list(visit = 'vis1')), + extract_analysis_result(result_actual, name = 'lsm_alt', meta = list(visit = 'vis1')) + ) + result_expected <- list( - "lsm_ref_vis1" = lsm1, - "lsm_alt_vis1" = lsm2 + as_analysis_result(lsm1, name = 'lsm_ref', meta = add_meta('visit', 'vis1')), + as_analysis_result(lsm2, name = 'lsm_alt', meta = add_meta('visit', 'vis1')) ) expect_equal(result_actual, result_expected) }) diff --git a/tests/testthat/test-pool.R b/tests/testthat/test-pool.R index e943c5113..ef62e0618 100644 --- a/tests/testthat/test-pool.R +++ b/tests/testthat/test-pool.R @@ -271,7 +271,7 @@ test_that("Pool (Rubin) works as expected when se = NA in analysis model", { bayes3 <- pool(results_bayes, alternative = "greater") expect_equal( - bayes$pars$p1, + extract_analysis_result(bayes$pars, name = 'p1')[[1]], list(name = 'p1', est = real_mu, ci = as.numeric(c(NA, NA)), @@ -281,7 +281,7 @@ test_that("Pool (Rubin) works as expected when se = NA in analysis model", { ) expect_equal( - bayes2$pars$p1, + extract_analysis_result(bayes2$pars, name = 'p1')[[1]], list(name = 'p1', est = real_mu, ci = as.numeric(c(NA, NA)), @@ -291,7 +291,7 @@ test_that("Pool (Rubin) works as expected when se = NA in analysis model", { ) expect_equal( - bayes3$pars$p1, + extract_analysis_result(bayes3$pars, name = 'p1')[[1]], list(name = 'p1', est = real_mu, ci = as.numeric(c(NA, NA)), @@ -317,7 +317,7 @@ test_that("Pool (Rubin) works as expected when se = NA in analysis model", { bayes3 <- pool(results_bayes, alternative = "greater") expect_equal( - bayes$pars$p1, + extract_analysis_result(bayes$pars, name = 'p1')[[1]], list(name = 'p1', est = real_mu, ci = as.numeric(c(NA, NA)), @@ -327,7 +327,7 @@ test_that("Pool (Rubin) works as expected when se = NA in analysis model", { ) expect_equal( - bayes2$pars$p1, + extract_analysis_result(bayes2$pars, name = 'p1')[[1]], list(name = 'p1', est = real_mu, ci = as.numeric(c(NA, NA)), @@ -337,7 +337,7 @@ test_that("Pool (Rubin) works as expected when se = NA in analysis model", { ) expect_equal( - bayes3$pars$p1, + extract_analysis_result(bayes3$pars, name = 'p1')[[1]], list(name = 'p1', est = real_mu, ci = as.numeric(c(NA, NA)), @@ -454,7 +454,7 @@ test_that("Pool (Rubin) works as expected when se = NA in analysis model", { pooled_res <- pool(results_bmlmi) expect_results(pooled_res, real_mu = real_mu, real_se = real_se) - expect_true(sd/sqrt(n) < pooled_res$pars$p1$se) + expect_true(sd/sqrt(n) < extract_analysis_result(pooled_res$pars, name = 'p1')[[1]]$se) }) @@ -851,14 +851,16 @@ test_that("condmean doesn't use first element in CI", { pooled_1 <- pool(x) - expect_equal(pooled_1$pars$p1$est, extract_analysis_result(x$results[[1]], name = 'p1')[[1]]$est) + expect_equal(extract_analysis_result(pooled_1$pars, name = 'p1')[[1]]$est, extract_analysis_result(x$results[[1]], name = 'p1')[[1]]$est) x$results[[1]][[1]]$est <- 9999 pooled_2 <- pool(x) - expect_equal(pooled_2$pars$p1$est, extract_analysis_result(x$results[[1]], name = 'p1')[[1]]$est) + expect_equal(extract_analysis_result(pooled_2$pars, name = 'p1')[[1]]$est, extract_analysis_result(x$results[[1]], name = 'p1')[[1]]$est) - pooled_1$pars$p1$est <- NULL - pooled_2$pars$p1$est <- NULL - expect_equal(pooled_1, pooled_2) + pooled_1_copy <- extract_analysis_result(pooled_1$pars, name = 'p1')[[1]] + pooled_2_copy <- extract_analysis_result(pooled_2$pars, name = 'p1')[[1]] + pooled_1_copy$est <- NULL + pooled_2_copy$est <- NULL + expect_equal(pooled_1_copy, pooled_2_copy) }) From 7d21a2389271cb38f738064a2a8160e1305efdbf Mon Sep 17 00:00:00 2001 From: Guanya Peng Date: Thu, 16 Jun 2022 19:54:33 +0200 Subject: [PATCH 81/84] update doc --- man/analst2df.Rd | 19 +++++++++++++++++++ man/analyse.Rd | 3 +++ man/analysis_info.Rd | 14 +++++++------- man/extract_analysis_result.Rd | 21 +++++++++++++++------ 4 files changed, 44 insertions(+), 13 deletions(-) create mode 100644 man/analst2df.Rd diff --git a/man/analst2df.Rd b/man/analst2df.Rd new file mode 100644 index 000000000..bcc15ec14 --- /dev/null +++ b/man/analst2df.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/analyse.R +\name{analst2df} +\alias{analst2df} +\title{Convert analysis results to a data.frame} +\usage{ +analst2df(analst, index = FALSE) +} +\arguments{ +\item{analst}{Results of analysis object (\code{anaObj$results})} + +\item{index}{logical variable indicating whether to add index column for imputation dataset. Default: \code{FALSE} - no index column will be added.} +} +\value{ +A data frame each row of which corresponds to a analysis result +} +\description{ +Convert analysis results to a data.frame +} diff --git a/man/analyse.Rd b/man/analyse.Rd index 6bb1ef340..5836de470 100644 --- a/man/analyse.Rd +++ b/man/analyse.Rd @@ -2,9 +2,12 @@ % Please edit documentation in R/analyse.R \name{analyse} \alias{analyse} +\alias{as.data.frame.analysis} \title{Analyse Multiple Imputed Datasets} \usage{ analyse(imputations, fun = ancova, delta = NULL, ...) + +\method{as.data.frame}{analysis}(x, ...) } \arguments{ \item{imputations}{An \code{imputations} object as created by \code{\link[=impute]{impute()}}.} diff --git a/man/analysis_info.Rd b/man/analysis_info.Rd index 830097e15..6d852632d 100644 --- a/man/analysis_info.Rd +++ b/man/analysis_info.Rd @@ -2,22 +2,22 @@ % Please edit documentation in R/analyse.R \name{analysis_info} \alias{analysis_info} -\title{Get printable analysis information from an example of analysis result} +\title{Convert a list of analysis_result objects to data.frame} \usage{ -analysis_info(example, name_of_group = "name", name_of_meta = "meta") +analysis_info(analst, name_of_group = "name", name_of_meta = "meta") } \arguments{ -\item{example}{A subset of the result of the analysis object for getting enough info to print. It should not be the complete result of analysis object but a subset of it such as \code{anaObj$results[[1]]}} +\item{analst}{A list of \code{analysis_result} objects. It should not be the complete result of analysis object but a subset of it such as \code{anaObj$results[[1]]}} -\item{name_of_group}{A character variable for the name of group variable in the result of analysis which is defined from \code{analysis_result}. Default: \code{'name'}} +\item{name_of_group}{A \code{character} variable for the name of group variable in the result of analysis which is defined from \code{analysis_result}. Default: \code{'name'}} -\item{name_of_meta}{A character variable for the name of meta data in the result of analysis which is defined from \code{analysis_result}. Default: 'meta'} +\item{name_of_meta}{A \code{character} variable for the name of meta data in the result of analysis which is defined from \code{analysis_result}. Default: \code{'meta'}} } \value{ -A data.frame containing the information of the analysis result from the example +A \code{data.frame} containing the information of the analysis result from the \code{analst} } \description{ -Get printable analysis information from an example of analysis result +Convert a list of analysis_result objects to data.frame } \examples{ \dontrun{ diff --git a/man/extract_analysis_result.Rd b/man/extract_analysis_result.Rd index 85f8d0131..ea394cc15 100644 --- a/man/extract_analysis_result.Rd +++ b/man/extract_analysis_result.Rd @@ -2,22 +2,24 @@ % Please edit documentation in R/analyse.R \name{extract_analysis_result} \alias{extract_analysis_result} -\title{Extract analysis_result from a list of analysis_results by matching names and values} +\title{Extract analysis results from a list of analysis_results by matching names and values} \usage{ extract_analysis_result(results, ...) } \arguments{ -\item{results}{A list of analysis_result} +\item{results}{A list of analysis results. It can be a list of \code{analysis_result} objects or more generally a nested list with named sublists which can be treated as analysis result such \code{poolObj$pars}} -\item{...}{Keywords parameters with the name and value matching the element in analysis result to be extracted} +\item{...}{Keywords parameters with the name and value matching the element of the \code{analysis_result} objects inside the \code{results}} } \value{ A list of matched analysis results } \description{ -The function returns a list of all analysis_results in the input list that match the values with names specified via keywords parameters of the function. -If no value matches the specified name in any analysis_result containing in the given list or -the specified name does not existed in any analysis_result, the function returns an empty list \code{list()}. +The function returns a list of all analysis results in the input list that match the values with names specified via keywords parameters of the function. +If no value matches the specified name in any sub list of analysis result or +the specified name does not existed, the function returns an empty list \code{list()}. +This function has general application for any type of nested list with named sublist that can be treated as analysis result. +For example, \code{extract_analysis_result(poolObj$pars, name = 'p1', visit = 1)} would extract the result from the parameters of the pool object with \code{name} as \code{'p1'} and \code{visit} as \code{1}. } \examples{ \dontrun{ @@ -28,6 +30,13 @@ results <- list( se = 2, df = 3, meta = list(visit = 'vis1') + ), + analysis_result( + name = 'trt2', + est = 3, + se = 4, + df = 5, + meta = list(visit = 'vis2') ) ) From 6e0336f3f1df309f9021f6d5e9f696dfb4e7a24c Mon Sep 17 00:00:00 2001 From: Guanya Peng Date: Thu, 16 Jun 2022 19:55:11 +0200 Subject: [PATCH 82/84] update namespace --- NAMESPACE | 1 + 1 file changed, 1 insertion(+) diff --git a/NAMESPACE b/NAMESPACE index ad2e24554..a0b26d3f8 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,5 +1,6 @@ # Generated by roxygen2: do not edit by hand +S3method(as.data.frame,analysis) S3method(as.data.frame,pool) S3method(draws,approxbayes) S3method(draws,bayes) From f10b57ebbe997c93d63bfe2938cd51d7774e4f8c Mon Sep 17 00:00:00 2001 From: Guanya Peng Date: Fri, 17 Jun 2022 16:51:53 +0200 Subject: [PATCH 83/84] final update --- R/stanmodels.R | 2 +- R/sysdata.rda | Bin 2702 -> 2819 bytes src/.gitkeep | 0 tests/testthat/_snaps/print.md | 243 ++++++++++++++------------ tests/testthat/test-analysis_result.R | 57 +++++- tests/testthat/test-fullusage.R | 49 ++++-- tests/testthat/test-print.R | 3 +- tests/testthat/test-utilities.R | 33 ++++ 8 files changed, 254 insertions(+), 133 deletions(-) delete mode 100644 src/.gitkeep diff --git a/R/stanmodels.R b/R/stanmodels.R index c8f6b0d8b..ee23926c5 100644 --- a/R/stanmodels.R +++ b/R/stanmodels.R @@ -21,5 +21,5 @@ stanmodels <- sapply(stanmodels, function(model_name) { model_name = stanfit$model_name, model_code = stanfit$model_code, model_cpp = stanfit$model_cpp, - mk_cppmodule = function(x) get(paste0("model_", model_name))) + mk_cppmodule = function(x) get(paste0("rstantools_model_", model_name))) }) diff --git a/R/sysdata.rda b/R/sysdata.rda index f750a5d9d7a349704cf49d7f783df550ae35e7ab..7b50fb4cef152f89d3e5387161a2085ffa41118e 100644 GIT binary patch delta 2796 zcmVsOPg5XdXf)FirU(p1jT#520io&)O&VbX z2*?J3={+W!NuvOO$kBe2c-0esK|JYLr+kC zsASnkskI(0pv2I6jSU$C(t0M!2FW&%4Lu-e(;yz0kZFh-0BB?~05r*_hoJDJ7h9Jn%ra%DGMw&DL02qT!4FCp!G|&KO02&5^Lrnpr zOoK*%00E#HG#UT~ga7~l02%-Q044wv00000005W(000vJ05kvq001Tcm;eGW001JS zCZ<6!Pe3&qYGpU7dqzT=B=R*eH1<EcM#LS#rp025Rg z$bT%TEQm;|ff_(P$=?2w>p{qWZrj6%$6Y`SuZ#I52o8OU#;sgjMZ6i zpKJDRX*wLv=hWr&ALnhG>UJNJ`sa|=dNw!KqiO(?!AJ;%1Q-en0agHlA!`8v8-bBQ zw@_f9;>0B!Y6}pA#1;akoMHrGRDUL-mWZTIQ52vt1~g|yj~FCW!Xk}o0-*s!Uoy%o z-S)=@K>n=5$RIg59-IXS0~v1^g?5r9Y#;zV z$Jxsfs5N`YkUN7#*73L{db@F92_RlrNJWYYQKChH(FGQar70)e!qCk$kbi-f`2Q+` zLd$xmoWRE*0nJwK;{a3m{d?|TA20-KY+@B~H#<1c6#6=vh{pl~iiST|KQ&K6P~3j( zuChcgabE8aBH}9eSo-KL7SF1gbdnX4?3`Cys=%s1H5F7)RRt7~Sg7H4mfbC}p6SeY zTl4Z1f+F_+4E}ysLkEE^a)0_fh79^DZU4oN!3ix%T$o-{2jAtojPr3DQ%KvYz2HAP zb#<70hIXxs!L_znV4U0Xn7Vp7Dq>$tfu<7=Lg3q2WL{MZ@?9B!cQ*B$xYQcPC)cV5 zAug`GhG0ylUV*9(J?O6n*Hp*x^oO6_Q_5}bj^V$I8ScQ&L;rBCfreyI&h>d)cQ4U2hsG`(aFA)5eN&R)3z$WxUT( z05>{K4|$}&rNe1@$bZbVvUn+0SIS5A7iEU}=VaHqQjw@;=KtPu4gPjKe|WnYCc}kT zhDsyCECL(b!O~mr9NyKZ)_4XckO1544Kn2{1Q8St%9K$QM46<89d?w8CPl{8kh$0$ z^Od#vIgFMv#L6Z@(u_sJu%eKAW{z3LWN2S3?w)3M_rBe2_kWvS*PzMuJGKi6VU6<4 z&yl?4bYj9S6JxwcJvf^;%*~{%@d`R$81^|%jO@LABrMac1m|hIa&^m?nrm-i-e`wa z)ibfj0Lc^(!b7?TrXXH)ld`L#umm44-NHCeW!3hNfU_{f`jj@I(`IVg+7a@l42k-9 zPaI`+hDiZrWPi>jD=gEQy84=JZ~zg=qy!-anE(sn38tWJton^^`z`r)^Y=$|ic*a! z`H(Ay{XwY_ZVm{N@P9;v!Qx8{$Ah!ikrdP~xn0(DuiD;Ag*l}MR#N#UL}NuKzCM(6 zEpdmQpwJvL3uTc|e2BMl6-V@7fkeB*5^ux?U4c8KP=92Q7}rKQUAb6+ROj%c_|Zzq z2IaZGGu-a)O~X}=i&53(34I#k$wBn4@hxR3lPxU;0hlNZgWGsFnL0gnH%MFzSgZT0 z|5t*|`#15*L>THQyV$s2M#~0LFV#G4+7hY12{m= z(bU|;2-O+9RzvsWD(b0W3igmeg9Z#O#ITSfAb(4n2>_*`EyZI|7|tXcbW&1k1sQbW zqS520n<|2xLCIni8lkCNLJO5e16vF2#)^Y?Po=Bkyl#Z~E9ey?d-C|524-}6oHZ~l z^2r-jQ94%4;`)ibhJ+{8`Zp_D&Botc+b*l%i~$b-oy7wkQhXt0u>fhJWe?NSj^woj zr++Bu2lo*fnI*qL=SGbpmUOCb*jXdtU0@eB<{ZD9TS#=am!jzlFzO^Nm?2r=rEk8i zD>kM0WH?>*GX#-~vD-J@FZ}vX`h?~%APN>thgA{X{*TjAk(pVP$qO%9hP2J<>7xQl zdIuIX3A{((ls7B>=Q587YlM=$;}>$J>VH4L&=^$cWG~b)0qbqtWAdm~CV7{Z=i6x( zpur!smkB+x>zpb1A@{mGfx_*`_AvN58B==hlL6|NY6(&8^kO6!4RRYRJBrDCjN#@5 zZk=#>i_CBU-E_DlfE|x=!ut6d6R5H3)iRKrX$uo!5lP6DenQJds|&iy`%|hsEq^tf zK;e%=z6e-3>X?`Y#}FiF2;!radMeoDnKA^ZiNFT1wY)z z64pzf6MkUv4>fRd@~)9mS|t^;Du1j3aW}bbUS^Joy>E^=%VS-at|F|~Aofi(ue^pI zJso|bL(@6_r`n)ulEHb7Uj)nHl6nqfT-wwk>8l;$&;~7Oq8PXLw^5qw(62#}Qx7f&Qx&8Rk2MwDAik!3SrJAWVflz6aGqluyIyyZ zYj_bEQEwXHaaz&?CqLRgCtqk&?w{S!?^@h`#kWr-`NYe4mfPv;Y<~f_o#1jj27I#A yC^}*QDQ}y$02ad!&S3owMV355h$Dm#{x0N-aG@alP_(XAJ^#S~ delta 2677 zcmV-*3X1iE7LFAWLRx4!F+o`-Q(15?YWDyRl93S}fBygf|KJDz4X<*5QVp}c?*IwF zO7+-^Nv5Z%>OCMHNvEQD5vEU5H5z#%)CZ)~X`@qW8fY|aL8hLOr>N1UjR0iPiJ^oI zsgU&tpqglDF3 zXwcI}fHZoTgG~;AXeJW?m<cA~QtD%}-O*V2!4edV@nr={7+y(rq+Mn^O$~gg+u5^g^ly zp$ZEGEC$UifvqA40s;xqK(8AFD4tbFP>}>cu@FQoF#!<3P$)8g5QPR=>PihI2K_ov zAzMJuGod=pPdw;O3e1xvgFF8H%d79x&~5%&zyk8{&WLb_on01!36>H5erxDn-Ldyf zO}c9d*DV9~Nb{ss$91_M#UfZ5mzX*oZ}!Ku$o2y$_67vg3KJ0rfZpP5d#O8Tx(1~b z@VyD|g|ZYn+6_7O*;8-wI5i-Fli+ z^YnWHmj?(UJH!bP)PR&SfRqx6LPP{aK`2OuP$^o#hR-7)K%VYMx-6Bh%5e>LW767Y zaTJ7FmY2HNK)2g@(<&!H zqTE{D)w&IDZEa1X&d01VHKnCAvyX zX@Um8S=U4|$u%0J;1NGBCa`cWhAM;aY4|TxgW}cZQ*qo|zcM+iR!~Y^6_?20R*f?d zGbhTv)n{VPLb052lAL1GhdAGLousj53tr93T?L5wv%xga|@H;|E`bp0m~#0RTWoQPQqb zy{y+CfTay8HEGrxX6J%cFC{WpeX}Wx7&O_erq*(|xZ*#r6+qm@VGhTKle^_^<~2rt za!3J~-pf{E0s#bo87V}92?P+Fk`O5F6r>~(Fm)?pofik<&C)Y7!OgG|qCjkIG zj35BpAXt);1P@#=q$DW=1MOQ>{NCQfBh~oUdosA{&@D%-P;4;fG@mp&8OjHLCS|hM zyyx#ES8lx58M4imn))giiVmQ@e{$q(oOgi<{hLCfgS}t}bn+A)s#?quVtK3}RS&9S zP1u2@{7TIFgFNFf*?C1bld&5#3n|AW=R0$h^nYK`uO5Qr^Qsn#4$9fFt1b)%0YRZb zoNqHYtgl;r4 zx_K!AHRlmVK~w*&?`)vhL!JGab{|%l++v! z{R$0;*bWUr?C!ds-M6-QoSlDN?>FY^V!*?IM{c#+B1d?t4aJ1Zj5{^t+_}otODNas zfsVt*kyXZFQ+Be06AyBB_uwmG**>jeG{4&5bL*`!t>BJ#_Qmx=>yfAVT+&yGl zRjP4%-PDact9_F9)&$7Z1B>6>pNuLTvMiw%bs~WLbsBp*Th7@#qLhfxI|7)n7#@1L z1fbkn!^4lkQ#Kea?uN9D95k5yIT}}Y^+5w0dbo*Yen&W)(%{P1?`pvS|S!#Nf$@fn#QfE3C+mBx7=FT&epZ%)SR>{E)YQsLdN|Q6P8;yOUV&H8_SL z;s(}o+BR(j^_3s`&^y4zW2tj8DVq1BR8TuVw{y0t3qu@~udcJPF+hKl8{-EXIC*|o zyqoYs4aCo_bS%{%+Bs%pD+csYjUd9-NM2?A=XD0cEX_@|@P!E8v5J~9dW0;#SL_Q(-+7K%WMX52N| z00zK71q1p3(LxFt*>1Ufcu>Y&)e6=eK9DQ!1U|__(ZqZY1;j?q&t~x5X6kT2Qpu!< z -Inf 7.383 <0.001 - lsm_ref_visit_1 7.605 -Inf 8.126 <0.001 - lsm_alt_visit_1 14.248 -Inf 15.088 <0.001 - trt_visit_2 6.906 -Inf 7.944 <0.001 - lsm_ref_visit_2 7.299 -Inf 7.666 <0.001 - lsm_alt_visit_2 14.205 -Inf 14.977 <0.001 - trt_visit_3 4.118 -Inf 4.257 <0.001 - lsm_ref_visit_3 7.514 -Inf 8.083 <0.001 - lsm_alt_visit_3 11.632 -Inf 11.837 <0.001 - ----------------------------------------------------- + ====================================================== + name visit est lci uci se pvalue + ------------------------------------------------------ + lsm_alt visit_1 14.248 -Inf 15.088 <0.001 + lsm_ref visit_1 7.605 -Inf 8.126 <0.001 + trt visit_1 6.643 -Inf 7.383 <0.001 + lsm_alt visit_2 14.205 -Inf 14.977 <0.001 + lsm_ref visit_2 7.299 -Inf 7.666 <0.001 + trt visit_2 6.906 -Inf 7.944 <0.001 + lsm_alt visit_3 11.632 -Inf 11.837 <0.001 + lsm_ref visit_3 7.514 -Inf 8.083 <0.001 + trt visit_3 4.118 -Inf 4.257 <0.001 + ------------------------------------------------------ --- @@ -100,19 +100,19 @@ Results: - ====================================================== - parameter est se lci uci pval - ------------------------------------------------------ - trt_visit_1 6.643 0.561 -Inf 7.565 <0.001 - lsm_ref_visit_1 7.605 1.057 -Inf 9.343 <0.001 - lsm_alt_visit_1 14.248 1.163 -Inf 16.161 <0.001 - trt_visit_2 6.906 0.852 -Inf 8.308 <0.001 - lsm_ref_visit_2 7.299 1.114 -Inf 9.13 <0.001 - lsm_alt_visit_2 14.205 0.984 -Inf 15.823 <0.001 - trt_visit_3 4.118 0.663 -Inf 5.208 <0.001 - lsm_ref_visit_3 7.514 1.003 -Inf 9.165 <0.001 - lsm_alt_visit_3 11.632 1.339 -Inf 13.834 <0.001 - ------------------------------------------------------ + ======================================================= + name visit est lci uci se pvalue + ------------------------------------------------------- + lsm_alt visit_1 14.248 -Inf 16.161 1.163 <0.001 + lsm_ref visit_1 7.605 -Inf 9.343 1.057 <0.001 + trt visit_1 6.643 -Inf 7.565 0.561 <0.001 + lsm_alt visit_2 14.205 -Inf 15.823 0.984 <0.001 + lsm_ref visit_2 7.299 -Inf 9.13 1.114 <0.001 + trt visit_2 6.906 -Inf 8.308 0.852 <0.001 + lsm_alt visit_3 11.632 -Inf 13.834 1.339 <0.001 + lsm_ref visit_3 7.514 -Inf 9.165 1.003 <0.001 + trt visit_3 4.118 -Inf 5.208 0.663 <0.001 + ------------------------------------------------------- --- @@ -130,19 +130,19 @@ Results: - ======================================================== - parameter est se lci uci pval - -------------------------------------------------------- - trt_visit_1 7.296 0.784 6.006 8.587 <0.001 - lsm_ref_visit_1 7.051 0.766 5.792 8.311 <0.001 - lsm_alt_visit_1 14.348 0.74 13.131 15.564 <0.001 - trt_visit_2 7.363 0.373 6.749 7.977 <0.001 - lsm_ref_visit_2 7.085 0.555 6.173 7.997 <0.001 - lsm_alt_visit_2 14.448 0.599 13.463 15.433 <0.001 - trt_visit_3 4.593 1.063 2.844 6.342 <0.001 - lsm_ref_visit_3 6.469 0.815 5.129 7.809 <0.001 - lsm_alt_visit_3 11.062 0.929 9.534 12.59 <0.001 - -------------------------------------------------------- + ========================================================= + name visit est lci uci se pvalue + --------------------------------------------------------- + lsm_alt visit_1 14.348 13.131 15.564 0.74 <0.001 + lsm_ref visit_1 7.051 5.792 8.311 0.766 <0.001 + trt visit_1 7.296 6.006 8.587 0.784 <0.001 + lsm_alt visit_2 14.448 13.463 15.433 0.599 <0.001 + lsm_ref visit_2 7.085 6.173 7.997 0.555 <0.001 + trt visit_2 7.363 6.749 7.977 0.373 <0.001 + lsm_alt visit_3 11.062 9.534 12.59 0.929 <0.001 + lsm_ref visit_3 6.469 5.129 7.809 0.815 <0.001 + trt visit_3 4.593 2.844 6.342 1.063 <0.001 + --------------------------------------------------------- --- @@ -160,19 +160,19 @@ Results: - ======================================================== - parameter est se lci uci pval - -------------------------------------------------------- - trt_visit_1 7.039 0.5 6.032 8.047 <0.001 - lsm_ref_visit_1 6.993 1.38 4.212 9.773 0.004 - lsm_alt_visit_1 14.032 1.178 11.658 16.406 <0.001 - trt_visit_2 7.494 0.403 6.681 8.306 <0.001 - lsm_ref_visit_2 6.694 1.278 4.119 9.27 0.003 - lsm_alt_visit_2 14.188 1.013 12.146 16.23 <0.001 - trt_visit_3 4.737 1.142 2.43 7.044 0.009 - lsm_ref_visit_3 6.53 1.097 4.318 8.742 0.002 - lsm_alt_visit_3 11.267 1.753 7.734 14.8 0.001 - -------------------------------------------------------- + ========================================================= + name visit est lci uci se pvalue + --------------------------------------------------------- + lsm_alt visit_1 14.032 11.658 16.406 1.178 <0.001 + lsm_ref visit_1 6.993 4.212 9.773 1.38 0.004 + trt visit_1 7.039 6.032 8.047 0.5 <0.001 + lsm_alt visit_2 14.188 12.146 16.23 1.013 <0.001 + lsm_ref visit_2 6.694 4.119 9.27 1.278 0.003 + trt visit_2 7.494 6.681 8.306 0.403 <0.001 + lsm_alt visit_3 11.267 7.734 14.8 1.753 0.001 + lsm_ref visit_3 6.53 4.318 8.742 1.097 0.002 + trt visit_3 4.737 2.43 7.044 1.142 0.009 + --------------------------------------------------------- # print - approx bayes @@ -226,15 +226,20 @@ Analysis Function: ancova Delta Applied: FALSE Analysis Estimates: - trt_visit_1 - lsm_ref_visit_1 - lsm_alt_visit_1 - trt_visit_2 - lsm_ref_visit_2 - lsm_alt_visit_2 - trt_visit_3 - lsm_ref_visit_3 - lsm_alt_visit_3 + + ===================================== + name est se df visit + ------------------------------------- + trt 7.253 0.781 35 visit_1 + lsm_ref 7.254 0.566 35 visit_1 + lsm_alt 14.507 0.479 35 visit_1 + trt 7.406 0.388 35 visit_2 + lsm_ref 7.011 0.282 35 visit_2 + lsm_alt 14.417 0.238 35 visit_2 + trt 5.037 1.128 35 visit_3 + lsm_ref 6.942 0.818 35 visit_3 + lsm_alt 11.978 0.692 35 visit_3 + ------------------------------------- # print - bayesian @@ -288,12 +293,17 @@ Analysis Function: rbmi::ancova Delta Applied: TRUE Analysis Estimates: - trt_visit_1 - lsm_ref_visit_1 - lsm_alt_visit_1 - trt_visit_3 - lsm_ref_visit_3 - lsm_alt_visit_3 + + ===================================== + name est se df visit + ------------------------------------- + trt 7.253 0.781 35 visit_1 + lsm_ref 7.254 0.566 35 visit_1 + lsm_alt 14.507 0.479 35 visit_1 + trt 7.929 0.184 35 visit_3 + lsm_ref 6.966 0.134 35 visit_3 + lsm_alt 14.895 0.113 35 visit_3 + ------------------------------------- # print - condmean bootstrap @@ -348,15 +358,20 @@ Analysis Function: ancova Delta Applied: FALSE Analysis Estimates: - trt_visit_1 - lsm_ref_visit_1 - lsm_alt_visit_1 - trt_visit_2 - lsm_ref_visit_2 - lsm_alt_visit_2 - trt_visit_3 - lsm_ref_visit_3 - lsm_alt_visit_3 + + ===================================== + name est se df visit + ------------------------------------- + trt 6.643 1.26 37 visit_1 + lsm_ref 7.605 0.955 37 visit_1 + lsm_alt 14.248 0.821 37 visit_1 + trt 6.906 0.941 37 visit_2 + lsm_ref 7.299 0.713 37 visit_2 + lsm_alt 14.205 0.613 37 visit_2 + trt 7.181 0.917 37 visit_3 + lsm_ref 7.51 0.696 37 visit_3 + lsm_alt 14.691 0.598 37 visit_3 + ------------------------------------- # print - condmean jackknife @@ -410,15 +425,20 @@ Analysis Function: ancova Delta Applied: FALSE Analysis Estimates: - trt_visit_1 - lsm_ref_visit_1 - lsm_alt_visit_1 - trt_visit_2 - lsm_ref_visit_2 - lsm_alt_visit_2 - trt_visit_3 - lsm_ref_visit_3 - lsm_alt_visit_3 + + ===================================== + name est se df visit + ------------------------------------- + trt 7.296 0.657 30 visit_1 + lsm_ref 7.051 0.501 30 visit_1 + lsm_alt 14.348 0.406 30 visit_1 + trt 7.363 0.37 30 visit_2 + lsm_ref 7.085 0.282 30 visit_2 + lsm_alt 14.448 0.229 30 visit_2 + trt 4.593 1.169 30 visit_3 + lsm_ref 6.469 0.892 30 visit_3 + lsm_alt 11.062 0.722 30 visit_3 + ------------------------------------- # print - bmlmi @@ -472,6 +492,11 @@ Analysis Function: compare_prop_lastvisit Delta Applied: FALSE Analysis Estimates: - trt + + ======================== + name est se df + ------------------------ + trt 2.005 0.73 Inf + ------------------------ diff --git a/tests/testthat/test-analysis_result.R b/tests/testthat/test-analysis_result.R index 40183ad72..50cc1b8d4 100644 --- a/tests/testthat/test-analysis_result.R +++ b/tests/testthat/test-analysis_result.R @@ -155,6 +155,9 @@ test_that("incorrect constructions of analysis_result fail", { # Test for as_analysis_result # This test needs to be updated accordingly if ana_name_chker has been udpated test_that("as_analysis_result works as expected", { + + skip_if_not(is_full_test()) + expect_general <- function(x) { expect_s3_class(x, c("analysis_result", "list")) expect_equal(typeof(x), "list") @@ -178,6 +181,9 @@ test_that("as_analysis_result works as expected", { test_that("ana_name_chker works as expected", { + + skip_if_not(is_full_test()) + f <- ana_name_chker() expect_equal(class(f), "function") expect_equal(class(f('musthave_in_objnames')), 'function') @@ -199,6 +205,8 @@ test_that("is.analysis_result works as expected", { test_that("analysis_info works as expected", { + skip_if_not(is_full_test()) + # check for normal input test_names <- c('a', 'b', 'c', 'd', 'e', 'f', 'g') test_ests <- seq(length(test_names)) @@ -232,6 +240,8 @@ test_that("analysis_info works as expected", { test_that("extract_analysis_result works as expected", { + skip_if_not(is_full_test()) + x1 <- analysis_result(name ='a', est = 1, se = 2) x2 <- analysis_result(name ='b', est = 2) x3 <- analysis_result(name ='c', est = 3, se = NA, meta = list(visit = 5)) @@ -402,12 +412,53 @@ test_that("extract_analysis_result works as expected", { expect_equal(actual, expect) expect_error(extract_analysis_result(x, meta = list('abc')), - "Invalide parameters") + "Invalid parameters") expect_error(extract_analysis_result(x, meta = list(NULL)), - "Invalide parameters") + "Invalid parameters") expect_error(extract_analysis_result(x, meta = list(NA)), - "Invalide parameters") + "Invalid parameters") } ) + +test_that("analst2df works as expected", { + + skip_if_not(is_full_test()) + + ana_list <- list( + list( + analysis_result(name = 'trt', est = 1, meta = list(visit = 1)), + analysis_result(name = 'ref1', est = 2, se = 2, meta = list(visit = 2, abc = 'm')), + analysis_result(name = 'ref2', est = 3, df = 5, meta = list(efg = 'q')) + ), + list( + analysis_result(name = 'trt_a', est = 9, meta = list(visit = 7)), + analysis_result(name = 'ref2', est = 10, se = NA, df = 15, meta = list(abc = 't', kkkk = NA)), + analysis_result(name = 'ref_a', est = 11, df = NA, meta = list(efg = NA, uut = 21)) + ) + ) + + expect_s3_class(analst2df(ana_list), 'data.frame') + expect_named(analst2df(ana_list)) + expect_equal(names(analst2df(ana_list)), c('name', 'est', 'se', 'df', 'visit', 'abc', 'efg', 'kkkk', 'uut')) + expect_equal(analst2df(ana_list)$name[[4]], 'trt_a') + expect_equal(analst2df(ana_list)$est[[6]], 11) + expect_equal(analst2df(ana_list)$se[[2]], 2) + expect_true(is.na(analst2df(ana_list)$se[[3]])) + expect_equal(analst2df(ana_list)$df[[3]], 5) + expect_equal(analst2df(ana_list)$df[[5]], 15) + expect_true(is.na(analst2df(ana_list)$df[[4]])) + expect_equal(analst2df(ana_list)$visit[[4]], 7) + expect_equal(analst2df(ana_list)$visit[[2]], 2) + expect_true(is.na(analst2df(ana_list)$visit[[5]])) + expect_equal(analst2df(ana_list)$abc[[2]], 'm') + expect_equal(analst2df(ana_list)$abc[[5]], 't') + expect_equal(analst2df(ana_list)$abc[[1]], as.character(NA)) + expect_true(is.na(analst2df(ana_list)$abc[[1]])) + expect_equal(analst2df(ana_list)$efg[[3]], 'q') + expect_true(is.na(analst2df(ana_list)$efg[[6]])) + expect_true(all(is.na(analst2df(ana_list)$kkkk))) + expect_true(is.na(analst2df(ana_list)$uut[[1]])) + expect_equal(analst2df(ana_list)$uut[[6]], 21) +}) diff --git a/tests/testthat/test-fullusage.R b/tests/testthat/test-fullusage.R index 68c70e3dd..9e7a39425 100644 --- a/tests/testthat/test-fullusage.R +++ b/tests/testthat/test-fullusage.R @@ -16,28 +16,39 @@ sigma <- as_vcov(c(2, 1, 0.7), c(0.5, 0.3, 0.2)) nsamp <- 200 -expect_pool_est <- function(po, expected, param = "trt.visit_3") { +expect_pool_ests <- function(po, expected, ...) { + actuallst <- extract_analysis_result(po$pars, ...) + + assert_that(!!length(actuallst), + msg = sprintf("No matches for condition: %s ", + mapply(function(var, value) paste(paste0("`",var,"`"), value, sep = ' == '), + names(list(...)), list(...)) %>% paste(collapse = ' & '))) + + actual <- actuallst[[1]] + expect_contains( - po$pars[[param]]$ci, + actual$ci, expected ) expect_contains( - po$pars[[param]]$ci, - po$pars[[param]]$est + actual$ci, + actual$est ) - if ("lsm_alt.visit_3" %in% names(po$pars)) { - lsm_trt <- (po$pars$lsm_alt.visit_3$est - po$pars$lsm_ref.visit_3$est) + lsm_alt_visit_3 <- extract_analysis_result(po$pars, name = "lsm_alt", visit = "visit_3") + lsm_ref_visit_3 <- extract_analysis_result(po$pars, name = "lsm_ref", visit = "visit_3") + if (!!length(lsm_alt_visit_3) & !!length(lsm_ref_visit_3)) { + lsm_trt <- (lsm_alt_visit_3[[1]]$est - lsm_ref_visit_3[[1]]$est) expect_within( - lsm_trt - po$pars[[param]]$est, + lsm_trt - actual$est, c(-0.005, 0.005) ) } } - +expect_pool_est <- function(po, expected) expect_pool_ests(po, expected, name = 'trt', visit = 'visit_3') test_that("Basic Usage - Approx Bayes", { @@ -365,7 +376,7 @@ test_that("Custom Strategies and Custom analysis functions", { poolobj <- pool(anaobj) expect_within( - poolobj$pars$treatment_effect$est, + extract_analysis_result(poolobj$pars, name = 'treatment_effect')[[1]]$est, 4 + c(-0.3, 0.3) ) @@ -383,7 +394,7 @@ test_that("Custom Strategies and Custom analysis functions", { poolobj_delta <- pool(anaobj_delta) - expect_pool_est(poolobj_delta, 14, "treatment_effect") + expect_pool_ests(poolobj_delta, 14, name = "treatment_effect") @@ -400,7 +411,7 @@ test_that("Custom Strategies and Custom analysis functions", { poolobj_delta <- pool(anaobj_delta) - expect_pool_est(poolobj_delta, 24, "treatment_effect") + expect_pool_ests(poolobj_delta, 24, name = "treatment_effect") @@ -528,7 +539,7 @@ test_that("Multiple imputation references / groups work as expected (end to end vars2$group <- "group" x_ana <- analyse(x_imp, ancova, vars = vars2) x_pl <- pool(x_ana, conf.level = 0.98) - x_pl$pars$trt.visit_3$ci + extract_analysis_result(x_pl$pars, name = 'trt', visit = 'visit_3')[[1]]$ci } set.seed(2351) @@ -807,11 +818,11 @@ test_that("rbmi works for one arm trials", { } else { pooled <- pool(anl_obj) } - - expect_length(pooled$pars$mean, 5) - expect_true(all(!is.null(unlist(pooled$pars$mean)))) - expect_true(all(!is.na(unlist(pooled$pars$mean)))) - expect_true(all(is.double(unlist(pooled$pars$mean[names(pooled$pars$mean) != 'name'])))) + pooled_mean <- extract_analysis_result(pooled$pars, name = 'mean')[[1]] + expect_length(pooled_mean, 5) + expect_true(all(!is.null(unlist(pooled_mean)))) + expect_true(all(!is.na(unlist(pooled_mean)))) + expect_true(all(is.double(unlist(pooled_mean[names(pooled_mean) != 'name'])))) } method <- method_condmean(type = "jackknife") @@ -922,7 +933,7 @@ test_that("Three arms trial runs smoothly and gives expected results", { imp_dat <- extract_imputed_dfs(imputeobj)[[1]] expect_equal(imp_dat$outcome[imp_dat$group == "B"], imp_dat$outcome[imp_dat$group == "C"]) expect_equal(anaobj$results[[1]]$trtB, anaobj$results[[1]]$trtC) - expect_equal(pooled$pars$trtB, pooled$pars$trtC) + expect_equal(extract_analysis_result(pooled$pars, name = 'trtB'), extract_analysis_result(pooled$pars, name = 'trtC')) ########## same_cov = FALSE @@ -951,6 +962,6 @@ test_that("Three arms trial runs smoothly and gives expected results", { imp_dat <- extract_imputed_dfs(imputeobj)[[1]] expect_equal(imp_dat$outcome[imp_dat$group == "B"], imp_dat$outcome[imp_dat$group == "C"]) expect_equal(anaobj$results[[1]]$trtB, anaobj$results[[1]]$trtC) - expect_equal(pooled$pars$trtB, pooled$pars$trtC) + expect_equal(extract_analysis_result(pooled$pars, name = 'trtB'), extract_analysis_result(pooled$pars, name = 'trtC')) }) diff --git a/tests/testthat/test-print.R b/tests/testthat/test-print.R index f661573ef..9c283418d 100644 --- a/tests/testthat/test-print.R +++ b/tests/testthat/test-print.R @@ -255,7 +255,8 @@ test_that("print - bmlmi", { ) ) res <- list( - trt = list( + analysis_result( + name = 'trt', est = fit$coefficients["groupTRT", "Estimate"], se = fit$coefficients["groupTRT", "Std. Error"], df = Inf diff --git a/tests/testthat/test-utilities.R b/tests/testthat/test-utilities.R index 75c953c07..bc04bbbdf 100644 --- a/tests/testthat/test-utilities.R +++ b/tests/testthat/test-utilities.R @@ -244,6 +244,9 @@ test_that("Stack", { test_that("add_meta", { + + skip_if_not(is_full_test()) + expect_equal(add_meta('a', 1), list(a=1)) expect_equal(add_meta(c('a','b','c'), '1','2',3), list(a='1', b='2',c=3)) expect_equal(add_meta(list('a'), 1), list(a=1)) @@ -256,6 +259,9 @@ test_that("add_meta", { test_that("assert_type", { + + skip_if_not(is_full_test()) + expect_true(assert_type('a', is.character)) expect_true(assert_type(c('a', 'b', 'c'), is.character)) expect_true(assert_type(1, is.numeric)) @@ -279,6 +285,9 @@ test_that("assert_type", { test_that("assert_value", { + + skip_if_not(is_full_test()) + expect_true(assert_value(max)(c(1,2,3), 3)) expect_true(assert_value(length)(list(1,2), 2)) expect_true(assert_value(names)(list(a=1,b=2,c=3), c('a', 'b', 'c'))) @@ -292,6 +301,9 @@ test_that("assert_value", { }) test_that("assert_anares_length", { + + skip_if_not(is_full_test()) + expect_true(assert_anares_length('a', 1)) expect_true(assert_anares_length(c(1,2), 2)) expect_true(assert_anares_length(list(a=1,b=2), 2)) @@ -306,6 +318,9 @@ test_that("assert_anares_length", { }) test_that("make_chain", { + + skip_if_not(is_full_test()) + is.numeric_or_na <- make_chain(any, is.numeric, is.na) expect_true(is.numeric_or_na(NA)) expect_true(is.numeric_or_na(1)) @@ -315,6 +330,9 @@ test_that("make_chain", { }) test_that("order_list_by_name", { + + skip_if_not(is_full_test()) + expect_equal(order_list_by_name(list(a=1,b='x',c=TRUE), c("c", "a", "d", "x", "b", "t"))[[3]], 'x') expect_true(names(order_list_by_name(list(t=1,v='x'), c("c", "a", "d", "x", "b", "t"))) == 't') expect_true(all(names(order_list_by_name(list(t=1,v='x',z=2,m=list(), q='t', w=data.frame()), c("z", "t","q", "m"))) == c("z", "t","q", "m"))) @@ -337,6 +355,9 @@ test_that("base_bind_rows", { }) test_that("namechecker", { + + skip_if_not(is_full_test()) + chker <- namechecker('a', 'b', 'c', optional = c('d', 'e', 'f')) expect_type(chker, "closure") expect_equal(chker('musthave'), c('a', 'b', 'c')) @@ -352,6 +373,9 @@ test_that("namechecker", { }) test_that("compose_n", { + + skip_if_not(is_full_test()) + # addition add_one <- function (x) x + 1 add_five <- compose_n(add_one, 5) @@ -371,6 +395,9 @@ test_that("compose_n", { }) test_that("back_apply_at", { + + skip_if_not(is_full_test()) + x <- list( a1=list( b11=list(c111=1, c112=2,c113=3), @@ -399,6 +426,9 @@ test_that("back_apply_at", { test_that("vec2form", { + + skip_if_not(is_full_test()) + x <- vec2form(c('a1', 'a2')) expect_equal(class(x), 'formula') expect_true(is.call(x[2])) @@ -407,6 +437,9 @@ test_that("vec2form", { ) test_that("reduce_df", { + + skip_if_not(is_full_test()) + x <- data.frame(a=1, b=c(1,2,3), c=5) # concatenate rows to vector From 0e146d3968a27ec59e0e297d71d0025851265f70 Mon Sep 17 00:00:00 2001 From: Guanya Peng Date: Fri, 9 Sep 2022 20:09:15 +0200 Subject: [PATCH 84/84] update delta fun --- DESCRIPTION | 2 +- R/analyse.R | 33 +++++++----- R/delta.R | 44 +++++++++++++--- R/utilities.R | 1 + man/Stack.Rd | 18 +++---- man/analyse.Rd | 21 ++++++-- man/ancova.Rd | 12 +++-- man/apply_delta.Rd | 13 ++++- man/as_analysis.Rd | 2 +- man/as_indices.Rd | 6 ++- man/as_mmrm_formula.Rd | 4 +- man/as_strata.Rd | 12 +++-- man/convert_to_imputation_list_df.Rd | 12 +++-- man/delta2df.Rd | 19 +++++++ man/delta_template.Rd | 24 ++++++--- man/expand.Rd | 6 ++- man/extract_imputed_df.Rd | 12 ++++- man/fit_mmrm_multiopt.Rd | 6 ++- man/get_mmrm_sample.Rd | 7 +-- man/invert_indexes.Rd | 12 +++-- man/longDataConstructor.Rd | 78 +++++++++++++++------------- man/make_poolable.Rd | 12 +++-- man/progressLogger.Rd | 24 ++++----- man/random_effects_expr.Rd | 12 +++-- man/scalerConstructor.Rd | 30 +++++------ man/simulate_test_data.Rd | 18 ++++--- man/split_dim.Rd | 12 +++-- man/split_imputations.Rd | 12 +++-- man/str_contains.Rd | 6 ++- man/strategies.Rd | 6 ++- man/transpose_imputations.Rd | 12 +++-- tests/testthat/test-delta.R | 42 +++++++++++---- 32 files changed, 348 insertions(+), 182 deletions(-) create mode 100644 man/delta2df.Rd diff --git a/DESCRIPTION b/DESCRIPTION index 94f1de347..11d0380c8 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -13,7 +13,7 @@ LazyData: true Roxygen: list(markdown = TRUE) URL: https://insightsengineering.github.io/rbmi/, https://github.com/insightsengineering/rbmi BugReports: https://github.com/insightsengineering/rbmi/issues -RoxygenNote: 7.1.2 +RoxygenNote: 7.2.0 Suggests: dplyr, covr, diff --git a/R/analyse.R b/R/analyse.R index 24b865674..4d26d31c0 100644 --- a/R/analyse.R +++ b/R/analyse.R @@ -90,7 +90,7 @@ #' #' @param imputations An `imputations` object as created by [impute()]. #' @param fun An analysis function to be applied to each imputed dataset. See details. -#' @param delta A `data.frame` containing the delta transformation to be applied to the imputed +#' @param delta A `data.frame` containing the delta transformation to be applied to the imputed, or a `function` to apply the delta transformation #' datasets prior to running `fun`. See details. #' @param ... Additional arguments passed onto `fun`. #' @examples @@ -119,6 +119,13 @@ #' delta = deltadf, #' vars = vars #' ) +#' +#' delta_fun <- function(df) mutate(df, out + 1) +#' analyse( +#' imputations = imputeObj, +#' delta = delta_fun, +#' vars = vars +#' ) #' } #' @export analyse <- function(imputations, fun = ancova, delta = NULL, ...) { @@ -131,15 +138,15 @@ analyse <- function(imputations, fun = ancova, delta = NULL, ...) { ) assert_that( - is.null(delta) | is.data.frame(delta), - msg = "`delta` must be NULL or a data.frame" + is.null(delta) | is.data.frame(delta) | is.function(delta), + msg = "`delta` must be NULL or a data.frame or a function" ) vars <- imputations$data$vars devnull <- lapply(imputations$imputations, function(x) validate(x)) - if (!is.null(delta)) { + if (is.data.frame(delta)) { expected_vars <- c( vars$subjid, vars$visit, @@ -239,12 +246,14 @@ extract_imputed_dfs <- function( #' #' @param imputation An imputation object as generated by [imputation_df()]. #' @param ld A `longdata` object as generated by [longDataConstructor()]. -#' @param delta Either `NULL` or a `data.frame`. Is used to offset outcome values in the imputed dataset. +#' @param delta Either `NULL` or a `data.frame` or `function`. Is used to offset outcome values in the imputed dataset. #' @param idmap Logical. If `TRUE` an attribute called "idmap" is attached to #' the return object which contains a `list` that maps the old subject ids #' the new subject ids. +#' @param oldvar character vector for dummy variable name to avoid collision. It should be same as the one used in [apply_delta()]. #' @returns A `data.frame`. -extract_imputed_df <- function(imputation, ld, delta = NULL, idmap = FALSE) { +extract_imputed_df <- function(imputation, ld, delta = NULL, idmap = FALSE, + oldvar = "old_subject_variable_zkfed1fgkadwni6g4oajd2aw") { vars <- ld$vars dat <- ld$get_data(imputation, idmap = TRUE) @@ -253,14 +262,14 @@ extract_imputed_df <- function(imputation, ld, delta = NULL, idmap = FALSE) { if (!is.null(delta)) { # We are injecting a variable into the dataset so are using a obscured variable # name to remove the chance of a clash - oldvar <- "old_subject_variable_zkfed1fgkadwni6g4oajd2aw" dat[[oldvar]] <- id_map[dat[[vars$subjid]]] - delta[[oldvar]] <- delta[[vars$subjid]] dat2 <- apply_delta( dat, - delta, + vars$subjid, + delta = delta, group = c(oldvar, vars$visit), - outcome = vars$outcome + outcome = vars$outcome, + oldvar = oldvar ) dat2[[oldvar]] <- NULL } else { @@ -289,7 +298,7 @@ extract_imputed_df <- function(imputation, ld, delta = NULL, idmap = FALSE) { #' @param results A list of lists contain the analysis results for each imputation #' See [analyse()] for details on what this object should look like. #' @param method The method object as specified in [draws()]. -#' @param delta The delta dataset used. See [analyse()] for details on how this +#' @param delta The delta dataset or function used. See [analyse()] for details on how this #' should be specified. #' @param fun The analysis function that was used. #' @param fun_name The character name of the analysis function (used for printing) @@ -390,7 +399,7 @@ validate.analysis <- function(x, ...) { assert_that( is.list(x$results), - is.null(x$delta) | is.data.frame(x$delta), + is.null(x$delta) | is.data.frame(x$delta) | is.function(x$delta), is.null(x$fun) | is.function(x$fun), is.null(x$fun_name) | is.character(x$fun_name) ) diff --git a/R/delta.R b/R/delta.R index 62fa4bca1..348a40495 100644 --- a/R/delta.R +++ b/R/delta.R @@ -285,11 +285,14 @@ d_lagscale <- function(delta, dlag, is_post_ice) { #' corresponding delta. #' #' @param data `data.frame` which will have its `outcome` column adjusted. +#' @param subjid character vector of subject id #' @param delta `data.frame` (must contain a column called `delta`). #' @param group character vector of variables in both `data` and `delta` that will be used #' to merge the 2 data.frames together by. #' @param outcome character, name of the outcome variable in `data`. -apply_delta <- function(data, delta = NULL, group = NULL, outcome = NULL) { +#' @param oldvar character vector for dummy variable name to avoid collision. It should be same as the one used in [extract_imputed_df()]. +apply_delta <- function(data, subjid, delta = NULL, group = NULL, outcome = NULL, + oldvar = "old_subject_variable_zkfed1fgkadwni6g4oajd2aw") { assert_that( is.character(group), @@ -301,22 +304,28 @@ apply_delta <- function(data, delta = NULL, group = NULL, outcome = NULL) { assert_that( is.data.frame(data), - is.data.frame(delta) | is.null(delta), + is.data.frame(delta) | is.null(delta) | is.function(delta), msg = "`dat` and `delta` must be data.frames" ) assert_that( - !"delta" %in% names(data), - msg = " `delta` is a reserved variable name should not be already defined in `data`" + !"delta" %in% names(data), + msg = " `delta` is a reserved variable name should not be already defined in `data`" ) if (is.null(delta)) { return(data) } - if (nrow(delta) == 0) { - return(data) + + delta_df <- delta2df(delta, data) + + + if (nrow(delta_df) == 0) { + return(data) } + delta_df[[oldvar]] <- delta_df[[subjid]] + for (var in c(group, outcome)) { assert_that( var %in% names(data), @@ -326,12 +335,12 @@ apply_delta <- function(data, delta = NULL, group = NULL, outcome = NULL) { for (var in c(group, "delta")) { assert_that( - var %in% names(delta), + var %in% names(delta_df), msg = sprintf("Variable `%s` is not in `delta`", var) ) } - delta_min <- delta[, c(group, "delta")] + delta_min <- delta_df[, c(group, "delta")] # We insert a variable in order to recover the original sort order of our `data.frame` # We use a obfuscated name in order to prevent variable overwriting @@ -366,3 +375,22 @@ apply_delta <- function(data, delta = NULL, group = NULL, outcome = NULL) { class(data3) <- class(data) return(data3) } + + +#' Dispatch on delta +#' +#' If delta is a data.frame, return delta. If delta is function apply it to the remaining arguments and return +#' +#' @param delta The delta object +#' @param ... Potential arguments for delta function +#' @return A delta data.frame +delta2df <- function(delta, ...) { + assert_that(is.data.frame(delta) | is.function(delta), + msg = '`delta` must be data.frame or function' + ) + if (is.data.frame(delta)) { + delta + } else { + delta(...) + } +} diff --git a/R/utilities.R b/R/utilities.R index 9540cab5d..1487290ca 100644 --- a/R/utilities.R +++ b/R/utilities.R @@ -756,3 +756,4 @@ reduce_df <- function(df, keys, split = FALSE) { aggregate(vec2form(keys, bothside = TRUE), data = df, FUN = concat, na.action=na.pass) ) } + diff --git a/man/Stack.Rd b/man/Stack.Rd index 4c4d0b43f..a569795d9 100644 --- a/man/Stack.Rd +++ b/man/Stack.Rd @@ -16,14 +16,14 @@ This is a simple stack object offering add / pop functionality \section{Methods}{ \subsection{Public methods}{ \itemize{ -\item \href{#method-add}{\code{Stack$add()}} -\item \href{#method-pop}{\code{Stack$pop()}} -\item \href{#method-clone}{\code{Stack$clone()}} +\item \href{#method-Stack-add}{\code{Stack$add()}} +\item \href{#method-Stack-pop}{\code{Stack$pop()}} +\item \href{#method-Stack-clone}{\code{Stack$clone()}} } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-add}{}}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Stack-add}{}}} \subsection{Method \code{add()}}{ Adds content to the end of the stack (must be a list) \subsection{Usage}{ @@ -39,8 +39,8 @@ Adds content to the end of the stack (must be a list) } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-pop}{}}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Stack-pop}{}}} \subsection{Method \code{pop()}}{ Retrieve content from the stack \subsection{Usage}{ @@ -57,8 +57,8 @@ items left on the stack it will just return everything that is left.} } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-clone}{}}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Stack-clone}{}}} \subsection{Method \code{clone()}}{ The objects of this class are cloneable with this method. \subsection{Usage}{ diff --git a/man/analyse.Rd b/man/analyse.Rd index 5836de470..adde18488 100644 --- a/man/analyse.Rd +++ b/man/analyse.Rd @@ -14,7 +14,7 @@ analyse(imputations, fun = ancova, delta = NULL, ...) \item{fun}{An analysis function to be applied to each imputed dataset. See details.} -\item{delta}{A \code{data.frame} containing the delta transformation to be applied to the imputed +\item{delta}{A \code{data.frame} containing the delta transformation to be applied to the imputed, or a \code{function} to apply the delta transformation datasets prior to running \code{fun}. See details.} \item{...}{Additional arguments passed onto \code{fun}.} @@ -42,7 +42,9 @@ via \code{...}. list containing a single numeric element called \code{est} (or additionally \code{se} and \code{df} if you had originally specified \code{\link[=method_bayes]{method_bayes()}} or \code{\link[=method_approxbayes]{method_approxbayes()}}) -i.e.:\preformatted{myfun <- function(dat, ...) \{ +i.e.: + +\if{html}{\out{
}}\preformatted{myfun <- function(dat, ...) \{ mod_1 <- lm(data = dat, outcome ~ group) mod_2 <- lm(data = dat, outcome ~ group + covar) x <- list( @@ -61,7 +63,7 @@ i.e.:\preformatted{myfun <- function(dat, ...) \{ ) return(x) \} -} +}\if{html}{\out{
}} Please note that the \code{vars$subjid} column (as defined in the original call to \code{\link[=draws]{draws()}}) will be scrambled in the data.frames that are provided to \code{fun}. @@ -84,8 +86,10 @@ This is typically used for sensitivity or tipping point analyses. The delta dataset must contain columns \code{vars$subjid}, \code{vars$visit} (as specified in the original call to \code{\link[=draws]{draws()}}) and \code{delta}. Essentially this \code{data.frame} is merged onto the imputed dataset by \code{vars$subjid} and \code{vars$visit} and then -the outcome variable is modified by:\preformatted{imputed_data[[vars$outcome]] <- imputed_data[[vars$outcome]] + imputed_data[["delta"]] -} +the outcome variable is modified by: + +\if{html}{\out{
}}\preformatted{imputed_data[[vars$outcome]] <- imputed_data[[vars$outcome]] + imputed_data[["delta"]] +}\if{html}{\out{
}} Please note that in order to provide maximum flexibility, the \code{delta} argument can be used to modify any/all outcome values including those that were not @@ -120,6 +124,13 @@ analyse( delta = deltadf, vars = vars ) + +delta_fun <- function(df) mutate(df, out + 1) +analyse( + imputations = imputeObj, + delta = delta_fun, + vars = vars +) } } \seealso{ diff --git a/man/ancova.Rd b/man/ancova.Rd index c1fa3843a..38f648b88 100644 --- a/man/ancova.Rd +++ b/man/ancova.Rd @@ -40,7 +40,9 @@ If no value for \code{visits} is provided then it will be set to \code{unique(data[[vars$visit]])}. Visits as part of the meta information of the \code{analysis_result} object from results of \code{\link[=analyse]{analyse()}} can be accessed individually and are -are displayed in a column from the \code{print.analysis} output such like\preformatted{ ===================================== +are displayed in a column from the \code{print.analysis} output such like + +\if{html}{\out{
}}\preformatted{ ===================================== name est se df visit ------------------------------------- trt -0.513 0.505 197 1 @@ -49,9 +51,11 @@ are displayed in a column from the \code{print.analysis} output such like\prefor lsm_alt 5.144 0.477 197 4 ------------------------------------- -} +}\if{html}{\out{
}} -Then list in analysis results has structure such as following. Each individual result is in class \code{analysis_result}\preformatted{list( +Then list in analysis results has structure such as following. Each individual result is in class \code{analysis_result} + +\if{html}{\out{
}}\preformatted{list( trt = analysis_result(name =, est = ..., meta = list(visit=1, ...)), lsm_ref = analysis_result(name =, est = ..., meta = list(visit=1, ...)), lsm_alt = analysis_result(name =, est = ..., meta = list(visit=1, ...)), @@ -60,7 +64,7 @@ Then list in analysis results has structure such as following. Each individual r lsm_alt = analysis_result(name =, est = ..., meta = list(visit=2, ...)), ... ) -} +}\if{html}{\out{
}} Please note that "ref" refers to the first factor level of \code{vars$group} which does not necessarily coincide with the control arm. Analogously, "alt" refers to the second factor level of \code{vars$group}. diff --git a/man/apply_delta.Rd b/man/apply_delta.Rd index 5700f837e..d983f3c7f 100644 --- a/man/apply_delta.Rd +++ b/man/apply_delta.Rd @@ -4,17 +4,28 @@ \alias{apply_delta} \title{Applies delta adjustment} \usage{ -apply_delta(data, delta = NULL, group = NULL, outcome = NULL) +apply_delta( + data, + subjid, + delta = NULL, + group = NULL, + outcome = NULL, + oldvar = "old_subject_variable_zkfed1fgkadwni6g4oajd2aw" +) } \arguments{ \item{data}{\code{data.frame} which will have its \code{outcome} column adjusted.} +\item{subjid}{character vector of subject id} + \item{delta}{\code{data.frame} (must contain a column called \code{delta}).} \item{group}{character vector of variables in both \code{data} and \code{delta} that will be used to merge the 2 data.frames together by.} \item{outcome}{character, name of the outcome variable in \code{data}.} + +\item{oldvar}{character vector for dummy variable name to avoid collision. It should be same as the one used in \code{\link[=extract_imputed_df]{extract_imputed_df()}}.} } \description{ Takes a delta dataset and adjusts the outcome variable by adding the diff --git a/man/as_analysis.Rd b/man/as_analysis.Rd index e98ca7aa0..1778b3d6f 100644 --- a/man/as_analysis.Rd +++ b/man/as_analysis.Rd @@ -12,7 +12,7 @@ See \code{\link[=analyse]{analyse()}} for details on what this object should loo \item{method}{The method object as specified in \code{\link[=draws]{draws()}}.} -\item{delta}{The delta dataset used. See \code{\link[=analyse]{analyse()}} for details on how this +\item{delta}{The delta dataset or function used. See \code{\link[=analyse]{analyse()}} for details on how this should be specified.} \item{fun}{The analysis function that was used.} diff --git a/man/as_indices.Rd b/man/as_indices.Rd index 14db1f02d..66e7510f0 100644 --- a/man/as_indices.Rd +++ b/man/as_indices.Rd @@ -15,6 +15,8 @@ Converts a string of 0's and 1's into index positions of the 1's padding the results by 0's so they are all the same length } \details{ -i.e.\preformatted{patmap(c("1101", "0001")) -> list(c(1,2,4,999), c(4,999, 999, 999)) -} +i.e. + +\if{html}{\out{
}}\preformatted{patmap(c("1101", "0001")) -> list(c(1,2,4,999), c(4,999, 999, 999)) +}\if{html}{\out{
}} } diff --git a/man/as_mmrm_formula.Rd b/man/as_mmrm_formula.Rd index 89c57aea5..237b49d63 100644 --- a/man/as_mmrm_formula.Rd +++ b/man/as_mmrm_formula.Rd @@ -17,6 +17,6 @@ Derives the MMRM model formula from the structure of mmrm_df. returns a formula object of the form: } \details{ -\preformatted{outcome ~ 0 + V1 + V2 + V4 + ... + us(0 + group1:visit | subjid) + us(0 + group2:visit | subjid) + ... -} +\if{html}{\out{
}}\preformatted{outcome ~ 0 + V1 + V2 + V4 + ... + us(0 + group1:visit | subjid) + us(0 + group2:visit | subjid) + ... +}\if{html}{\out{
}} } diff --git a/man/as_strata.Rd b/man/as_strata.Rd index 8f1c1dbf2..13de88349 100644 --- a/man/as_strata.Rd +++ b/man/as_strata.Rd @@ -11,11 +11,15 @@ as_strata(...) } \description{ Collapse multiple categorical variables into distinct unique categories. -e.g.\preformatted{as_strata(c(1,1,2,2,2,1), c(5,6,5,5,6,5)) -} +e.g. -would return\preformatted{c(1,2,3,3,4,1) -} +\if{html}{\out{
}}\preformatted{as_strata(c(1,1,2,2,2,1), c(5,6,5,5,6,5)) +}\if{html}{\out{
}} + +would return + +\if{html}{\out{
}}\preformatted{c(1,2,3,3,4,1) +}\if{html}{\out{
}} } \examples{ \dontrun{ diff --git a/man/convert_to_imputation_list_df.Rd b/man/convert_to_imputation_list_df.Rd index 3a1abd4a1..6f2bfc5ab 100644 --- a/man/convert_to_imputation_list_df.Rd +++ b/man/convert_to_imputation_list_df.Rd @@ -25,7 +25,9 @@ matrix varies for each subject and is equal to the number of times the patient w for imputation (for non-conditional mean methods this should be 1 per subject per imputed dataset). -This function is best illustrated by an example:\preformatted{imputes = list( +This function is best illustrated by an example: + +\if{html}{\out{
}}\preformatted{imputes = list( imputation_list_single( id = "Tom", imputations = matrix( @@ -46,9 +48,11 @@ sample_ids <- list( c("Tom", "Harry", "Tom"), c("Tom") ) -} +}\if{html}{\out{
}} -Then \code{convert_to_imputation_df(imputes, sample_ids)} would result in:\preformatted{imputation_list_df( +Then \code{convert_to_imputation_df(imputes, sample_ids)} would result in: + +\if{html}{\out{
}}\preformatted{imputation_list_df( imputation_df( imputation_single_t_1_1, imputation_single_h_1_1, @@ -66,7 +70,7 @@ Then \code{convert_to_imputation_df(imputes, sample_ids)} would result in:\prefo imputation_single_t_3_2 ) ) -} +}\if{html}{\out{
}} Note that the different repetitions (i.e. the value set for D) are grouped together sequentially.} diff --git a/man/delta2df.Rd b/man/delta2df.Rd new file mode 100644 index 000000000..4bda7b6d7 --- /dev/null +++ b/man/delta2df.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/delta.R +\name{delta2df} +\alias{delta2df} +\title{Dispatch on delta} +\usage{ +delta2df(delta, ...) +} +\arguments{ +\item{delta}{The delta object} + +\item{...}{Potential arguments for delta function} +} +\value{ +A delta data.frame +} +\description{ +If delta is a data.frame, return delta. If delta is function apply it to the remaining arguments and return +} diff --git a/man/delta_template.Rd b/man/delta_template.Rd index bb121e321..0200ba45d 100644 --- a/man/delta_template.Rd +++ b/man/delta_template.Rd @@ -44,7 +44,9 @@ This is best illustrated with an example: Let \code{delta = c(5,6,7,8)} and \code{dlag=c(1,2,3,4)} (i.e. assuming there are 4 visits) and lets say that the subject had an ICE on visit 2. The calculation would then be -as follows:\preformatted{v1 v2 v3 v4 +as follows: + +\if{html}{\out{
}}\preformatted{v1 v2 v3 v4 -------------- 5 6 7 8 # delta assigned to each visit 0 1 2 3 # lagged scaling starting from the first visit after the subjects ICE @@ -52,11 +54,13 @@ as follows:\preformatted{v1 v2 v3 v4 0 6 14 24 # delta * lagged scaling -------------- 0 6 20 44 # accumulative sum of delta to be applied to each visit -} +}\if{html}{\out{
}} That is to say the subject would have a delta offset of 0 applied for visit-1, 6 for visit-2, 20 for visit-3 and 44 for visit-4. As a comparison, lets say that the -subject instead had their ICE on visit 3, the calculation would then be as follows:\preformatted{v1 v2 v3 v4 +subject instead had their ICE on visit 3, the calculation would then be as follows: + +\if{html}{\out{
}}\preformatted{v1 v2 v3 v4 -------------- 5 6 7 8 # delta assigned to each visit 0 0 1 2 # lagged scaling starting from the first visit after the subjects ICE @@ -64,12 +68,14 @@ subject instead had their ICE on visit 3, the calculation would then be as follo 0 0 7 16 # delta * lagged scaling -------------- 0 0 7 23 # accumulative sum of delta to be applied to each visit -} +}\if{html}{\out{
}} In terms of practical usage, lets say that you wanted a delta of 5 to be used for all post ICE visits regardless of their proximity to the ICE visit. This can be achieved by setting \code{delta = c(5,5,5,5)} and \code{dlag = c(1,0,0,0)}. For example lets say a subject had their -ICE on visit-1, then the calculation would be as follows:\preformatted{v1 v2 v3 v4 +ICE on visit-1, then the calculation would be as follows: + +\if{html}{\out{
}}\preformatted{v1 v2 v3 v4 -------------- 5 5 5 5 # delta assigned to each visit 1 0 0 0 # lagged scaling starting from the first visit after the subjects ICE @@ -77,7 +83,7 @@ ICE on visit-1, then the calculation would be as follows:\preformatted{v1 v2 v 5 0 0 0 # delta * lagged scaling -------------- 5 5 5 5 # accumulative sum of delta to be applied to each visit -} +}\if{html}{\out{
}} Another way of using these arguments is to set \code{delta} to be the difference in time between visits and \code{dlag} to be the @@ -85,7 +91,9 @@ amount of delta per unit of time. For example lets say that we have a visit on w 1, 5, 6 & 9 and that we want a delta of 3 to be applied for each week after an ICE. This can be achieved by setting \code{delta = c(0,4,1,3)} (the difference in weeks between each visit) and \code{dlag = c(3, 3, 3, 3)}. For example lets say we have a subject who had their ICE on week-5 -(i.e. visit-2) then the calculation would be:\preformatted{v1 v2 v3 v4 +(i.e. visit-2) then the calculation would be: + +\if{html}{\out{
}}\preformatted{v1 v2 v3 v4 -------------- 0 4 1 3 # delta assigned to each visit 0 0 3 3 # lagged scaling starting from the first visit after the subjects ICE @@ -93,7 +101,7 @@ and \code{dlag = c(3, 3, 3, 3)}. For example lets say we have a subject who had 0 0 3 9 # delta * lagged scaling -------------- 0 0 3 12 # accumulative sum of delta to be applied to each visit -} +}\if{html}{\out{
}} i.e. on week-6 (1 week after the ICE) they have a delta of 3 and on week-9 (4 weeks after the ICE) they have a delta of 12. diff --git a/man/expand.Rd b/man/expand.Rd index 6836768e8..e80a1e5e2 100644 --- a/man/expand.Rd +++ b/man/expand.Rd @@ -58,7 +58,9 @@ These values are deliberately not imputed as doing so risks silent errors in the varying covariates. One solution is to first use \code{expand_locf()} on just the visit variable and time varying covariates and then merge on the baseline covariates -afterwards i.e.\preformatted{library(dplyr) +afterwards i.e. + +\if{html}{\out{
}}\preformatted{library(dplyr) dat_expanded <- expand( data = dat, @@ -68,7 +70,7 @@ dat_expanded <- expand( dat_filled <- dat_expanded \%>\% left_join(baseline_covariates, by = "subject") -} +}\if{html}{\out{
}} } } \examples{ diff --git a/man/extract_imputed_df.Rd b/man/extract_imputed_df.Rd index 9781828d1..4b52273aa 100644 --- a/man/extract_imputed_df.Rd +++ b/man/extract_imputed_df.Rd @@ -4,18 +4,26 @@ \alias{extract_imputed_df} \title{Extract imputed dataset} \usage{ -extract_imputed_df(imputation, ld, delta = NULL, idmap = FALSE) +extract_imputed_df( + imputation, + ld, + delta = NULL, + idmap = FALSE, + oldvar = "old_subject_variable_zkfed1fgkadwni6g4oajd2aw" +) } \arguments{ \item{imputation}{An imputation object as generated by \code{\link[=imputation_df]{imputation_df()}}.} \item{ld}{A \code{longdata} object as generated by \code{\link[=longDataConstructor]{longDataConstructor()}}.} -\item{delta}{Either \code{NULL} or a \code{data.frame}. Is used to offset outcome values in the imputed dataset.} +\item{delta}{Either \code{NULL} or a \code{data.frame} or \code{function}. Is used to offset outcome values in the imputed dataset.} \item{idmap}{Logical. If \code{TRUE} an attribute called "idmap" is attached to the return object which contains a \code{list} that maps the old subject ids the new subject ids.} + +\item{oldvar}{character vector for dummy variable name to avoid collision. It should be same as the one used in \code{\link[=apply_delta]{apply_delta()}}.} } \value{ A \code{data.frame}. diff --git a/man/fit_mmrm_multiopt.Rd b/man/fit_mmrm_multiopt.Rd index 41ebd98c7..72d929fc7 100644 --- a/man/fit_mmrm_multiopt.Rd +++ b/man/fit_mmrm_multiopt.Rd @@ -21,14 +21,16 @@ try again. If \code{optimizer} is a list then the names of the list will be taken to be the required \code{optimizer} with the contents of that element being used as the initial values. This functionality can be used to try and fit the model using the same optimizer at multiple different starting -values e.g.:\preformatted{fit_mmrm_multiopt( +values e.g.: + +\if{html}{\out{
}}\preformatted{fit_mmrm_multiopt( ..., optimizer = list( "L-BFGS-B" = list(beta = c(1,2,3), theta = c(9,8,7)), "L-BFGS-B" = list(beta = c(5,6,7), theta = c(10,11,12)), ) ) -} +}\if{html}{\out{
}} See \code{\link[stats:optim]{stats::optim()}} for a list of the available optimizers that can be used } diff --git a/man/get_mmrm_sample.Rd b/man/get_mmrm_sample.Rd index 6cd70c3b2..5a8a80624 100644 --- a/man/get_mmrm_sample.Rd +++ b/man/get_mmrm_sample.Rd @@ -16,12 +16,7 @@ get_mmrm_sample(ids, longdata, method, optimizer) \item{optimizer}{vector of characters defining the optimizer to be used. Every optimizer must be one of the \code{\link[stats:optim]{stats::optim()}} function. The list of possible -optimizers are Nelder-Mead, -BFGS, -CG, -L-BFGS-B, -SANN, -Brent,.} +optimizers are Nelder-Mead,, BFGS,, CG,, L-BFGS-B,, SANN,, Brent,.} } \value{ A named list of class \code{sample_single}. It contains the following: diff --git a/man/invert_indexes.Rd b/man/invert_indexes.Rd index f627b690f..1be0fb009 100644 --- a/man/invert_indexes.Rd +++ b/man/invert_indexes.Rd @@ -17,9 +17,13 @@ the indexes of which original elements it occurred in. \details{ This functions purpose is best illustrated by an example: -input:\preformatted{list( c("A", "B", "C"), c("A", "A", "B"))\} -} +input: -becomes:\preformatted{list( "A" = c(1,2,2), "B" = c(1,2), "C" = 1 ) -} +\if{html}{\out{
}}\preformatted{list( c("A", "B", "C"), c("A", "A", "B"))\} +}\if{html}{\out{
}} + +becomes: + +\if{html}{\out{
}}\preformatted{list( "A" = c(1,2,2), "B" = c(1,2), "C" = 1 ) +}\if{html}{\out{
}} } diff --git a/man/longDataConstructor.Rd b/man/longDataConstructor.Rd index f8cc67957..fb0d90898 100644 --- a/man/longDataConstructor.Rd +++ b/man/longDataConstructor.Rd @@ -80,9 +80,11 @@ original dataset belong to this subject i.e. to recover the full data for subject "pt3" you can use \code{self$data[self$indexes[["pt3"]],]}. This may seem redundant over filtering the data directly -however it enables efficient bootstrap sampling of the data i.e.\preformatted{indexes <- unlist(self$indexes[c("pt3", "pt3")]) +however it enables efficient bootstrap sampling of the data i.e. + +\if{html}{\out{
}}\preformatted{indexes <- unlist(self$indexes[c("pt3", "pt3")]) self$data[indexes,] -} +}\if{html}{\out{
}} This list is populated during the object initialisation.} @@ -102,22 +104,22 @@ for all observations. This list is populated by a call to \code{self$set_strateg \section{Methods}{ \subsection{Public methods}{ \itemize{ -\item \href{#method-get_data}{\code{longDataConstructor$get_data()}} -\item \href{#method-add_subject}{\code{longDataConstructor$add_subject()}} -\item \href{#method-validate_ids}{\code{longDataConstructor$validate_ids()}} -\item \href{#method-sample_ids}{\code{longDataConstructor$sample_ids()}} -\item \href{#method-extract_by_id}{\code{longDataConstructor$extract_by_id()}} -\item \href{#method-update_strategies}{\code{longDataConstructor$update_strategies()}} -\item \href{#method-set_strategies}{\code{longDataConstructor$set_strategies()}} -\item \href{#method-check_has_data_at_each_visit}{\code{longDataConstructor$check_has_data_at_each_visit()}} -\item \href{#method-set_strata}{\code{longDataConstructor$set_strata()}} -\item \href{#method-new}{\code{longDataConstructor$new()}} -\item \href{#method-clone}{\code{longDataConstructor$clone()}} +\item \href{#method-longdata-get_data}{\code{longDataConstructor$get_data()}} +\item \href{#method-longdata-add_subject}{\code{longDataConstructor$add_subject()}} +\item \href{#method-longdata-validate_ids}{\code{longDataConstructor$validate_ids()}} +\item \href{#method-longdata-sample_ids}{\code{longDataConstructor$sample_ids()}} +\item \href{#method-longdata-extract_by_id}{\code{longDataConstructor$extract_by_id()}} +\item \href{#method-longdata-update_strategies}{\code{longDataConstructor$update_strategies()}} +\item \href{#method-longdata-set_strategies}{\code{longDataConstructor$set_strategies()}} +\item \href{#method-longdata-check_has_data_at_each_visit}{\code{longDataConstructor$check_has_data_at_each_visit()}} +\item \href{#method-longdata-set_strata}{\code{longDataConstructor$set_strata()}} +\item \href{#method-longdata-new}{\code{longDataConstructor$new()}} +\item \href{#method-longdata-clone}{\code{longDataConstructor$clone()}} } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-get_data}{}}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-longdata-get_data}{}}} \subsection{Method \code{get_data()}}{ Returns a \code{data.frame} based upon required subject IDs. Replaces missing values with new ones if provided. @@ -156,13 +158,15 @@ returned multiple times. If \code{obj} is an \code{imputation_df} object (as created by \code{\link[=imputation_df]{imputation_df()}}) then the subject ids specified in the object will be returned and missing values will be filled -in by those specified in the imputation list object. i.e.\preformatted{obj <- imputation_df( +in by those specified in the imputation list object. i.e. + +\if{html}{\out{
}}\preformatted{obj <- imputation_df( imputation_single( id = "pt1", values = c(1,2,3)), imputation_single( id = "pt1", values = c(4,5,6)), imputation_single( id = "pt3", values = c(7,8)) ) longdata$get_data(obj) -} +}\if{html}{\out{
}} Will return a \code{data.frame} consisting of all observations for \code{pt1} twice and all of the observations for \code{pt3} once. The first set of observations for \code{pt1} will have missing @@ -181,8 +185,8 @@ A \code{data.frame}. } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-add_subject}{}}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-longdata-add_subject}{}}} \subsection{Method \code{add_subject()}}{ This function decomposes a patient data from \code{self$data} and populates all the corresponding lists i.e. \code{self$is_missing}, \code{self$values}, \code{self$group}, etc. @@ -200,8 +204,8 @@ This function is only called upon the objects initialization. } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-validate_ids}{}}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-longdata-validate_ids}{}}} \subsection{Method \code{validate_ids()}}{ Throws an error if any element of \code{ids} is not within the source data \code{self$data}. \subsection{Usage}{ @@ -220,8 +224,8 @@ TRUE } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-sample_ids}{}}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-longdata-sample_ids}{}}} \subsection{Method \code{sample_ids()}}{ Performs random stratified sampling of patient ids (with replacement) Each patient has an equal weight of being picked within their strata (i.e is not dependent on @@ -235,8 +239,8 @@ Character vector of ids. } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-extract_by_id}{}}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-longdata-extract_by_id}{}}} \subsection{Method \code{extract_by_id()}}{ Returns a list of key information for a given subject. Is a convenience wrapper to save having to manually grab each element. @@ -253,8 +257,8 @@ to save having to manually grab each element. } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-update_strategies}{}}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-longdata-update_strategies}{}}} \subsection{Method \code{update_strategies()}}{ Convenience function to run self$set_strategies(dat_ice, update=TRUE) kept for legacy reasons. @@ -271,8 +275,8 @@ kept for legacy reasons. } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-set_strategies}{}}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-longdata-set_strategies}{}}} \subsection{Method \code{set_strategies()}}{ Updates the \code{self$strategies}, \code{self$is_mar}, \code{self$is_post_ice} variables based upon the provided ICE information. @@ -298,8 +302,8 @@ of post-ICE observations. } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-check_has_data_at_each_visit}{}}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-longdata-check_has_data_at_each_visit}{}}} \subsection{Method \code{check_has_data_at_each_visit()}}{ Ensures that all visits have at least 1 observed "MAR" observation. Throws an error if this criteria is not met. This is to ensure that the initial @@ -310,8 +314,8 @@ MMRM can be resolved. } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-set_strata}{}}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-longdata-set_strata}{}}} \subsection{Method \code{set_strata()}}{ Populates the \code{self$strata} variable. If the user has specified stratification variables The first visit is used to determine the value of those variables. If no stratification variables @@ -322,8 +326,8 @@ have been specified then everyone is defined as being in strata 1. } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-new}{}}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-longdata-new}{}}} \subsection{Method \code{new()}}{ Constructor function. \subsection{Usage}{ @@ -341,8 +345,8 @@ Constructor function. } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-clone}{}}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-longdata-clone}{}}} \subsection{Method \code{clone()}}{ The objects of this class are cloneable with this method. \subsection{Usage}{ diff --git a/man/make_poolable.Rd b/man/make_poolable.Rd index ee1225104..2ef23fe61 100644 --- a/man/make_poolable.Rd +++ b/man/make_poolable.Rd @@ -17,7 +17,9 @@ Covert Results object (as created by \code{\link[=analyse]{analyse()}}) in order the same estimates together into vectors. The return object is in poolable class containing the results, meta information and the key names for the mata information } \details{ -The format of analysis results are converted from:\preformatted{x <- list( +The format of analysis results are converted from: + +\if{html}{\out{
}}\preformatted{x <- list( list( analysis_result( name = 'trt', @@ -47,10 +49,12 @@ The format of analysis results are converted from:\preformatted{x <- list( ) ) ) -} +}\if{html}{\out{
}} to the following format and stored in the \verb{$results} element of the poolable object. The element \verb{$meta} contains meta information. -The element \verb{$metakeys} contains the names of the meta information as a character vector\preformatted{list( +The element \verb{$metakeys} contains the names of the meta information as a character vector + +\if{html}{\out{
}}\preformatted{list( trt.1 = data.frame( list( name = 'trt', @@ -68,5 +72,5 @@ The element \verb{$metakeys} contains the names of the meta information as a cha ) ) ) -} +}\if{html}{\out{
}} } diff --git a/man/progressLogger.Rd b/man/progressLogger.Rd index 1c51dbbc9..584eefcc5 100644 --- a/man/progressLogger.Rd +++ b/man/progressLogger.Rd @@ -31,15 +31,15 @@ acts as the denominator for calculating progress percentages} \section{Methods}{ \subsection{Public methods}{ \itemize{ -\item \href{#method-new}{\code{progressLogger$new()}} -\item \href{#method-add}{\code{progressLogger$add()}} -\item \href{#method-print_progress}{\code{progressLogger$print_progress()}} -\item \href{#method-clone}{\code{progressLogger$clone()}} +\item \href{#method-progressLogger-new}{\code{progressLogger$new()}} +\item \href{#method-progressLogger-add}{\code{progressLogger$add()}} +\item \href{#method-progressLogger-print_progress}{\code{progressLogger$print_progress()}} +\item \href{#method-progressLogger-clone}{\code{progressLogger$clone()}} } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-new}{}}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-progressLogger-new}{}}} \subsection{Method \code{new()}}{ Create progressLogger object \subsection{Usage}{ @@ -59,8 +59,8 @@ Create progressLogger object } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-add}{}}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-progressLogger-add}{}}} \subsection{Method \code{add()}}{ Records that \code{n} more iterations have been completed this will add that number to the current step count (\code{step_current}) and will @@ -79,8 +79,8 @@ This function will do nothing if \code{quiet} has been set to \code{TRUE} } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-print_progress}{}}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-progressLogger-print_progress}{}}} \subsection{Method \code{print_progress()}}{ method to print the current state of progress \subsection{Usage}{ @@ -89,8 +89,8 @@ method to print the current state of progress } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-clone}{}}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-progressLogger-clone}{}}} \subsection{Method \code{clone()}}{ The objects of this class are cloneable with this method. \subsection{Usage}{ diff --git a/man/random_effects_expr.Rd b/man/random_effects_expr.Rd index b9ce6d849..0f0c2fc85 100644 --- a/man/random_effects_expr.Rd +++ b/man/random_effects_expr.Rd @@ -18,10 +18,14 @@ for fitting a MMRM for subject by visit in the format required for glmmTMB. } \details{ For example assuming the user specified a covariance structure of "us" and that no groups -were provided this will return\preformatted{us(0 + visit | subjid) -} +were provided this will return + +\if{html}{\out{
}}\preformatted{us(0 + visit | subjid) +}\if{html}{\out{
}} If \code{group} is provided then this indicates that separate covariance matrices -are required per group and as such the following will be returned:\preformatted{us( 0 + group1:visit | subjid) + us(0 + group2:visit | subjid) + ... -} +are required per group and as such the following will be returned: + +\if{html}{\out{
}}\preformatted{us( 0 + group1:visit | subjid) + us(0 + group2:visit | subjid) + ... +}\if{html}{\out{
}} } diff --git a/man/scalerConstructor.Rd b/man/scalerConstructor.Rd index 67454c18b..e896a76e7 100644 --- a/man/scalerConstructor.Rd +++ b/man/scalerConstructor.Rd @@ -32,16 +32,16 @@ variable, all other variables are the predictors.} \section{Methods}{ \subsection{Public methods}{ \itemize{ -\item \href{#method-new}{\code{scalerConstructor$new()}} -\item \href{#method-scale}{\code{scalerConstructor$scale()}} -\item \href{#method-unscale_sigma}{\code{scalerConstructor$unscale_sigma()}} -\item \href{#method-unscale_beta}{\code{scalerConstructor$unscale_beta()}} -\item \href{#method-clone}{\code{scalerConstructor$clone()}} +\item \href{#method-scaler-new}{\code{scalerConstructor$new()}} +\item \href{#method-scaler-scale}{\code{scalerConstructor$scale()}} +\item \href{#method-scaler-unscale_sigma}{\code{scalerConstructor$unscale_sigma()}} +\item \href{#method-scaler-unscale_beta}{\code{scalerConstructor$unscale_beta()}} +\item \href{#method-scaler-clone}{\code{scalerConstructor$clone()}} } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-new}{}}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-scaler-new}{}}} \subsection{Method \code{new()}}{ Uses \code{dat} to determine the relevant column means and standard deviations to use when scaling and un-scaling future datasets. Implicitly assumes that new datasets @@ -66,8 +66,8 @@ to \code{0} and scale to \code{1}. } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-scale}{}}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-scaler-scale}{}}} \subsection{Method \code{scale()}}{ Scales a dataset so that all continuous variables have a mean of 0 and a standard deviation of 1. @@ -86,8 +86,8 @@ order as the dataset used in the initialization function.} } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-unscale_sigma}{}}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-scaler-unscale_sigma}{}}} \subsection{Method \code{unscale_sigma()}}{ Unscales a sigma value (or matrix) as estimated by a linear model using a design matrix scaled by this object. This function only @@ -109,8 +109,8 @@ A numeric value or matrix } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-unscale_beta}{}}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-scaler-unscale_beta}{}}} \subsection{Method \code{unscale_beta()}}{ Unscales a beta value (or vector) as estimated by a linear model using a design matrix scaled by this object. This function only @@ -132,8 +132,8 @@ A numeric vector. } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-clone}{}}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-scaler-clone}{}}} \subsection{Method \code{clone()}}{ The objects of this class are cloneable with this method. \subsection{Usage}{ diff --git a/man/simulate_test_data.Rd b/man/simulate_test_data.Rd index 01e85c65b..1b5bef203 100644 --- a/man/simulate_test_data.Rd +++ b/man/simulate_test_data.Rd @@ -45,8 +45,10 @@ The covariates in the simulated dataset are produced as follows: for details } -The mean for the outcome variable is derived as:\preformatted{outcome = Intercept + age + sex + visit + treatment -} +The mean for the outcome variable is derived as: + +\if{html}{\out{
}}\preformatted{outcome = Intercept + age + sex + visit + treatment +}\if{html}{\out{
}} The coefficients for the intercept, age and sex are taken from \code{mu$int}, \code{mu$age} and \code{mu$sex} respectively, all of which must be a length 1 numeric. @@ -54,13 +56,17 @@ The coefficients for the intercept, age and sex are taken from \code{mu$int}, Treatment and visit coefficients are taken from \code{mu$trt} and \code{mu$visit} respectively and must either be of length 1 (i.e. a constant affect across all visits) or equal to the number of visits (as determined by the length of \code{sd}). I.e. if you wanted a treatment -slope of 5 and a visit slope of 1 you could specify:\preformatted{mu = list(..., "trt" = c(0,5,10), "visit" = c(0,1,2)) -} +slope of 5 and a visit slope of 1 you could specify: + +\if{html}{\out{
}}\preformatted{mu = list(..., "trt" = c(0,5,10), "visit" = c(0,1,2)) +}\if{html}{\out{
}} The correlation matrix is constructed from \code{cor} as follows. -Let \code{cor = c(a, b, c, d, e, f)} then the correlation matrix would be:\preformatted{1 a b d +Let \code{cor = c(a, b, c, d, e, f)} then the correlation matrix would be: + +\if{html}{\out{
}}\preformatted{1 a b d a 1 c e b c 1 f d e f 1 -} +}\if{html}{\out{
}} } diff --git a/man/split_dim.Rd b/man/split_dim.Rd index 04c8feee8..3caecad22 100644 --- a/man/split_dim.Rd +++ b/man/split_dim.Rd @@ -29,21 +29,25 @@ Example: inputs: \code{a <- array( c(1,2,3,4,5,6,7,8,9,10,11,12), dim = c(3,2,2))}, -which means that:\preformatted{a[1,,] a[2,,] a[3,,] +which means that: + +\if{html}{\out{
}}\preformatted{a[1,,] a[2,,] a[3,,] [,1] [,2] [,1] [,2] [,1] [,2] --------- --------- --------- 1 7 2 8 3 9 4 10 5 11 6 12 -} +}\if{html}{\out{
}} \code{n <- 1} -output of \code{res <- split_dim(a,n)} is a list of 3 elements:\preformatted{res[[1]] res[[2]] res[[3]] +output of \code{res <- split_dim(a,n)} is a list of 3 elements: + +\if{html}{\out{
}}\preformatted{res[[1]] res[[2]] res[[3]] [,1] [,2] [,1] [,2] [,1] [,2] --------- --------- --------- 1 7 2 8 3 9 4 10 5 11 6 12 -} +}\if{html}{\out{
}} } diff --git a/man/split_imputations.Rd b/man/split_imputations.Rd index ba1338552..f12815ff2 100644 --- a/man/split_imputations.Rd +++ b/man/split_imputations.Rd @@ -19,7 +19,9 @@ Split a flat list of \code{\link[=imputation_single]{imputation_single()}} into } \details{ This function converts a list of imputations from being structured per patient -to being structured per sample i.e. it converts\preformatted{obj <- list( +to being structured per sample i.e. it converts + +\if{html}{\out{
}}\preformatted{obj <- list( imputation_single("Ben", numeric(0)), imputation_single("Ben", numeric(0)), imputation_single("Ben", numeric(0)), @@ -33,9 +35,11 @@ index <- list( c("Ben", "Harry", "Phil", "Tom"), c("Ben", "Ben", "Phil") ) -} +}\if{html}{\out{
}} -Into:\preformatted{output <- list( +Into: + +\if{html}{\out{
}}\preformatted{output <- list( imputation_df( imputation_single(id = "Ben", values = numeric(0)), imputation_single(id = "Harry", values = c(1, 2)), @@ -48,5 +52,5 @@ Into:\preformatted{output <- list( imputation_single(id = "Phil", values = c(5, 6)) ) ) -} +}\if{html}{\out{
}} } diff --git a/man/str_contains.Rd b/man/str_contains.Rd index e33804430..e7aae207b 100644 --- a/man/str_contains.Rd +++ b/man/str_contains.Rd @@ -15,7 +15,9 @@ str_contains(x, subs) Returns a vector of \code{TRUE}/\code{FALSE} for each element of x if it contains any element in \code{subs} -i.e.\preformatted{str_contains( c("ben", "tom", "harry"), c("e", "y")) +i.e. + +\if{html}{\out{
}}\preformatted{str_contains( c("ben", "tom", "harry"), c("e", "y")) [1] TRUE FALSE TRUE -} +}\if{html}{\out{
}} } diff --git a/man/strategies.Rd b/man/strategies.Rd index 8c3e2cd27..26d365ffa 100644 --- a/man/strategies.Rd +++ b/man/strategies.Rd @@ -37,11 +37,13 @@ the Missing-at-Random (MAR) assumption. \details{ \code{pars_group} and \code{pars_ref} both must be a list containing elements \code{mu} and \code{sigma}. \code{mu} must be a numeric vector and \code{sigma} must be a square matrix symmetric covariance -matrix with dimensions equal to the length of \code{mu} and \code{index_mar}. e.g.\preformatted{list( +matrix with dimensions equal to the length of \code{mu} and \code{index_mar}. e.g. + +\if{html}{\out{
}}\preformatted{list( mu = c(1,2,3), sigma = matrix(c(4,3,2,3,5,4,2,4,6), nrow = 3, ncol = 3) ) -} +}\if{html}{\out{
}} Users can define their own strategy functions and include them via the \code{strategies} argument to \code{\link[=impute]{impute()}} using \code{\link[=getStrategies]{getStrategies()}}. That being said the following diff --git a/man/transpose_imputations.Rd b/man/transpose_imputations.Rd index aa4fae6c3..3a291fce6 100644 --- a/man/transpose_imputations.Rd +++ b/man/transpose_imputations.Rd @@ -10,17 +10,21 @@ transpose_imputations(imputations) \item{imputations}{An \code{imputation_df} object created by \code{\link[=imputation_df]{imputation_df()}}} } \description{ -Takes an \code{imputation_df} object and transposes it e.g.\preformatted{list( +Takes an \code{imputation_df} object and transposes it e.g. + +\if{html}{\out{
}}\preformatted{list( list(id = "a", values = c(1,2,3)), list(id = "b", values = c(4,5,6) ) ) -} +}\if{html}{\out{
}} } \details{ -becomes\preformatted{list( +becomes + +\if{html}{\out{
}}\preformatted{list( ids = c("a", "b"), values = c(1,2,3,4,5,6) ) -} +}\if{html}{\out{
}} } diff --git a/tests/testthat/test-delta.R b/tests/testthat/test-delta.R index 17bbb5902..97715df5b 100644 --- a/tests/testthat/test-delta.R +++ b/tests/testthat/test-delta.R @@ -150,11 +150,11 @@ test_that("apply_delta", { v2 = c(1, 2, 3), id = c("c", "b", "a") ) - output_actual <- apply_delta(d1, group = "id", outcome = "out") + output_actual <- apply_delta(d1, "a", group = "id", outcome = "out") expect_equal(d1, output_actual) delta <- tibble() - output_actual <- apply_delta(d1, delta, group = "id", outcome = "out") + output_actual <- apply_delta(d1, "a", delta, group = "id", outcome = "out") expect_equal(d1, output_actual) @@ -165,7 +165,7 @@ test_that("apply_delta", { ) output_expected <- d1 output_expected$out <- c(1, 3, 5) - output_actual <- apply_delta(d1, delta, group = "id", outcome = "out") + output_actual <- apply_delta(d1, "a", delta, group = "id", outcome = "out") expect_equal(output_expected, output_actual, ignore_attr = TRUE) @@ -177,7 +177,7 @@ test_that("apply_delta", { ) output_expected <- d1 output_expected$out <- c(1, 3, 3) - output_actual <- apply_delta(d1, delta, group = c("id", "v1"), outcome = "out") + output_actual <- apply_delta(d1, "a", delta, group = c("id", "v1"), outcome = "out") expect_equal(output_expected, output_actual, ignore_attr = TRUE) @@ -194,10 +194,10 @@ test_that("apply_delta", { ) output_expected <- d1 output_expected$out <- c(1, 3, 5, 5) - output_actual <- apply_delta(d1, delta, group = c("id"), outcome = "out") + output_actual <- apply_delta(d1, "a", delta, group = c("id"), outcome = "out") expect_equal(output_expected, output_actual, ignore_attr = TRUE) expect_error( - apply_delta(d1, delta, group = c("id", "v1"), outcome = "out"), + apply_delta(d1, "a", delta, group = c("id", "v1"), outcome = "out"), regexp = "`v1` is not in `delta`" ) @@ -208,7 +208,7 @@ test_that("apply_delta", { ) output_expected <- d1 output_expected$out <- c(1, 3, 3, 4) - output_actual <- apply_delta(d1, delta, group = c("id", "v1"), outcome = "out") + output_actual <- apply_delta(d1, "a", delta, group = c("id", "v1"), outcome = "out") expect_equal(output_expected, output_actual, ignore_attr = TRUE) delta <- tibble( @@ -218,7 +218,7 @@ test_that("apply_delta", { ) output_expected <- d1 output_expected$out <- c(1, 11, 3, 5) - output_actual <- apply_delta(d1, delta, group = c("id", "v1"), outcome = "out") + output_actual <- apply_delta(d1, "a", delta, group = c("id", "v1"), outcome = "out") expect_equal(output_expected, output_actual, ignore_attr = TRUE) @@ -228,7 +228,7 @@ test_that("apply_delta", { delta = c(1, 2, 3, 4) ) expect_error( - apply_delta(d1, delta, group = "id", outcome = "out"), + apply_delta(d1, "a", delta, group = "id", outcome = "out"), "whilst applying delta" ) }) @@ -258,9 +258,9 @@ test_that("extract_imputed_dfs + delta", { ) dobj <- draws( - dat, + dat, dat_ice, - vars = vars, + vars = vars, method = method_approxbayes(n_samples = 5), quiet = TRUE ) @@ -286,3 +286,23 @@ test_that("extract_imputed_dfs + delta", { }) +test_that('delta2df', { + delta <- tibble( + id = c("b", "a", "d"), + v1 = c(1, 2, 2), + delta = c(1, 2, 3) + ) + + d1 <- tibble( + out = c(1, 2, 3, 4), + v1 = c(1, 1, 1, 2), + v2 = c(1, 2, 3, 4), + id = c("c", "b", "a", "b") + ) + + delta_fun <- function(df) mutate(df, out + 1) + + expect_equal(delta2df(delta, d1), delta) + expect_equal(delta2df(delta_fun, d1), delta_fun(d1)) +}) +