diff --git a/NAMESPACE b/NAMESPACE index 0c4cd4201..822f238e4 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) @@ -37,6 +38,7 @@ S3method(validate,stan_data) export(Stack) export(add_class) export(analyse) +export(analysis_result) export(ancova) export(as_class) export(as_vcov) @@ -44,12 +46,14 @@ export(delta_template) export(draws) export(expand) export(expand_locf) +export(extract_analysis_result) export(extract_imputed_dfs) export(fill_locf) export(getStrategies) export(get_example_data) export(has_class) export(impute) +export(is.analysis_result) export(locf) export(longDataConstructor) export(method_approxbayes) @@ -72,6 +76,7 @@ import(R6) import(Rcpp) import(methods) importFrom(assertthat,assert_that) +importFrom(assertthat,has_attr) importFrom(mmrm,VarCorr) importFrom(rstan,extract) importFrom(rstan,sampling) diff --git a/R/analyse.R b/R/analyse.R index b313d74b5..24b865674 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) @@ -349,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", names(x$results[[1]])), + as_ascii_table(analysis_info(x$results[[1]])), "" ) @@ -440,12 +442,21 @@ 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 result must be type of analysis_result" ) - results_names <- lapply(results, function(x) unique(names(x))) + 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) @@ -487,3 +498,372 @@ 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`, `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 = 3, meta = list(visit = 1)) +#' } +#' @export +analysis_result <- function (name, + est, + 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) + + # asssert type for required parameter (directly assert type) + assert_type(name, is.character) + assert_type(est, is.numeric) + + # 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 length for required parameter + assert_anares_length(name, 1) + assert_anares_length(est, 1) + + # 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" + ) + } + + if (!is.null(df) & !anyNA(df)) { + assert_anares_length(df, 1) + + assert_that( + df >= 0, + msg = "DF must be greater or equal to 0" + ) + } + + value <- list(name = name, + est = est) + + # optional parameters + if (!is.null(se)) { + value[['se']] <- se + } + + if (!is.null(df)) { + value[['df']] <- df + } + + if (!is.null(meta)) { + value[['meta']] <- meta + } + + structure( + value, + meta = meta, + class = c("analysis_result", "list") + ) +} + +#' 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') +#' } +as_analysis_result <- function(x, ...) { + new_pars <- list(...) + + # coercion with generic function + x <- as.list(x) + + present <- ana_name_chker()('musthave_in_objnames') + + names_not_presented <- names(present(x))[!present(x)] + + # 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')) { + updated_x[[name]] <- new_pars[[name]] + } + } + + # after updating check if all required elements are presented + 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')) + + # set attributes: meta & class + if ('meta' %in% names(ordered_x)) { + attr(ordered_x, 'meta') <- ordered_x[['meta']] + } + + as_class(ordered_x, c("analysis_result", "list")) +} + +#' Name checker for analysis_result object +#' +#' 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') +#' } +ana_name_chker <- function() namechecker('name', 'est', optional = c('se', 'df', '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 +#' @export +#' @importFrom assertthat has_attr +is.analysis_result <- function(x) { + + all( + has_attr(x, 'class'), + 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)) + ) +} + +#' Convert a list of analysis_result objects to data.frame +#' +#' @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(analst, name_of_group = 'name', 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(analst)) { + item <- analst[[i]] + + assert_that(is.analysis_result(item), + 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]])) + 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)) + } + } + + base_left_join <- function(x, y, by) merge(x, y, by = by, all.x=TRUE) + + all_pars <- append(pars_with_meta, pars_no_meta) + + res_df <- base_bind_rows(all_pars) + + 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_group)), + error=function(e) res_df + ) + + subset(info_df, select = -index) +} + +#' Convert analysis results to a data.frame +#' +#' @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 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 +#' \dontrun{ +#' results <- list( +#' analysis_result( +#' name = 'trt', +#' est = 1, +#' se = 2, +#' df = 3, +#' meta = list(visit = 'vis1') +#' ), +#' analysis_result( +#' name = 'trt2', +#' est = 3, +#' se = 4, +#' df = 5, +#' meta = list(visit = 'vis2') +#' ) +#' ) +#' +#' 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(...) + + assert_keyword <- function(obj, msg) { + assert_that(all(!is.null(names(obj)), + length(names(obj)) > 0, + !any(grepl("^$", names(obj)))), + msg = msg + ) + } + + 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']], + "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) or other types of logical value + TRUE_or_FALSE <- 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 <- TRUE_or_FALSE(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 + + 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) { + message(w) + list() + }) +} diff --git a/R/ancova.R b/R/ancova.R index 57a08af44..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, ...)), #' ... #') #'``` @@ -139,8 +151,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 +185,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 +212,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('visit', ...) ), - lsm_ref = lsm0, - lsm_alt = lsm1 + as_analysis_result(lsm0, name = 'lsm_ref', meta = add_meta('visit', ...)), + as_analysis_result(lsm1, name = 'lsm_alt', meta = add_meta('visit', ...)) ) return(x) } diff --git a/R/pool.R b/R/pool.R index 98eb74524..dc4e6762b 100644 --- a/R/pool.R +++ b/R/pool.R @@ -72,13 +72,10 @@ pool <- function( pool_type <- class(results$results)[[1]] - results_transpose <- transpose_results( - results$results, - get_pool_components(pool_type) - ) + 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, @@ -86,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 { @@ -97,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) @@ -602,88 +602,111 @@ 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 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 #' -#' Essentially this function takes an object of the format: +#' The format of analysis results are converted from: #' #' ``` #' 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: +#' 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( -#' trt1 = list( +#' trt.1 = data.frame( +#' list( +#' name = 'trt', #' est = c(1,5), -#' se = c(2,6) +#' se = c(2,6), +#' visit = c(1,1) +#' ), #' ), -#' trt2 = list( +#' 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, 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) - ) +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 } } - return(results_transpose) + + extract_aggregate <- function(lst, keys) unique(lst[keys]) + extract_aggragates <- assert_map(extract_aggregate, function(x) nrow(x) == 1) + + results_df <- analst2df(results) + group_keys <- setdiff(names(results_df), non_group_keys) + + results <- unname(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 } @@ -707,7 +730,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/R/sysdata.rda b/R/sysdata.rda index f750a5d9d..7b50fb4ce 100644 Binary files a/R/sysdata.rda and b/R/sysdata.rda differ diff --git a/R/utilities.R b/R/utilities.R index cd4fa8cb0..9540cab5d 100644 --- a/R/utilities.R +++ b/R/utilities.R @@ -513,7 +513,246 @@ as_dataframe <- function(x) { return(x2) } +#' Add meta information to customerize analysis function +#' +#' This function is used only internally for ancova +#' +#' @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( + 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)) + ) + + names(var_values) <- var_names + var_values +} +#' 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 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(all(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 +#' @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) isTRUE(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 +#' @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)` +#' +#' } +order_list_by_name <- function(L, v) { + ordered_pos <- match(v, names(L)) + 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))) +} + +#' 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, function(.x) .x %in% 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 in musthave_in_objnames: B_in_A = swap(A_in_B)) + 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]] + } +} + +#' 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) + } + ) +} + +#' 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, na.action=na.pass) + ) +} diff --git a/man/add_meta.Rd b/man/add_meta.Rd new file mode 100644 index 000000000..fbb10eaf4 --- /dev/null +++ b/man/add_meta.Rd @@ -0,0 +1,16 @@ +% 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, ...) +} +\arguments{ +\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{var_name}{A character variable of the names of the elements to be added to meta} +} +\description{ +This function is used only internally for ancova +} diff --git a/man/ana_name_chker.Rd b/man/ana_name_chker.Rd new file mode 100644 index 000000000..f05023210 --- /dev/null +++ b/man/ana_name_chker.Rd @@ -0,0 +1,22 @@ +% 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_result object} +\usage{ +ana_name_chker() +} +\description{ +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/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 41d9bf9b1..34b601178 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()}}.} @@ -45,12 +48,14 @@ i.e.: 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..6d852632d --- /dev/null +++ b/man/analysis_info.Rd @@ -0,0 +1,26 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/analyse.R +\name{analysis_info} +\alias{analysis_info} +\title{Convert a list of analysis_result objects to data.frame} +\usage{ +analysis_info(analst, name_of_group = "name", name_of_meta = "meta") +} +\arguments{ +\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 \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 \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 \code{data.frame} containing the information of the analysis result from the \code{analst} +} +\description{ +Convert a list of analysis_result objects to data.frame +} +\examples{ +\dontrun{ +analysis_info(dat, name_of_group = 'name', name_of_meta = 'meta') +} +} diff --git a/man/analysis_result.Rd b/man/analysis_result.Rd new file mode 100644 index 000000000..52b9d3306 --- /dev/null +++ b/man/analysis_result.Rd @@ -0,0 +1,36 @@ +% 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, est, se = NULL, df = NULL, 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}, \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 = 3, meta = list(visit = 1)) +} +} diff --git a/man/ancova.Rd b/man/ancova.Rd index 886bd48cf..38f648b88 100644 --- a/man/ancova.Rd +++ b/man/ancova.Rd @@ -39,16 +39,29 @@ 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.: +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 + +\if{html}{\out{
}}\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 + ------------------------------------- + +}\if{html}{\out{
}} + +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_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, ...)), ... ) }\if{html}{\out{
}} 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/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_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/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 +} 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/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/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 + +} +} diff --git a/man/extract_analysis_result.Rd b/man/extract_analysis_result.Rd new file mode 100644 index 000000000..ea394cc15 --- /dev/null +++ b/man/extract_analysis_result.Rd @@ -0,0 +1,48 @@ +% 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 results from a list of analysis_results by matching names and values} +\usage{ +extract_analysis_result(results, ...) +} +\arguments{ +\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 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 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{ +results <- list( + analysis_result( + name = 'trt', + est = 1, + se = 2, + df = 3, + meta = list(visit = 'vis1') + ), + analysis_result( + name = 'trt2', + est = 3, + se = 4, + df = 5, + meta = list(visit = 'vis2') + ) +) + +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') +} +} 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/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/make_poolable.Rd b/man/make_poolable.Rd new file mode 100644 index 000000000..2ef23fe61 --- /dev/null +++ b/man/make_poolable.Rd @@ -0,0 +1,76 @@ +% 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: + +\if{html}{\out{
}}\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) + ) + ) +) +}\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 + +\if{html}{\out{
}}\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) + ) + ) +) +}\if{html}{\out{
}} +} diff --git a/man/namechecker.Rd b/man/namechecker.Rd new file mode 100644 index 000000000..1d03c55c4 --- /dev/null +++ b/man/namechecker.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utilities.R +\name{namechecker} +\alias{namechecker} +\title{Create name checkers for object 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 for object with message passing dispatch +} diff --git a/man/order_list_by_name.Rd b/man/order_list_by_name.Rd new file mode 100644 index 000000000..8395bff29 --- /dev/null +++ b/man/order_list_by_name.Rd @@ -0,0 +1,26 @@ +% 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 +} +\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)` + +} +} 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/transpose_results.Rd b/man/transpose_results.Rd deleted file mode 100644 index a8121fe6b..000000000 --- a/man/transpose_results.Rd +++ /dev/null @@ -1,59 +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, components) -} -\arguments{ -\item{results}{A list of results.} - -\item{components}{a character vector of components to extract -(i.e. \verb{"est", "se"}).} -} -\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: - -\if{html}{\out{
}}\preformatted{x <- list( - list( - "trt1" = list( - est = 1, - se = 2 - ), - "trt2" = list( - est = 3, - se = 4 - ) - ), - list( - "trt1" = list( - est = 5, - se = 6 - ), - "trt2" = list( - est = 7, - se = 8 - ) - ) -) -}\if{html}{\out{
}} - -and produces: - -\if{html}{\out{
}}\preformatted{list( - trt1 = list( - est = c(1,5), - se = c(2,6) - ), - trt2 = list( - est = c(3,7), - se = c(4,8) - ) -) -}\if{html}{\out{
}} -} diff --git a/man/vec2form.Rd b/man/vec2form.Rd new file mode 100644 index 000000000..ce7f92fd0 --- /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: \code{FALSE} - only right side formula will be generated} +} +\value{ +an object of formula class representing formula \code{~ chr[[1]] + chr[[2]] + ...} +} +\description{ +Convert character vector \code{c('a1', 'a2')} to formula \code{~ a1 + a2} +} diff --git a/src/.gitkeep b/src/.gitkeep deleted file mode 100644 index e69de29bb..000000000 diff --git a/tests/testthat/_snaps/print.md b/tests/testthat/_snaps/print.md index 6f549fb3e..ecd61751d 100644 --- a/tests/testthat/_snaps/print.md +++ b/tests/testthat/_snaps/print.md @@ -13,16 +13,16 @@ Results: - ======================================================== - parameter est se lci uci pval - -------------------------------------------------------- - trt_visit_1 7.253 0.781 5.665 8.842 <0.001 - lsm_ref_visit_1 7.254 0.566 6.102 8.406 <0.001 - lsm_alt_visit_1 14.507 0.479 13.533 15.481 <0.001 - trt_visit_3 7.984 0.258 7.448 8.52 <0.001 - lsm_ref_visit_3 7.005 0.205 6.575 7.436 <0.001 - lsm_alt_visit_3 14.989 0.167 14.641 15.338 <0.001 - -------------------------------------------------------- + ========================================================= + name visit est lci uci se pvalue + --------------------------------------------------------- + lsm_alt visit_1 14.507 13.533 15.481 0.479 <0.001 + lsm_ref visit_1 7.254 6.102 8.406 0.566 <0.001 + trt visit_1 7.253 5.665 8.842 0.781 <0.001 + lsm_alt visit_3 15 14.671 15.328 0.158 <0.001 + lsm_ref visit_3 7.005 6.579 7.431 0.202 <0.001 + trt visit_3 7.995 7.451 8.538 0.261 <0.001 + --------------------------------------------------------- --- @@ -40,19 +40,19 @@ Results: - =================================================== - parameter est se lci uci pval - --------------------------------------------------- - trt_visit_1 7.253 0.781 6.232 Inf 1 - lsm_ref_visit_1 7.254 0.566 6.513 Inf 1 - lsm_alt_visit_1 14.507 0.479 13.881 Inf 1 - trt_visit_2 7.406 0.388 6.898 Inf 1 - lsm_ref_visit_2 7.011 0.282 6.643 Inf 1 - lsm_alt_visit_2 14.417 0.238 14.106 Inf 1 - trt_visit_3 5.359 1.092 3.929 Inf 1 - lsm_ref_visit_3 6.723 0.835 5.624 Inf 1 - lsm_alt_visit_3 12.082 0.658 11.222 Inf 1 - --------------------------------------------------- + ====================================================== + name visit est lci uci se pvalue + ------------------------------------------------------ + lsm_alt visit_1 14.507 13.881 Inf 0.479 1 + lsm_ref visit_1 7.254 6.513 Inf 0.566 1 + trt visit_1 7.253 6.232 Inf 0.781 1 + lsm_alt visit_2 14.417 14.106 Inf 0.238 1 + lsm_ref visit_2 7.011 6.643 Inf 0.282 1 + trt visit_2 7.406 6.898 Inf 0.388 1 + lsm_alt visit_3 12.082 11.222 Inf 0.658 1 + lsm_ref visit_3 6.723 5.624 Inf 0.835 1 + trt visit_3 5.359 3.929 Inf 1.092 1 + ------------------------------------------------------ --- @@ -70,19 +70,19 @@ Results: - ===================================================== - parameter est se lci uci pval - ----------------------------------------------------- - trt_visit_1 6.643 -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-analyse.R b/tests/testthat/test-analyse.R index ef294d176..6ddda8842 100644 --- a/tests/testthat/test-analyse.R +++ b/tests/testthat/test-analyse.R @@ -8,8 +8,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) ) @@ -18,8 +18,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") ) @@ -28,8 +28,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) ) @@ -38,8 +38,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) ) @@ -48,8 +48,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) ) @@ -58,13 +58,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)) - }) @@ -74,8 +73,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) ), @@ -85,8 +83,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) ), @@ -96,8 +94,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) ), @@ -109,80 +107,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 + ### 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" - ) + 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( 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( @@ -193,37 +190,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) ), @@ -232,8 +229,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) ) diff --git a/tests/testthat/test-analysis_result.R b/tests/testthat/test-analysis_result.R new file mode 100644 index 000000000..50cc1b8d4 --- /dev/null +++ b/tests/testthat/test-analysis_result.R @@ -0,0 +1,464 @@ +# 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", { + + skip_if_not(is_full_test()) + + 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", { + + skip_if_not(is_full_test()) + + 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", { + + 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)) + 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]])) +}) + +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)) + 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')), + "Invalid parameters") + + expect_error(extract_analysis_result(x, meta = list(NULL)), + "Invalid parameters") + + expect_error(extract_analysis_result(x, meta = list(NA)), + "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-ancova.R b/tests/testthat/test-ancova.R index eee1f1a49..fbb524f6d 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) @@ -63,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) @@ -93,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", @@ -109,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) @@ -132,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", @@ -148,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", @@ -161,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", @@ -179,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")) ################## # diff --git a/tests/testthat/test-fullusage.R b/tests/testthat/test-fullusage.R index e12f8f92e..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", { @@ -205,7 +216,7 @@ test_that("Basic Usage - Bayesian", { -test_that("Basic Usage - Condmean", { +test_that("Basic Usage - Condmean", { skip_if_not(is_full_test()) @@ -348,10 +359,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) ) ) } @@ -364,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) ) @@ -382,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") @@ -399,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") @@ -527,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) @@ -685,7 +697,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 +751,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, @@ -805,11 +818,11 @@ test_that("rbmi works for one arm trials", { } else { pooled <- pool(anl_obj) } - - expect_length(pooled$pars$mean, 4) - 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)))) + 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") @@ -848,10 +861,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) @@ -919,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 @@ -948,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-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 5e866a389..ef62e0618 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( @@ -271,8 +271,9 @@ test_that("Pool (Rubin) works as expected when se = NA in analysis model", { bayes3 <- pool(results_bayes, alternative = "greater") expect_equal( - bayes$pars$p1, - list(est = real_mu, + extract_analysis_result(bayes$pars, name = 'p1')[[1]], + list(name = 'p1', + est = real_mu, ci = as.numeric(c(NA, NA)), se = as.numeric(NA), pvalue = as.numeric(NA)), @@ -280,8 +281,9 @@ test_that("Pool (Rubin) works as expected when se = NA in analysis model", { ) expect_equal( - bayes2$pars$p1, - list(est = real_mu, + extract_analysis_result(bayes2$pars, name = 'p1')[[1]], + list(name = 'p1', + est = real_mu, ci = as.numeric(c(NA, NA)), se = as.numeric(NA), pvalue = as.numeric(NA)), @@ -289,8 +291,9 @@ test_that("Pool (Rubin) works as expected when se = NA in analysis model", { ) expect_equal( - bayes3$pars$p1, - list(est = real_mu, + extract_analysis_result(bayes3$pars, name = 'p1')[[1]], + list(name = 'p1', + est = real_mu, ci = as.numeric(c(NA, NA)), se = as.numeric(NA), pvalue = as.numeric(NA)), @@ -298,7 +301,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( @@ -314,8 +317,9 @@ test_that("Pool (Rubin) works as expected when se = NA in analysis model", { bayes3 <- pool(results_bayes, alternative = "greater") expect_equal( - bayes$pars$p1, - list(est = real_mu, + extract_analysis_result(bayes$pars, name = 'p1')[[1]], + list(name = 'p1', + est = real_mu, ci = as.numeric(c(NA, NA)), se = as.numeric(NA), pvalue = as.numeric(NA)), @@ -323,8 +327,9 @@ test_that("Pool (Rubin) works as expected when se = NA in analysis model", { ) expect_equal( - bayes2$pars$p1, - list(est = real_mu, + extract_analysis_result(bayes2$pars, name = 'p1')[[1]], + list(name = 'p1', + est = real_mu, ci = as.numeric(c(NA, NA)), se = as.numeric(NA), pvalue = as.numeric(NA)), @@ -332,15 +337,16 @@ test_that("Pool (Rubin) works as expected when se = NA in analysis model", { ) expect_equal( - bayes3$pars$p1, - list(est = real_mu, + extract_analysis_result(bayes3$pars, name = 'p1')[[1]], + list(name = 'p1', + est = real_mu, ci = as.numeric(c(NA, NA)), se = as.numeric(NA), pvalue = as.numeric(NA)), tolerance = 1e-2 ) }) - + test_that("pool BMLMI estimates", { set.seed(100) @@ -366,7 +372,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)) } @@ -448,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) }) @@ -830,7 +836,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,14 +851,16 @@ 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(extract_analysis_result(pooled_1$pars, name = 'p1')[[1]]$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(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) }) 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 05da2027b..bc04bbbdf 100644 --- a/tests/testthat/test-utilities.R +++ b/tests/testthat/test-utilities.R @@ -241,3 +241,226 @@ test_that("Stack", { expect_equal(mstack$pop(3), list(7)) expect_error(mstack$pop(1), "items to return") }) + + +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)) + 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)) +}) + + +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)) + 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", { + + 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'))) + 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", { + + 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)) + 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", { + + 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)) + expect_false(is.numeric_or_na('a')) + expect_false(is.numeric_or_na(list())) + expect_error(make_chain(any, is.numeric, 'a')(1)) +}) + +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"))) + 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", { + + 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')) + 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))) +}) + +test_that("compose_n", { + + skip_if_not(is_full_test()) + + # 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", { + + skip_if_not(is_full_test()) + + 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) +}) + + +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])) + expect_equal(deparse(x), "~a1 + a2") + } +) + +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 + 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) +})