From 0264f66e937d43011a479b1f5afdee1f1c1a1ef8 Mon Sep 17 00:00:00 2001 From: Matthew Phelps Date: Tue, 19 Mar 2024 15:12:32 +0100 Subject: [PATCH] Apply stylr to whole package --- R/add_event_index.R | 24 +- R/add_id.R | 2 +- R/apply_criterion.R | 2 +- R/apply_stats.R | 26 +- R/check_duplicate_functions.R | 9 +- R/construct_data_filter_logic.R | 11 +- R/eval_fn.R | 60 +- R/evaluate_criteria.R | 9 +- R/expand_endpoints.R | 78 +- R/fetch_db_data.R | 14 +- R/filter_db_data.R | 37 +- R/format_stats_results.R | 10 +- R/global.R | 3 +- R/group_ep_for_targets.R | 4 +- R/handle_mk_fn.R | 14 +- R/mk_endpoint_str.R | 16 +- R/mk_filtered_endpoint_dt.R | 9 +- R/mk_userdef_fn_dt.R | 32 +- R/parse_function_inputs.R | 9 +- R/prepare_for_stats.R | 166 ++-- R/try_and_validate.R | 48 +- R/unnest_by_fns.R | 23 +- R/unnest_endpoint_functions.R | 3 +- R/use_chef.R | 9 +- R/utils.R | 2 +- R/validate_endpoints_def.R | 52 +- R/validate_usr_fn_args.R | 1 - tests/testthat/helper-custom_expect.R | 8 +- tests/testthat/helper-mk_adam.R | 41 +- tests/testthat/helper-mk_ep.R | 12 +- tests/testthat/helper-stat_methods.R | 3 - tests/testthat/test-add_event_index.R | 129 +-- .../testthat/test-apply_criterion_by_strata.R | 7 +- .../testthat/test-apply_criterion_endpoint.R | 52 +- tests/testthat/test-apply_dt_filter.R | 46 +- tests/testthat/test-apply_stats.R | 724 +++++++------- .../testthat/test-check_duplicate_functions.R | 43 +- tests/testthat/test-construct_filter_logic.R | 4 +- tests/testthat/test-endpoint_bookkeeping.R | 139 +-- tests/testthat/test-expand_over_endpoints.R | 425 ++++---- tests/testthat/test-fetch_db_data.R | 95 +- tests/testthat/test-filter_db_data.R | 410 ++++---- tests/testthat/test-group_ep_for_targets.R | 8 +- tests/testthat/test-mk_endpoint_str.R | 207 ++-- tests/testthat/test-mk_userdef_fn_dt.R | 102 +- tests/testthat/test-parse_function_input.R | 13 +- tests/testthat/test-pipeline_manual.R | 5 +- tests/testthat/test-prepare_for_stats.R | 47 +- tests/testthat/test-targets.R | 917 +++++++++--------- tests/testthat/test-try_and_validate.R | 17 +- tests/testthat/test-unnest_by_fns.R | 200 ++-- .../testthat/test-unnest_endpoint_functions.R | 91 +- tests/testthat/test-use_chef.R | 307 +++--- tests/testthat/test-validate_usr_fn_args.R | 76 +- 54 files changed, 2487 insertions(+), 2314 deletions(-) diff --git a/R/add_event_index.R b/R/add_event_index.R index 76a9deb..93c5f29 100644 --- a/R/add_event_index.R +++ b/R/add_event_index.R @@ -18,8 +18,7 @@ #' #' @noRd -create_flag <- function(dat, var_value_pairs=NULL, singletons=NULL) { - +create_flag <- function(dat, var_value_pairs = NULL, singletons = NULL) { filter_str <- construct_data_filter_logic( var_value_pairs = var_value_pairs, @@ -42,7 +41,7 @@ create_flag <- function(dat, var_value_pairs=NULL, singletons=NULL) { #' of the columns `pop_var`, `pop_value`, `period_var`, `period_value`, #' `endpoint_filter`, `endpoint_group_filter`, and `custom_pop_filter`, which #' are used to define the conditions for event indexing. -#' +#' #' @param analysis_data_container A data.table containing the analysis data. #' #' @return A `data.table` similar to the input but with an additional @@ -57,11 +56,16 @@ add_event_index <- function(ep, analysis_data_container) { ep_out[, event_index := llist( create_flag( dat[[1]], - var_value_pairs = list(c(pop_var[[1]], pop_value[[1]]), - c(period_var[[1]], period_value[[1]])), - singletons = c(endpoint_filter[[1]], - endpoint_group_filter[[1]], - custom_pop_filter[[1]]) - )), by = endpoint_id] - ep_out[, dat:=NULL] + var_value_pairs = list( + c(pop_var[[1]], pop_value[[1]]), + c(period_var[[1]], period_value[[1]]) + ), + singletons = c( + endpoint_filter[[1]], + endpoint_group_filter[[1]], + custom_pop_filter[[1]] + ) + ) + ), by = endpoint_id] + ep_out[, dat := NULL] } diff --git a/R/add_id.R b/R/add_id.R index c22d52f..48e976f 100644 --- a/R/add_id.R +++ b/R/add_id.R @@ -4,7 +4,7 @@ #' #' @return data.table #' @export -add_id <- function(ep){ +add_id <- function(ep) { x <- copy(ep) x[, endpoint_spec_id := .I] x[] diff --git a/R/apply_criterion.R b/R/apply_criterion.R index 2ab1ff0..7633229 100644 --- a/R/apply_criterion.R +++ b/R/apply_criterion.R @@ -149,7 +149,7 @@ apply_criterion_by_strata <- #' @noRd unnest_ep_by_strata <- function(ep) { ep_accepted <- ep[(crit_accept_endpoint)] - ep_accepted[,strata_var := stratify_by] + ep_accepted[, strata_var := stratify_by] ep_unnested <- tidyr::unnest(ep_accepted, col = strata_var) |> setDT() diff --git a/R/apply_stats.R b/R/apply_stats.R index e8e3125..b17ea86 100644 --- a/R/apply_stats.R +++ b/R/apply_stats.R @@ -16,16 +16,17 @@ apply_stats <- function(ep, analysis_data_container, - type = c("stat_by_strata_by_trt", - "stat_by_strata_across_trt", - "stat_across_strata_across_trt")) { - + type = c( + "stat_by_strata_by_trt", + "stat_by_strata_across_trt", + "stat_across_strata_across_trt" + )) { checkmate::assert_data_table(ep) # If no functions are given by the user, no results table needs to be # produced nm <- names(ep) if (length(nm) <= 3 && - nm[1] == "SKIP_") { + nm[1] == "SKIP_") { return(data.table(NULL)) } type <- match.arg(type) @@ -34,8 +35,7 @@ apply_stats <- ep_cp <- ep[analysis_data_container] if (type == "stat_by_strata_by_trt") { - - if (nrow(ep_cp[crit_accept_by_strata_by_trt == TRUE]) == 0){ + if (nrow(ep_cp[crit_accept_by_strata_by_trt == TRUE]) == 0) { ep_cp[, stat_result := list()] } else { ep_cp[crit_accept_by_strata_by_trt == TRUE, stat_result := llist( @@ -56,10 +56,8 @@ apply_stats <- ) ), by = stat_result_id] } - } else if (type == "stat_by_strata_across_trt") { - - if (nrow(ep_cp[crit_accept_by_strata_across_trt == TRUE]) == 0 ){ + if (nrow(ep_cp[crit_accept_by_strata_across_trt == TRUE]) == 0) { ep_cp[, stat_result := list()] } else { ep_cp[crit_accept_by_strata_across_trt == TRUE, stat_result := llist( @@ -73,17 +71,16 @@ apply_stats <- event_index = unlist(event_index), cell_index = unlist(cell_index), subjectid_var = "USUBJID" - ), + ), validator = validate_stat_output, expr_name = fn_name ) ), by = stat_result_id] } - } else if (type == "stat_across_strata_across_trt"){ - if (nrow(ep_cp[crit_accept_by_strata_across_trt == TRUE]) == 0 ){ + } else if (type == "stat_across_strata_across_trt") { + if (nrow(ep_cp[crit_accept_by_strata_across_trt == TRUE]) == 0) { ep_cp[, stat_result := list()] } else { - ep_cp[crit_accept_by_strata_across_trt == TRUE, stat_result := llist( expr_ = try_and_validate( fn_callable[[1]]( @@ -103,5 +100,4 @@ apply_stats <- keep <- setdiff(names(ep_cp), c("fn_callable", "dat", "tar_group")) ep_cp[, .SD, .SDcols = keep] - } diff --git a/R/check_duplicate_functions.R b/R/check_duplicate_functions.R index ea214b3..b2e1ee9 100644 --- a/R/check_duplicate_functions.R +++ b/R/check_duplicate_functions.R @@ -7,7 +7,7 @@ #' @export #' check_duplicate_functions <- function(dir) { - if(!dir.exists(dir)){ + if (!dir.exists(dir)) { stop(paste0("Directory ", dir, " does not exist")) } dir_norm <- normalizePath(dir) @@ -16,8 +16,9 @@ check_duplicate_functions <- function(dir) { fn_names_ls <- lapply(x, function(i) { lang_objs <- Filter(is.language, parse(i)) fun_entries <- - Filter(function(x) - grepl(", function", toString(x)), lang_objs) + Filter(function(x) { + grepl(", function", toString(x)) + }, lang_objs) sapply(fun_entries, function(fun_entry_i) { trimws(strsplit(toString(fun_entry_i), ",")[[1]][2]) }) @@ -37,6 +38,4 @@ check_duplicate_functions <- function(dir) { "\n\n Please change the name so there are no duplicated names, otherwise it will be unclear which function will be used in the program.\n" ) ) - - } diff --git a/R/construct_data_filter_logic.R b/R/construct_data_filter_logic.R index c3f5421..6bd06ed 100644 --- a/R/construct_data_filter_logic.R +++ b/R/construct_data_filter_logic.R @@ -27,15 +27,12 @@ construct_data_filter_logic <- } if (!is.null(singletons)) { singletons_no_na <- singletons[!sapply(singletons, is_null_or_na)] - if(length(singletons_no_na)>0){ + if (length(singletons_no_na) > 0) { singletons_collapsed <- paste0(singletons_no_na, collapse = " & ") } - } - paste0(c(pairs, singletons_collapsed),collapse = " & ") - - + paste0(c(pairs, singletons_collapsed), collapse = " & ") } -is_null_or_na <- function(x){ - is.null(x)||is.na(x) +is_null_or_na <- function(x) { + is.null(x) || is.na(x) } diff --git a/R/eval_fn.R b/R/eval_fn.R index 6351045..af201de 100644 --- a/R/eval_fn.R +++ b/R/eval_fn.R @@ -1,11 +1,13 @@ - eval_data_fn <- function(fn_list, ...) { out <- lapply(fn_list, function(fn) { - x <- tryCatch({ - fn(...) # apply the function i - }, error = function(e) { - return(e) - }) + x <- tryCatch( + { + fn(...) # apply the function i + }, + error = function(e) { + return(e) + } + ) if (inherits(x, "simpleError") || inherits(x, "error")) { return(list( @@ -15,8 +17,8 @@ eval_data_fn <- function(fn_list, ...) { )) } - x[, "TOTAL_":="total"] - x[, "INDEX_":= .I] + x[, "TOTAL_" := "total"] + x[, "INDEX_" := .I] setkey(x, "INDEX_") return(list( @@ -24,11 +26,9 @@ eval_data_fn <- function(fn_list, ...) { error_flag = FALSE, error_message = NULL )) - }) purrr::transpose(out) - } #' Evaluate Endpoint Criteria @@ -44,21 +44,24 @@ eval_data_fn <- function(fn_list, ...) { eval_criteria_endpoint <- function(fn, ...) { dots <- list(...) result <- fn( - dat = dots$dat, - event_index = dots$event_index, - treatment_var = dots$treatment_var, - treatment_refval = dots$treatment_refval, - period_var = dots$period_var, - period_value = dots$period_value, - endpoint_filter = dots$endpoint_filter, - endpoint_group_metadata = dots$endpoint_group_metadata, - stratify_by = dots$stratify_by, - subjectid_var = dots$subjectid_var) + dat = dots$dat, + event_index = dots$event_index, + treatment_var = dots$treatment_var, + treatment_refval = dots$treatment_refval, + period_var = dots$period_var, + period_value = dots$period_value, + endpoint_filter = dots$endpoint_filter, + endpoint_group_metadata = dots$endpoint_group_metadata, + stratify_by = dots$stratify_by, + subjectid_var = dots$subjectid_var + ) if (!(isTRUE(result) | - isFALSE(result))) { - stop("The return value from the endpoint criterion function must be a logical of length 1, i.e.", - "TRUE or FALSE") + isFALSE(result))) { + stop( + "The return value from the endpoint criterion function must be a logical of length 1, i.e.", + "TRUE or FALSE" + ) } result } @@ -86,11 +89,14 @@ eval_criteria_subgroup <- function(fn, ...) { endpoint_filter = dots$endpoint_filter, endpoint_group_metadata = dots$endpoint_group_metadata, strata_var = dots$strata_var, - subjectid_var = dots$subjectid_var) + subjectid_var = dots$subjectid_var + ) if (!(isTRUE(result) | - isFALSE(result))) { - stop("The return value from the endpoint criterion function must be a logical of length 1, i.e.", - "TRUE or FALSE") + isFALSE(result))) { + stop( + "The return value from the endpoint criterion function must be a logical of length 1, i.e.", + "TRUE or FALSE" + ) } result } diff --git a/R/evaluate_criteria.R b/R/evaluate_criteria.R index 4926489..a7be142 100644 --- a/R/evaluate_criteria.R +++ b/R/evaluate_criteria.R @@ -11,15 +11,16 @@ #' whether to keep the endpoint/strata or not. #' @export #' -evaluate_criteria <- function(endpoints, adam_set, criteria_type = c("endpoint", "subgroup_description", "subgroup_analysis")){ -checkmate::assertDataTable(endpoints) +evaluate_criteria <- function(endpoints, adam_set, criteria_type = c("endpoint", "subgroup_description", "subgroup_analysis")) { + checkmate::assertDataTable(endpoints) endpoints_out <- data.table::copy(endpoints) # Apply row-wise operations over the endpoint data to enrich data with an # evaluation of criteria and an updated log - endpoints_out[, c(paste0("keep_",criteria_type), "log") := criterion_wrapper(.SD, adam_set, criteria_type), - by = seq_len(nrow(endpoints_out))] + endpoints_out[, c(paste0("keep_", criteria_type), "log") := criterion_wrapper(.SD, adam_set, criteria_type), + by = seq_len(nrow(endpoints_out)) + ] return(endpoints_out[]) } diff --git a/R/expand_endpoints.R b/R/expand_endpoints.R index b29d9b5..6d1424f 100644 --- a/R/expand_endpoints.R +++ b/R/expand_endpoints.R @@ -16,27 +16,28 @@ #' definition #' @export expand_over_endpoints <- function(ep, analysis_data_container) { - ep_with_data <- ep[analysis_data_container] ep_with_data[, expand_specification := llist(define_expanded_ep(dat[[1]], group_by[[1]])), - by = 1:nrow(ep_with_data)] + by = 1:nrow(ep_with_data) + ] ep_with_data[["dat"]] <- NULL # Expand by groups. If no grouping is present, then add empty group related columns - if(any(!is.na(ep_with_data$expand_specification))){ - ep_exp <- ep_with_data %>% tidyr::unnest(col = expand_specification) %>% setDT() - }else{ + if (any(!is.na(ep_with_data$expand_specification))) { + ep_exp <- ep_with_data %>% + tidyr::unnest(col = expand_specification) %>% + setDT() + } else { ep_exp <- ep_with_data[, .SD, .SDcols = setdiff(names(ep_with_data), "expand_specification")] ep_exp[, endpoint_group_filter := NA] ep_exp[, endpoint_group_metadata := list()] } - + ep_exp[, endpoint_id := add_ep_id(.SD, .BY), by = endpoint_spec_id] # Complete endpoint labels by replacing keywords with values nm_set <- names(ep_exp) - ep_exp[,endpoint_label_evaluated := apply(ep_exp, 1, function(x){ - + ep_exp[, endpoint_label_evaluated := apply(ep_exp, 1, function(x) { xlab <- x[["endpoint_label"]] # Replace keywords. Do only accept keywords which reference to either @@ -45,9 +46,11 @@ expand_over_endpoints <- function(ep, analysis_data_container) { if (grepl(paste0("<", i, ">"), xlab)) { if (is.character(x[[i]]) || is.numeric(x[[i]])) { xlab <- - xlab %>% gsub(paste0("<", i, ">"), - paste0(str_to_sentence_base(x[[i]]), collapse = ","), - .) + xlab %>% gsub( + paste0("<", i, ">"), + paste0(str_to_sentence_base(x[[i]]), collapse = ","), + . + ) } } } @@ -59,9 +62,11 @@ expand_over_endpoints <- function(ep, analysis_data_container) { for (j in group_keywords) { if (!is.null(x$endpoint_group_metadata[[j]])) { xlab <- - xlab %>% gsub(paste0("<", j, ">"), - as.character(x$endpoint_group_metadata[[j]]), - .) + xlab %>% gsub( + paste0("<", j, ">"), + as.character(x$endpoint_group_metadata[[j]]), + . + ) } } } @@ -87,9 +92,9 @@ expand_over_endpoints <- function(ep, analysis_data_container) { ) ) -out <- ep_exp[, .SD, .SDcols=keep] -setkey(out, key_analysis_data) -out[] + out <- ep_exp[, .SD, .SDcols = keep] + setkey(out, key_analysis_data) + out[] } @@ -105,7 +110,7 @@ out[] #' @param group_by A list specifying the grouping for endpoints, where #' each element corresponds to a variable used for grouping endpoints and #' contains the levels for that grouping variable. -#' @param forced_group_levels data.table (optional). Table with group levels +#' @param forced_group_levels data.table (optional). Table with group levels #' that must be included in the expansion, regardless of `group_by`. #' @param col_prefix A prefix used to create the names of the metadata and #' filter columns in the output `data.table`. Defaults to "endpoint_group". @@ -116,15 +121,16 @@ out[] #' @export #' define_expanded_ep <- function(x, group_by, forced_group_levels = NULL, col_prefix = "endpoint_group") { - if (!is.list(group_by) || all(is.na(group_by))) + if (!is.list(group_by) || all(is.na(group_by))) { return(NA) + } - col_name_meta = paste(col_prefix, "metadata", sep="_") - col_name_filter = paste(col_prefix, "filter", sep="_") + col_name_meta <- paste(col_prefix, "metadata", sep = "_") + col_name_filter <- paste(col_prefix, "filter", sep = "_") out <- index_expanded_ep_groups(x, group_by, forced_group_levels) %>% construct_group_filter(col_name_filter = col_name_filter) - out[, (col_name_meta) := .(list(lapply(.SD, identity))), by=1:nrow(out), .SDcols = names(group_by)] + out[, (col_name_meta) := .(list(lapply(.SD, identity))), by = 1:nrow(out), .SDcols = names(group_by)] out[, .SD, .SDcols = c(col_name_meta, col_name_filter)] } @@ -177,10 +183,11 @@ index_expanded_ep_groups <- function(x, group_by, forced_group_levels = NULL) { index_non_null_group_level(group_by) if (length(specified_group_levels) > 0) { var_group_levels <- names(specified_group_levels) - if (length(var_group_levels) > 1) + if (length(var_group_levels) > 1) { stop("Support for multiple variables specifying group levels not yet supported") + } combos_subset <- - combos_all[tolower(get(var_group_levels)) %in% tolower(specified_group_levels[[var_group_levels]]),] + combos_all[tolower(get(var_group_levels)) %in% tolower(specified_group_levels[[var_group_levels]]), ] } else { combos_subset <- combos_all } @@ -188,14 +195,14 @@ index_expanded_ep_groups <- function(x, group_by, forced_group_levels = NULL) { # Expand by all possible combinations of group-by columns in combos_subset. if (length(group_by) == 1) { return(combos_subset) - }else{ + } else { unique_vals <- lapply(combos_subset, unique) combos_expanded <- setDT(expand.grid(unique_vals, stringsAsFactors = FALSE)) return(combos_expanded) } } -construct_group_filter <- function(x, col_name_filter="endpoint_group_filter") { +construct_group_filter <- function(x, col_name_filter = "endpoint_group_filter") { out <- copy(x) filter_str_vec <- purrr::pmap(x, create_condition_str) %>% unlist(recursive = F) @@ -209,7 +216,7 @@ create_condition_str <- function(...) { purrr::map2_chr(names(lst), lst, ~ paste0(.x, ' == "', .y, '"')) # Concatenate all condition strings with ' & ' and return the result - return(paste(conditions, collapse = ' & ')) + return(paste(conditions, collapse = " & ")) } @@ -239,9 +246,8 @@ add_ep_id <- function(x, grp) { #' @param combos_all A data.table containing all combinations of group levels found in the analysis data. #' @param forced_group_levels A one column data.table containing a required set of group levels of a grouping variable. #' -#' @return A data.table containing all combinations of group levels exapnded with the forced grouping levels. +#' @return A data.table containing all combinations of group levels exapnded with the forced grouping levels. add_forced_group_levels <- function(combos_all, forced_group_levels) { - # If no forced group levels are present then return early if (is.null(forced_group_levels)) { return(combos_all) @@ -250,7 +256,7 @@ add_forced_group_levels <- function(combos_all, forced_group_levels) { # Only forced group levels on one group variable is supported, so check that forced_group_levels has one column only checkmate::assertDataTable(forced_group_levels, ncols = 1) - # Check that the variable that is subject to the forced group levels is present in the analysis data + # Check that the variable that is subject to the forced group levels is present in the analysis data unsupported_forced_group_levels <- setdiff(names(forced_group_levels), names(combos_all)) |> length() > 0 if (unsupported_forced_group_levels) { @@ -268,16 +274,20 @@ add_forced_group_levels <- function(combos_all, forced_group_levels) { # Check if the forced group levels covers more than the existing group levels. If not then no need to force them. forced_group_levels_already_present <- setequal(actual_group_levels[[1]], forced_group_levels[[1]]) - + # If the forced group levels cover more than the existing group levels then add them to the group level combinations if (!forced_group_levels_already_present) { cols_from_combos_all <- names(combos_all) != names(forced_group_levels) - col_list_combos_all <- lapply(combos_all[, .SD, .SDcols = cols_from_combos_all], function(x){x}) - col_list_2 <-lapply(forced_group_levels, function(x){x}) + col_list_combos_all <- lapply(combos_all[, .SD, .SDcols = cols_from_combos_all], function(x) { + x + }) + col_list_2 <- lapply(forced_group_levels, function(x) { + x + }) grid_list <- c(col_list_combos_all, col_list_2) return(expand.grid(grid_list) |> setDT()) } # If the forced group levels do not cover more than the existing group levels then return the unmodified group level combinations return(combos_all) -} \ No newline at end of file +} diff --git a/R/fetch_db_data.R b/R/fetch_db_data.R index 02cd149..a706994 100644 --- a/R/fetch_db_data.R +++ b/R/fetch_db_data.R @@ -26,12 +26,16 @@ fetch_db_data <- adam <- fn_dt[fn_type == "data_prepare"] adam[, c("dat", "error_flag", "error_msg") := eval_data_fn( - study_metadata = study_metadata, - fn = fn_callable), by = - seq_len(nrow(adam))] - adam[, error_flag := unlist(error_flag)] - if (sum(adam$error_flag) > 0) + study_metadata = study_metadata, + fn = fn_callable + ), + by = + seq_len(nrow(adam)) + ] + adam[, error_flag := unlist(error_flag)] + if (sum(adam$error_flag) > 0) { throw_error_adam(adam) + } return(adam[, .(fn_type, fn_hash, fn_name, fn_call_char, fn_callable, dat)]) } diff --git a/R/filter_db_data.R b/R/filter_db_data.R index b95e26d..0162df3 100644 --- a/R/filter_db_data.R +++ b/R/filter_db_data.R @@ -16,15 +16,17 @@ filter_db_data <- function(ep, ep_fn_map, adam_db) { ep_adam <- merge(ep, - ep_fn_map[fn_type == "data_prepare", .(endpoint_spec_id, fn_hash, fn_type)], - by = "endpoint_spec_id") + ep_fn_map[fn_type == "data_prepare", .(endpoint_spec_id, fn_hash, fn_type)], + by = "endpoint_spec_id" + ) ep_adam <- merge(ep_adam, - adam_db[, .(fn_hash, dat)], - by = "fn_hash", - all.x = TRUE, - all.y = FALSE) + adam_db[, .(fn_hash, dat)], + by = "fn_hash", + all.x = TRUE, + all.y = FALSE + ) ep_adam[, dat_analysis := llist( @@ -42,11 +44,14 @@ filter_db_data <- function(ep, ep_fn_map, adam_db) { setnames(ep_adam, "dat_analysis", "dat") ep_adam[, - key_analysis_data := digest::digest(list(fn_hash, - pop_var, - pop_value, - custom_pop_filter)), - by = 1:nrow(ep_adam)] + key_analysis_data := digest::digest(list( + fn_hash, + pop_var, + pop_value, + custom_pop_filter + )), + by = 1:nrow(ep_adam) + ] setkey(ep_adam, key_analysis_data) # The data container only keeps one row per unique analysis dataset analysis_data_container <- ep_adam[, .(dat, key_analysis_data)] @@ -54,8 +59,10 @@ filter_db_data <- function(ep, ep_fn_map, adam_db) { analysis_data_container[, unique(analysis_data_container, by = "key_analysis_data")] ep_adam[["dat"]] <- NULL - return(list(ep = ep_adam, - analysis_data_container = analysis_data_container)) + return(list( + ep = ep_adam, + analysis_data_container = analysis_data_container + )) } @@ -80,7 +87,8 @@ filter_adam_db <- filter_str <- construct_data_filter_logic( var_value_pairs = list(c(pop_var, pop_value)), - singletons = custom_pop_filter) + singletons = custom_pop_filter + ) apply_dt_filter(dat, filter_str, type = "filter") } @@ -114,5 +122,4 @@ apply_dt_filter <- out[, event_flag := FALSE] out[eval(parse(text = filter_string)), event_flag := TRUE] return(out) - } diff --git a/R/format_stats_results.R b/R/format_stats_results.R index 7cc2da1..ebccd25 100644 --- a/R/format_stats_results.R +++ b/R/format_stats_results.R @@ -5,8 +5,10 @@ #' @return A data.table containing the unnested endpoint information. #' @export #' -format_stats_results <- function(ep){ - if(is.null(ep))return(NULL) +format_stats_results <- function(ep) { + if (is.null(ep)) { + return(NULL) + } out <- ep %>% tidyr::unnest(cols = results) %>% as.data.table() @@ -14,8 +16,8 @@ format_stats_results <- function(ep){ names_out <- names(out) cols_to_move_actual <- intersect(cols_to_move_suggested, names_out) setcolorder(out, c(setdiff(names_out, cols_to_move_actual), cols_to_move_actual)) - if(length(intersect("strata_val", names_out))==0){ + if (length(intersect("strata_val", names_out)) == 0) { return(out) } - out[stratify_by=="TOTAL_", strata_val := "total"] + out[stratify_by == "TOTAL_", strata_val := "total"] } diff --git a/R/global.R b/R/global.R index 9d66f8f..23ff142 100644 --- a/R/global.R +++ b/R/global.R @@ -45,7 +45,7 @@ utils::globalVariables( ) ) -helper_calls_to_imports <- function(){ +helper_calls_to_imports <- function() { # Some packages will be needed when the user runs the pipeline, so we want # those packages "Imported" in the DESCRIPTION file, so the user does not have # any additional steps to install them after installing chef. However, the @@ -60,5 +60,4 @@ helper_calls_to_imports <- function(){ future.callr::callr tarchetypes::walk_ast targets::tar_warning - } diff --git a/R/group_ep_for_targets.R b/R/group_ep_for_targets.R index 413d67a..adf8652 100644 --- a/R/group_ep_for_targets.R +++ b/R/group_ep_for_targets.R @@ -7,9 +7,9 @@ #' column. #' @export #' -group_ep_for_targets <- function(ep, n_per_group){ +group_ep_for_targets <- function(ep, n_per_group) { x <- copy(ep) n_rows <- nrow(x) - x[, targets_group :=(.I-1) %/% n_per_group] + x[, targets_group := (.I - 1) %/% n_per_group] x[] } diff --git a/R/handle_mk_fn.R b/R/handle_mk_fn.R index 2a597d5..8fdd3f0 100644 --- a/R/handle_mk_fn.R +++ b/R/handle_mk_fn.R @@ -16,10 +16,9 @@ handle_mk_fn <- type <- match.arg(type) if (is.null(fn)) { - if (type != "mk_endpoint_def") { nm <- paste0(type, "_scaffold.R") - } else{ + } else { nm <- paste0(type, ".R") } path <- paste0(r_functions_dir, nm) @@ -32,7 +31,6 @@ handle_mk_fn <- open = TRUE ) )) - } if (length(fn) == 1) { return( @@ -58,7 +56,6 @@ handle_mk_fn <- nm, env = env ) - } handle_mk_fn_ <- @@ -81,8 +78,10 @@ handle_mk_fn_ <- fn_out <- paste0(deparse(fn_evaled), "()") } else { if (!is.function(fn_evaled)) { - stop(type, - "_fn must be a call to a function defining the endpoints") + stop( + type, + "_fn must be a call to a function defining the endpoints" + ) } fn_bod <- deparse(fn_evaled) fn_bod[1] <- gsub("\\s+", "", fn_bod[1]) @@ -97,7 +96,7 @@ handle_mk_fn_ <- file.create(path_normalized) writeLines(fn_out, path_normalized) - } else{ + } else { overwrite <- usethis::ui_yeah("Overwrite pre-existing file {path}?") if (overwrite) { @@ -110,5 +109,4 @@ handle_mk_fn_ <- # Open file for user usethis::edit_file(path) return(invisible(normalizePath(path, mustWork = FALSE))) - } diff --git a/R/mk_endpoint_str.R b/R/mk_endpoint_str.R index 549a842..5a81dd6 100644 --- a/R/mk_endpoint_str.R +++ b/R/mk_endpoint_str.R @@ -49,43 +49,43 @@ mk_endpoint_str <- function(study_metadata = NULL, if (!is.function(data_prepare)) { stop("Argument 'data_prepare' needs to be an unquoted function name") } - data_prepare <- substitute(list(data_prepare)) + data_prepare <- substitute(list(data_prepare)) if (is.function(crit_endpoint)) { crit_endpoint <- substitute(list(crit_endpoint)) - } else{ + } else { crit_endpoint <- substitute(crit_endpoint) } if (is.function(crit_by_strata_across_trt)) { crit_by_strata_across_trt <- substitute(list(crit_by_strata_across_trt)) - } else{ + } else { crit_by_strata_across_trt <- substitute(crit_by_strata_across_trt) } if (is.function(crit_by_strata_by_trt)) { crit_by_strata_by_trt <- substitute(list(crit_by_strata_by_trt)) - } else{ + } else { crit_by_strata_by_trt <- substitute(crit_by_strata_by_trt) } if (is.function(stat_by_strata_by_trt)) { stat_by_strata_by_trt <- substitute(list(stat_by_strata_by_trt)) - } else{ + } else { stat_by_strata_by_trt <- substitute(stat_by_strata_by_trt) } if (is.function(stat_by_strata_across_trt)) { stat_by_strata_across_trt <- substitute(list(stat_by_strata_across_trt)) - } else{ + } else { stat_by_strata_across_trt <- substitute(stat_by_strata_across_trt) } if (is.function(stat_across_strata_across_trt)) { stat_across_strata_across_trt <- substitute(list(stat_across_strata_across_trt)) - } else{ + } else { stat_across_strata_across_trt <- substitute(stat_across_strata_across_trt) } @@ -104,7 +104,7 @@ mk_endpoint_str <- function(study_metadata = NULL, treatment_refval = treatment_refval, period_var = period_var, period_value = period_value, - custom_pop_filter=custom_pop_filter, + custom_pop_filter = custom_pop_filter, endpoint_filter = endpoint_filter, group_by = group_by, stratify_by = stratify_by, diff --git a/R/mk_filtered_endpoint_dt.R b/R/mk_filtered_endpoint_dt.R index da8798a..8f7ba4e 100644 --- a/R/mk_filtered_endpoint_dt.R +++ b/R/mk_filtered_endpoint_dt.R @@ -8,14 +8,13 @@ #' #' @export #' -apply_dt_filter <- function(adam_dt, filter_string, type=c("filter", "flag")) { +apply_dt_filter <- function(adam_dt, filter_string, type = c("filter", "flag")) { type <- match.arg(type) - if(type=="filter"){ + if (type == "filter") { return(adam_dt[eval(parse(text = filter_string))]) } out <- copy(adam_dt) - out[, event_flag:=FALSE] - out[eval(parse(text = filter_string)), event_flag :=TRUE] + out[, event_flag := FALSE] + out[eval(parse(text = filter_string)), event_flag := TRUE] return(out) - } diff --git a/R/mk_userdef_fn_dt.R b/R/mk_userdef_fn_dt.R index c30f164..e3b4f8f 100644 --- a/R/mk_userdef_fn_dt.R +++ b/R/mk_userdef_fn_dt.R @@ -27,20 +27,20 @@ #' #' @export #' -mk_userdef_fn_dt <- function(x, env=parent.frame()){ - +mk_userdef_fn_dt <- function(x, env = parent.frame()) { # Take only the unique rows based on the hash. - unique_hash_table <- unique(x, by="fn_hash") + unique_hash_table <- unique(x, by = "fn_hash") # Run the function over all rows functions_table <- unique_hash_table[, - generate_function_table_row(fn_type, fn, fn_name, fn_hash, env), - by=seq_len(nrow(unique_hash_table))] + generate_function_table_row(fn_type, fn, fn_name, fn_hash, env), + by = seq_len(nrow(unique_hash_table)) + ] # Validate functions by their expected inputs. functions_table[, - validate_usr_fn_args(fn=fn_callable[[1]], fn_type = fn_type, fn_name = fn_name), - by=seq_len(nrow(functions_table)) + validate_usr_fn_args(fn = fn_callable[[1]], fn_type = fn_type, fn_name = fn_name), + by = seq_len(nrow(functions_table)) ] # Drop the column used for the running. @@ -64,10 +64,8 @@ mk_userdef_fn_dt <- function(x, env=parent.frame()){ #' @param env The environment in which to evaluate the function. #' #' @return A `data.table` row with the function's details. -generate_function_table_row <- function(fn_type, fn, fn_name, fn_hash, env){ - - - if (is.null(fn[[1]])){ +generate_function_table_row <- function(fn_type, fn, fn_name, fn_hash, env) { + if (is.null(fn[[1]])) { out_row <- data.table::data.table( fn_type = as.character(fn_type), fn_hash = fn_hash, @@ -78,12 +76,12 @@ generate_function_table_row <- function(fn_type, fn, fn_name, fn_hash, env){ return(out_row) } out_row <- data.table::data.table( - fn_type = as.character(fn_type), - fn_hash = fn_hash, - fn_name = fn_name, - fn_call_char = as.character(fn), - fn_callable = parse_function_input(eval(fn[[1]], envir = env)) - ) + fn_type = as.character(fn_type), + fn_hash = fn_hash, + fn_name = fn_name, + fn_call_char = as.character(fn), + fn_callable = parse_function_input(eval(fn[[1]], envir = env)) + ) return(out_row) } diff --git a/R/parse_function_inputs.R b/R/parse_function_inputs.R index 94c9d44..f5a7e5b 100644 --- a/R/parse_function_inputs.R +++ b/R/parse_function_inputs.R @@ -18,17 +18,18 @@ parse_function_input <- function(fn_input) { # returns functions with arguments wrapped in partial # Should include checks to ensure function and args are valid - if (length(fn_input) == 1){ - if(is.list(fn_input)){ + if (length(fn_input) == 1) { + if (is.list(fn_input)) { fn_input <- fn_input[[1]] } - if(!is.function(fn_input)) + if (!is.function(fn_input)) { stop("`", fn_input, "` is not a valid function") + } # check it is a function return(fn_input) } else { # Check that arguments are valid. - #... + # ... return(purrr::partial(fn_input[[1]], !!!fn_input[-1])) } diff --git a/R/prepare_for_stats.R b/R/prepare_for_stats.R index a80adfb..5bb1f01 100644 --- a/R/prepare_for_stats.R +++ b/R/prepare_for_stats.R @@ -34,8 +34,7 @@ prepare_for_stats <- function(ep, type <- match.arg(type) # Map stat function type to associated criterion variable - crit_var <- switch( - type, + crit_var <- switch(type, "stat_by_strata_by_trt" = "crit_accept_by_strata_by_trt", "stat_by_strata_across_trt" = "crit_accept_by_strata_across_trt", "stat_across_strata_across_trt" = "crit_accept_by_strata_across_trt", @@ -43,8 +42,7 @@ prepare_for_stats <- function(ep, ) # Set of columns used for slicing the population depending on the type of stat function - grouping_cols <- switch( - type, + grouping_cols <- switch(type, "stat_by_strata_by_trt" = c("strata_var", "treatment_var"), "stat_by_strata_across_trt" = c("strata_var"), "stat_across_strata_across_trt" = c("strata_var", "treatment_var"), @@ -57,15 +55,14 @@ prepare_for_stats <- function(ep, # 1) no endpoint rows are accepted by criterion # 2) no stat functions are supplied # 3) no stratum is accepted when preparing for stat_across_strata_across_trt - if(nrow(ep_accepted) == 0 | - nrow(fn_map[fn_type == type]) == 0 | - (type == "stat_across_strata_across_trt" & !any(ep_accepted[[grouping_cols[[1]]]] != "TOTAL_")) - ){ + if (nrow(ep_accepted) == 0 | + nrow(fn_map[fn_type == type]) == 0 | + (type == "stat_across_strata_across_trt" & !any(ep_accepted[[grouping_cols[[1]]]] != "TOTAL_")) + ) { return(data.table::data.table(SKIP_ = TRUE)) } if (type %in% c("stat_by_strata_by_trt", "stat_by_strata_across_trt")) { - # Expand endpoints by treatment and/or strata ep_expanded <- expand_ep_for_stats( @@ -73,7 +70,7 @@ prepare_for_stats <- function(ep, grouping_cols = grouping_cols, analysis_data_container = analysis_data_container, data_col = data_col, - id_col = id_col, + id_col = id_col, col_prefix = "stat" ) @@ -83,22 +80,24 @@ prepare_for_stats <- function(ep, # Join stat function data so that each row represent a function call ep_fn <- merge(ep_expanded, - fn_map[fn_type == type], - by = "endpoint_spec_id", - allow.cartesian = TRUE) + fn_map[fn_type == type], + by = "endpoint_spec_id", + allow.cartesian = TRUE + ) # Create unique id for stat function call ep_fn[, stat_result_id := paste(get(id_col), fn_hash, formatC(.I, width = 4, format = "d", flag = "0"), - sep = "-")] + sep = "-" + )] return(ep_fn) - } else{ - + } else { ep_fn <- merge(ep_accepted, - fn_map[fn_type == type], - by = "endpoint_spec_id", - allow.cartesian = TRUE) + fn_map[fn_type == type], + by = "endpoint_spec_id", + allow.cartesian = TRUE + ) # For stat_across_strata_across_trt we test interaction effect between treatment and strata # So Treatment ~ SEX we therefore add an empty filter and an metadata containing all the levels. @@ -107,35 +106,38 @@ prepare_for_stats <- function(ep, ep_with_data <- ep_fn[analysis_data_container] ep_sg <- ep_with_data[get(grouping_cols[1]) != "TOTAL_", ] ep_sg <- - ep_sg[, c("stat_event_exist", - "stat_metadata", - "stat_filter", - "stat_result_id", - "cell_index") := - c(TRUE, - llist(c( - list_group_and_levels(get(data_col)[[1]], get(grouping_cols[1])), - list_group_and_levels(get(data_col)[[1]], get(grouping_cols[2])) - )), - "", - paste( - get(id_col), - fn_hash, - formatC( - .I, - width = 4, - format = "d", - flag = "0" - ), - sep="-" - ), - llist(get(data_col)[[1]][["INDEX_"]])), - by = 1:nrow(ep_sg)] + ep_sg[, c( + "stat_event_exist", + "stat_metadata", + "stat_filter", + "stat_result_id", + "cell_index" + ) := + c( + TRUE, + llist(c( + list_group_and_levels(get(data_col)[[1]], get(grouping_cols[1])), + list_group_and_levels(get(data_col)[[1]], get(grouping_cols[2])) + )), + "", + paste( + get(id_col), + fn_hash, + formatC( + .I, + width = 4, + format = "d", + flag = "0" + ), + sep = "-" + ), + llist(get(data_col)[[1]][["INDEX_"]]) + ), + by = 1:nrow(ep_sg) + ] ep_sg[, (data_col) := NULL] return(ep_sg) - } - } @@ -154,11 +156,10 @@ prepare_for_stats <- function(ep, #' @noRd list_group_and_levels <- function( data, - grouping_col -){ + grouping_col) { l <- list(data[, unique(get(grouping_col))]) names(l) <- grouping_col - return (l) + return(l) } #' Expand Endpoint Data for Statistics @@ -186,40 +187,44 @@ expand_ep_for_stats <- function( analysis_data_container, data_col, id_col, - col_prefix -){ - - name_expand_col <- paste(col_prefix, "expand_spec", sep="_") + col_prefix) { + name_expand_col <- paste(col_prefix, "expand_spec", sep = "_") - ep[,"_i_" := .I] + ep[, "_i_" := .I] setkey(ep, key_analysis_data) ep_with_data <- ep[analysis_data_container, nomatch = NULL] ep_with_data[, - stat_expand_spec := llist( - define_expansion_cell_from_data( - row=.SD, - grouping_cols = grouping_cols, - data_col = data_col, - col_prefix = col_prefix - )), - by = "_i_"] + stat_expand_spec := llist( + define_expansion_cell_from_data( + row = .SD, + grouping_cols = grouping_cols, + data_col = data_col, + col_prefix = col_prefix + ) + ), + by = "_i_" + ] # We remove the clinical data, otherwise the memory usage during the unnest # step will explode - ep_with_data[, (data_col):=NULL] + ep_with_data[, (data_col) := NULL] - ep_exp <- ep_with_data %>% tidyr::unnest(col = stat_expand_spec) %>% setDT() + ep_exp <- ep_with_data %>% + tidyr::unnest(col = stat_expand_spec) %>% + setDT() setkey(ep_exp, key_analysis_data) - ep_exp[,"_i_":= .I] + ep_exp[, "_i_" := .I] ep_exp_with_data <- ep_exp[analysis_data_container, nomatch = NULL] - filter_col_name <- paste(col_prefix, "filter", sep="_") + filter_col_name <- paste(col_prefix, "filter", sep = "_") ep_exp_with_data[, cell_index := llist(create_flag(get(data_col)[[1]], - singletons = c(get(filter_col_name)[[1]]))), - by = "_i_"] + singletons = c(get(filter_col_name)[[1]]) + )), + by = "_i_" + ] ep_exp_with_data[, (data_col) := NULL] ep_exp_with_data[, "_i_" := NULL] @@ -246,37 +251,36 @@ define_expansion_cell_from_data <- function( row, grouping_cols, data_col, - col_prefix -){ - if (is.character(grouping_cols)){ + col_prefix) { + if (is.character(grouping_cols)) { grouping_cols <- c(grouping_cols) } stopifnot(all(grouping_cols %in% names(row))) # Get the actual grouping variables - grouping_col_values <- row[, .SD, .SDcols=grouping_cols] - grouping_var_list <- vector(mode="list", length(grouping_col_values)) + grouping_col_values <- row[, .SD, .SDcols = grouping_cols] + grouping_var_list <- vector(mode = "list", length(grouping_col_values)) names(grouping_var_list) <- grouping_col_values - if(row[["only_strata_with_events"]]){ - dat <- row[,get(data_col)][[1]][row[["event_index"]]] - }else{ - dat <- row[,get(data_col)][[1]] + if (row[["only_strata_with_events"]]) { + dat <- row[, get(data_col)][[1]][row[["event_index"]]] + } else { + dat <- row[, get(data_col)][[1]] } # If treatment is part of grouping then force all treatment arms to be present in the group levels - if("treatment_var" %in% grouping_cols){ - trt_arms <- data.table(unique(row[,get(data_col)][[1]][,get(row[["treatment_var"]])])) + if ("treatment_var" %in% grouping_cols) { + trt_arms <- data.table(unique(row[, get(data_col)][[1]][, get(row[["treatment_var"]])])) names(trt_arms) <- row[["treatment_var"]] - }else{ + } else { trt_arms <- NULL } exp_dt <- define_expanded_ep(x = dat, group_by = grouping_var_list, forced_group_levels = trt_arms, col_prefix = col_prefix) - return (exp_dt) + return(exp_dt) } -add_total_meta <- function(x, meta_col, total_meta){ +add_total_meta <- function(x, meta_col, total_meta) { llist(c(x[[meta_col]][[1]], total_meta)) } diff --git a/R/try_and_validate.R b/R/try_and_validate.R index 31956cd..3eaea3c 100644 --- a/R/try_and_validate.R +++ b/R/try_and_validate.R @@ -16,7 +16,7 @@ #' @export try_and_validate <- function(expr_, expr_name = NA_character_, - #TODO Allow forwarding of meaning full names. + # TODO Allow forwarding of meaning full names. debug_dir = "debug", validator = function(expr_result) { NA_character_ @@ -45,15 +45,17 @@ try_and_validate <- function(expr_, expr_result <- try(expr = expr_, silent = TRUE) if (inherits(expr_result, "try-error")) { - err_msg <- paste0("Failed to EVALUATE function with error:", - "\n ", expr_result[[1]]) - + err_msg <- paste0( + "Failed to EVALUATE function with error:", + "\n ", expr_result[[1]] + ) } else if (!is.na(validator_err <- validator(expr_result))) { - #validate output + # validate output err_msg <- paste("Failed to VALIDATE function output with error:", - validator_err, - sep = "\n") + validator_err, + sep = "\n" + ) } else { # Return valid result return(expr_result) @@ -79,8 +81,9 @@ try_and_validate <- function(expr_, # Prepare error message. full_error <- paste(sprintf("\nError during evaluation of: %s", expr_name), - err_msg, - sep = "\n") + err_msg, + sep = "\n" + ) if (!stage_debugging) { stop(full_error) @@ -106,7 +109,6 @@ try_and_validate <- function(expr_, sep = "\n" ) stop(full_error) - } @@ -142,7 +144,7 @@ stage_debug <- norm_dir <- normalizePath(debug_dir) filepath <- file.path(norm_dir, paste0(fn_name, ".Rdata")) - saveRDS(debug_env, file = filepath) #Set dynamically + saveRDS(debug_env, file = filepath) # Set dynamically return(filepath) } @@ -173,9 +175,9 @@ load_debug_session <- function(debug_file) { if (is.primitive(debug_env$fn)) { cli::cli_alert_danger( - "The inspected function ({.val {deparse(debug_env$fn)}}) is a + "The inspected function ({.val {deparse(debug_env$fn)}}) is a primitive and cannot be inspected using debugonce.\ - You can still load the debug environemnt and inspect + You can still load the debug environemnt and inspect inputs and function: readRDS({.path {debug_file}})", wrap = TRUE ) @@ -193,7 +195,7 @@ load_debug_session <- function(debug_file) { extra_libraries <- setdiff(debug_env$ns, search()) if (length(extra_libraries) > 0) { - cli::cli_alert_warning("The following libraries was available at runtime + cli::cli_alert_warning("The following libraries was available at runtime but isn't currently.") cli::cli_li(extra_libraries) } @@ -219,7 +221,7 @@ load_debug_session <- function(debug_file) { validate_crit_output <- function(output) { if (!(isTRUE(output) | isFALSE(output))) { paste( - "The return value from the endpoint criterion + "The return value from the endpoint criterion function must be a logical of length 1, i.e.", "TRUE or FALSE" ) @@ -240,8 +242,10 @@ validate_crit_output <- function(output) { validate_stat_output <- function(output) { # if not a DT return early if (!data.table::is.data.table(output)) { - err_msg <- paste0("Expected (data.table::data.table). Found: ", - class(output)) + err_msg <- paste0( + "Expected (data.table::data.table). Found: ", + class(output) + ) return(err_msg) } @@ -263,10 +267,12 @@ validate_stat_output <- function(output) { " )" ) if (length(actual_diff) > 0) { - err_msg <- paste0(err_msg, - "\n\tExtra items in actual: ( ", - paste(actual_diff, collapse = ", "), - " )") + err_msg <- paste0( + err_msg, + "\n\tExtra items in actual: ( ", + paste(actual_diff, collapse = ", "), + " )" + ) } if (length(expected_diff) > 0) { err_msg <- paste0( diff --git a/R/unnest_by_fns.R b/R/unnest_by_fns.R index 6215dd1..28d9c49 100644 --- a/R/unnest_by_fns.R +++ b/R/unnest_by_fns.R @@ -14,12 +14,12 @@ #' @export #' unnest_by_fns <- function(dt, cols) { - if(nrow(dt)==0){ + if (nrow(dt) == 0) { stop("Provided data.table to unnest was empty", call. = FALSE) } missing_cols <- setdiff(cols, colnames(dt)) - if(length(missing_cols)>0){ + if (length(missing_cols) > 0) { stop("The following columns are not found in the provided data.table to unnest:\n-", paste0(missing_cols, collapse = "\n-")) } long <- @@ -31,18 +31,18 @@ unnest_by_fns <- function(dt, cols) { variable.factor = FALSE, ) - long[, fn := purrr::map(fn_list, function(i) - as.list(i[-1]))] - long[, fn_name:=character()] + long[, fn := purrr::map(fn_list, function(i) { + as.list(i[-1]) + })] + long[, fn_name := character()] long[, fn_name := purrr::map(long$fn, function(i) { - x <- names(i) if (is.null(x)) { return(NA_character_) } return(x) })] - if(nrow(long)==1){ + if (nrow(long) == 1) { x <- long } else { x <- tidyr::unnest(long, c(fn, fn_name)) %>% as.data.table() @@ -52,22 +52,21 @@ unnest_by_fns <- function(dt, cols) { # When no fn get a name in the tidy::unnest(), the fn_name gets transformed # to a logical. This needs to be converted back to a character so names can be # assigned downstream - x[,fn_name:=as.character(fn_name)] + x[, fn_name := as.character(fn_name)] # Index rows where we have to assign function name manually. This happens # because when there is only one function provided the logic is different than # when multiple are provided inx <- x[, purrr::map_lgl(fn, is.name)] & x[, is.na(fn_name)] - x[inx==TRUE, fn_name := as.character(fn)] + x[inx == TRUE, fn_name := as.character(fn)] # For unnamed fns supplied in style of `list(c(fn, arg))` we need a different # approach inx <- x[, is.na(fn_name)] - if(length(inx)>0) { + if (length(inx) > 0) { fn_names <- vapply(x[inx, fn], function(i) { - if (length(i) == 3 && i[[1]] == "::") { return(deparse(i)) } @@ -77,5 +76,5 @@ unnest_by_fns <- function(dt, cols) { } keep <- setdiff(colnames(x), c(cols, "fn_list")) - return(x[, .SD, .SDcols=keep]) + return(x[, .SD, .SDcols = keep]) } diff --git a/R/unnest_endpoint_functions.R b/R/unnest_endpoint_functions.R index 75ea633..23d17ba 100644 --- a/R/unnest_endpoint_functions.R +++ b/R/unnest_endpoint_functions.R @@ -28,7 +28,8 @@ unnest_endpoint_functions <- function(endpoint_defs, "stat_across_strata_across_trt", "crit_endpoint", "crit_by_strata_by_trt", - "crit_by_strata_across_trt"), + "crit_by_strata_across_trt" + ), env = parent.frame()) { endpoints_long <- unnest_by_fns(endpoint_defs, fn_cols) diff --git a/R/use_chef.R b/R/use_chef.R index 27e89b7..ddcd5f3 100644 --- a/R/use_chef.R +++ b/R/use_chef.R @@ -53,7 +53,7 @@ use_chef <- mk_criteria_fn = NULL, branch_group_size = 100, env = parent.frame()) { - file_name = paste0("pipeline_", pipeline_id, ".R") + file_name <- paste0("pipeline_", pipeline_id, ".R") mk_ep_def_template <- "template-mk_endpoint_def.R" # Create directories if none exist @@ -76,8 +76,9 @@ use_chef <- pkg_file_exists <- file.exists(pkg_file_path_norm) if (!pkg_file_exists) { usethis::use_template("packages_template.R", - package = "chef", - save_as = pkg_file_path) + package = "chef", + save_as = pkg_file_path + ) } # Write the pipeline scaffold @@ -157,7 +158,6 @@ run_pipeline <- function(pipeline_id = NULL, stage_pipeline(pipeline_name = nm) targets::tar_make() - } #' Stage a {targets} pipeline so that you can work interactively with it @@ -186,5 +186,4 @@ stage_pipeline <- } Sys.setenv(TAR_PROJECT = nm) - } diff --git a/R/utils.R b/R/utils.R index b402dc2..f373026 100644 --- a/R/utils.R +++ b/R/utils.R @@ -10,6 +10,6 @@ llist <- function(...) { list(list(...)) } -str_to_sentence_base <- function(x){ +str_to_sentence_base <- function(x) { paste0(toupper(substring(x, 1, 1)), substring(x, 2)) } diff --git a/R/validate_endpoints_def.R b/R/validate_endpoints_def.R index 3f7b5fb..379c084 100644 --- a/R/validate_endpoints_def.R +++ b/R/validate_endpoints_def.R @@ -43,33 +43,31 @@ validate_endpoints_def <- function(endpoint_base) { ), call. = FALSE ) - } - validate_period_specification <- + validate_period_specification <- function(period_var, period_value) { arg_list <- list(period_var = period_var, period_value = period_value) if (!anyNA(arg_list)) { return(invisible(TRUE)) } - if (all(is.na(arg_list))){ + if (all(is.na(arg_list))) { return(invisible(TRUE)) } - missing_arg <- - arg_list[vapply(arg_list, is.na, logical(1L))] |> names() - non_missing_arg <- - arg_list[!vapply(arg_list, is.na, logical(1L))] |> names() - stop( - "`",non_missing_arg,"`", - " is supplied in the endpoint specification, but ", - "`",missing_arg,"`", - " is not. Either both need to be provided (non-`NA` values), or both need to be empty", - call. = FALSE - - ) -} + missing_arg <- + arg_list[vapply(arg_list, is.na, logical(1L))] |> names() + non_missing_arg <- + arg_list[!vapply(arg_list, is.na, logical(1L))] |> names() + stop( + "`", non_missing_arg, "`", + " is supplied in the endpoint specification, but ", + "`", missing_arg, "`", + " is not. Either both need to be provided (non-`NA` values), or both need to be empty", + call. = FALSE + ) + } validate_period_specification(endpoint_base$period_var, endpoint_base$period_value) @@ -85,13 +83,14 @@ validate_endpoints_def <- function(endpoint_base) { paste0( "The following columns in the endpoint definition data.table have the incorrect class:\n-", paste0(cli::style_bold( - missmatch$col_name), collapse = "\n-"), + missmatch$col_name + ), collapse = "\n-"), ". \n\n Please check the endpoint_definition function" ) ) } col_class_expected[grepl("data_prepare|stat_by_strata_by_trt|analysis_stats", col_name), class_nested := - "function"] + "function"] check_fn_calls(col_class_expected, endpoint_base) @@ -107,7 +106,7 @@ build_expected_col_classes <- function() { treatment_refval = "character", period_var = "character", period_value = "character", - custom_pop_filter="character", + custom_pop_filter = "character", endpoint_filter = "character", group_by = "list", group_by = "character", @@ -122,8 +121,10 @@ build_expected_col_classes <- function() { crit_by_strata_across_trt = "list", only_strata_with_events = "logical" ) - data.table::data.table(col_name = names(col_class_expected_vec), - col_class = col_class_expected_vec) + data.table::data.table( + col_name = names(col_class_expected_vec), + col_class = col_class_expected_vec + ) } build_actual_col_classes <- function(endpoint_base) { @@ -136,12 +137,15 @@ build_actual_col_classes <- function(endpoint_base) { check_fn_calls <- function(col_class_expected, ep_def) { fn_inx <- col_class_expected[class_nested == "function"] - lapply(fn_inx$col_name, function(i) - lapply(ep_def[[i]], error_not_fn, i)) + lapply(fn_inx$col_name, function(i) { + lapply(ep_def[[i]], error_not_fn, i) + }) } error_not_fn <- function(x, i) { - if(is.null(x)|| is.null(x[[1]]))return(message("No functions provided for: ", i)) + if (is.null(x) || is.null(x[[1]])) { + return(message("No functions provided for: ", i)) + } if (!is.call(x)) { stop( "The argument to ", diff --git a/R/validate_usr_fn_args.R b/R/validate_usr_fn_args.R index b36b3cf..4574fa5 100644 --- a/R/validate_usr_fn_args.R +++ b/R/validate_usr_fn_args.R @@ -59,7 +59,6 @@ validate_usr_fn_args <- function(fn, "treatment_refval", "subjectid_var" ), - stat_across_strata_across_trt = c( "dat", diff --git a/tests/testthat/helper-custom_expect.R b/tests/testthat/helper-custom_expect.R index fa2336c..da195ea 100644 --- a/tests/testthat/helper-custom_expect.R +++ b/tests/testthat/helper-custom_expect.R @@ -1,17 +1,17 @@ -expect_str_contains <- function(object, substring){ +expect_str_contains <- function(object, substring) { # Capture objet and label act <- quasi_label(rlang::enquo(object), arg = "object") # expect act$character <- as.character(object) expect( - grepl(substring, act$character, fixed=T), + grepl(substring, act$character, fixed = T), sprintf("%s Does not contain the substring\n(%s)%s\n(sub)'%s'", act$lab, act$lab, act$character, substring) ) invisible(act$character) } -expect_na_or_null <- function(object){ +expect_na_or_null <- function(object) { # Capture objet and label act <- quasi_label(rlang::enquo(object), arg = "object") @@ -39,7 +39,7 @@ expect_same_items <- function(actual, expected, ...) { exp_msg <- paste0( "Expected: (", paste(expected_sorted, collapse = ", "), ")", "\nFound: (", paste(actual_sorted, collapse = ", ") - ) + ) if (length(actual_diff) > 0) { exp_msg <- paste(exp_msg, "\nExtra items in actual:", actual_diff) } diff --git a/tests/testthat/helper-mk_adam.R b/tests/testthat/helper-mk_adam.R index d1a1237..7acf74f 100644 --- a/tests/testthat/helper-mk_adam.R +++ b/tests/testthat/helper-mk_adam.R @@ -1,41 +1,50 @@ mk_adae <- function(study_metadata) { - adsl <- data.table::as.data.table(pharmaverseadam::adsl) - adsl[, AGEGR2 := data.table::fcase(AGE < 70, "AGE < 70", - AGE >= 70, "AGE >= 70")] + adsl[, AGEGR2 := data.table::fcase( + AGE < 70, "AGE < 70", + AGE >= 70, "AGE >= 70" + )] adae <- data.table::as.data.table(pharmaverseadam::adae) adae_out <- - merge(adsl, adae[, c(setdiff(names(adae), names(adsl)), "USUBJID"), with = - F], by = "USUBJID", all = TRUE) + merge(adsl, adae[, c(setdiff(names(adae), names(adsl)), "USUBJID"), + with = + F + ], by = "USUBJID", all = TRUE) adae_out[] } mk_adex <- function(study_metadata) { - adsl <- data.table::as.data.table(pharmaverseadam::adsl) - adsl[, AGEGR2 := data.table::fcase(AGE < 70, "AGE < 70", - AGE >= 70, "AGE >= 70")] + adsl[, AGEGR2 := data.table::fcase( + AGE < 70, "AGE < 70", + AGE >= 70, "AGE >= 70" + )] adex <- pharmaverseadam::adex adex_out <- - merge(adsl, adex[, c(setdiff(names(adex), names(adsl)), "USUBJID"), with = - F], by = "USUBJID", all = TRUE) + merge(adsl, adex[, c(setdiff(names(adex), names(adsl)), "USUBJID"), + with = + F + ], by = "USUBJID", all = TRUE) adex_out[] } -mk_adcm <- function(study_metadata){ - +mk_adcm <- function(study_metadata) { adsl <- data.table::as.data.table(pharmaverseadam::adsl) - adsl[, AGEGR2 := data.table::fcase(AGE < 70, "AGE < 70", - AGE >= 70, "AGE >= 70")] + adsl[, AGEGR2 := data.table::fcase( + AGE < 70, "AGE < 70", + AGE >= 70, "AGE >= 70" + )] adcm <- data.table::as.data.table(pharmaverseadam::adcm) adcm_out <- - merge(adsl, adcm[, c(setdiff(names(adcm), names(adsl)), "USUBJID"), with = - F], by = "USUBJID", all = TRUE) + merge(adsl, adcm[, c(setdiff(names(adcm), names(adsl)), "USUBJID"), + with = + F + ], by = "USUBJID", all = TRUE) adcm_out[] } diff --git a/tests/testthat/helper-mk_ep.R b/tests/testthat/helper-mk_ep.R index a12da25..cc34e8c 100644 --- a/tests/testthat/helper-mk_ep.R +++ b/tests/testthat/helper-mk_ep.R @@ -14,13 +14,17 @@ mk_ep_0001_awaiting_data <- purrr::partial( stratify_by = list(c("SEX", "AGEGR2")), endpoint_filter = "AESEV == 'MILD'", stat_by_strata_across_trt = list(c()), - stat_by_strata_by_trt = list("n_sub" = n_sub, - "n_subev" = n_subev) + stat_by_strata_by_trt = list( + "n_sub" = n_sub, + "n_subev" = n_subev + ) ) mk_ep_0001_waiting_grps <- purrr::partial( mk_ep_0001_base, stratify_by = list(c("SEX", "AGEGR2")), - stat_by_strata_by_trt = list("n_subj" = n_sub, - "n_subev" = n_subev) + stat_by_strata_by_trt = list( + "n_subj" = n_sub, + "n_subev" = n_subev + ) ) diff --git a/tests/testthat/helper-stat_methods.R b/tests/testthat/helper-stat_methods.R index a00c05b..d69f741 100644 --- a/tests/testthat/helper-stat_methods.R +++ b/tests/testthat/helper-stat_methods.R @@ -65,7 +65,6 @@ summary_stats <- function(dat, var, var_type = c("cont", "cat"), ...) { - # Check argument var_type <- match.arg(var_type) @@ -138,7 +137,6 @@ contingency2x2_ptest <- function(dat, cell_index, treatment_var, ...) { - # Test a 2x2 contingency table ie. is there a link between treatment and total number of events dat_cell <- dat[J(cell_index), ] dat_cell[, is_event := INDEX_ %in% event_index] @@ -171,7 +169,6 @@ contingency2x2_strata_test <- function(dat, treatment_var, subjectid_var, ...) { - # Test a 2x2 contingency table i.e. is there a link between treatment and # patients with events over multiple strata dt_unique_subjects <- dat %>% diff --git a/tests/testthat/test-add_event_index.R b/tests/testthat/test-add_event_index.R index 4392485..9dd3461 100644 --- a/tests/testthat/test-add_event_index.R +++ b/tests/testthat/test-add_event_index.R @@ -13,14 +13,16 @@ test_that("base case: add_event_index works", { custom_pop_filter = NA, key_analysis_data = "a" ) - dat = data.table(dat = list(mk_adae() %>% .[, "INDEX_" := .I]), - key_analysis_data = "a") + dat <- data.table( + dat = list(mk_adae() %>% .[, "INDEX_" := .I]), + key_analysis_data = "a" + ) setkey(ep, key_analysis_data) setkey(dat, key_analysis_data) # ACT --------------------------------------------------------------------- actual <- add_event_index(ep = ep, analysis_data_container = dat) # EXPECT ------------------------------------------------------------------ - expect_equal(actual$event_index[[1]], dat$dat[[1]][SAFFL == "Y" ][["INDEX_"]]) + expect_equal(actual$event_index[[1]], dat$dat[[1]][SAFFL == "Y"][["INDEX_"]]) }) @@ -40,54 +42,56 @@ test_that("add_event_index works with period_var", { custom_pop_filter = NA, key_analysis_data = "a" ) - dat = data.table(dat = list(mk_adcm() %>% .[, "INDEX_" := .I]), - key_analysis_data = "a") + dat <- data.table( + dat = list(mk_adcm() %>% .[, "INDEX_" := .I]), + key_analysis_data = "a" + ) setkey(ep, key_analysis_data) setkey(dat, key_analysis_data) # ACT --------------------------------------------------------------------- actual <- add_event_index(ep = ep, analysis_data_container = dat) # EXPECT ------------------------------------------------------------------ expect_equal(actual$event_index[[1]], dat$dat[[1]][SAFFL == "Y" & - ANL01FL == "Y"][["INDEX_"]]) + ANL01FL == "Y"][["INDEX_"]]) }) -test_that("add_event_index works over multiple rows in ep with custom filter", - { - # SETUP ------------------------------------------------------------------- - ep <- data.table( - pop_var = "SAFFL", - pop_value = "Y", - treatment_var = "TRT01A", - treatment_refval = "Xanomeline High Dose", - period_var = NA_character_, - period_value = NA_character_, - endpoint_id = 1, - endpoint_filter = NA, - endpoint_group_filter = NA, - custom_pop_filter = "AGE >70", - dat = list(mk_adcm() %>% .[, "INDEX_" := .I]), - key_analysis_data = "a" - ) - dat = data.table(dat = list(mk_adcm() %>% .[, "INDEX_" := .I]), - key_analysis_data = "a") - - setkey(dat, key_analysis_data) - ep <- rbindlist(list(ep, ep)) - setkey(ep, key_analysis_data) - ep[2, `:=` (custom_pop_filter = "AGE <=70", endpoint_id = 2)] - - # ACT --------------------------------------------------------------------- - actual <- add_event_index(ep = ep, dat) - - # EXPECT ------------------------------------------------------------------ - - expect_equal(actual$event_index[[1]], dat$dat[[1]][SAFFL == "Y" & - AGE > 70][["INDEX_"]]) - expect_equal(actual$event_index[[2]], dat$dat[[1]][SAFFL == "Y" & - AGE <= 70][["INDEX_"]]) - - }) +test_that("add_event_index works over multiple rows in ep with custom filter", { + # SETUP ------------------------------------------------------------------- + ep <- data.table( + pop_var = "SAFFL", + pop_value = "Y", + treatment_var = "TRT01A", + treatment_refval = "Xanomeline High Dose", + period_var = NA_character_, + period_value = NA_character_, + endpoint_id = 1, + endpoint_filter = NA, + endpoint_group_filter = NA, + custom_pop_filter = "AGE >70", + dat = list(mk_adcm() %>% .[, "INDEX_" := .I]), + key_analysis_data = "a" + ) + dat <- data.table( + dat = list(mk_adcm() %>% .[, "INDEX_" := .I]), + key_analysis_data = "a" + ) + + setkey(dat, key_analysis_data) + ep <- rbindlist(list(ep, ep)) + setkey(ep, key_analysis_data) + ep[2, `:=`(custom_pop_filter = "AGE <=70", endpoint_id = 2)] + + # ACT --------------------------------------------------------------------- + actual <- add_event_index(ep = ep, dat) + + # EXPECT ------------------------------------------------------------------ + + expect_equal(actual$event_index[[1]], dat$dat[[1]][SAFFL == "Y" & + AGE > 70][["INDEX_"]]) + expect_equal(actual$event_index[[2]], dat$dat[[1]][SAFFL == "Y" & + AGE <= 70][["INDEX_"]]) +}) test_that("add_event_index works over expanded endpoints", { @@ -104,8 +108,10 @@ test_that("add_event_index works over expanded endpoints", { fn_map <- merge(ep_fn_map[, .(endpoint_spec_id, fn_hash)], user_def_fn, by = "fn_hash") adam_db <- - fetch_db_data(study_metadata = list(), - fn_dt = user_def_fn) + fetch_db_data( + study_metadata = list(), + fn_dt = user_def_fn + ) ep_and_data <- filter_db_data(ep, ep_fn_map, adam_db) ep_expanded <- expand_over_endpoints(ep = ep_and_data$ep, ep_and_data$analysis_data_container) @@ -116,16 +122,19 @@ test_that("add_event_index works over expanded endpoints", { # EXPECT ------------------------------------------------------------------ for (i in 1:nrow(actual)) { - expect_equal(actual$event_index[[i]], - ep_and_data$analysis_data_container$dat[[1]][SAFFL == "Y" & - eval(parse(text = - actual$endpoint_group_filter[[i]]))][["INDEX_"]]) + expect_equal( + actual$event_index[[i]], + ep_and_data$analysis_data_container$dat[[1]][SAFFL == "Y" & + eval(parse( + text = + actual$endpoint_group_filter[[i]] + ))][["INDEX_"]] + ) } }) -test_that("add_event_index works over expanded endpoints with endpoint filter", -{ +test_that("add_event_index works over expanded endpoints with endpoint filter", { # SETUP ------------------------------------------------------------------- testr::skip_on_devops() ep <- mk_ep_0001_base( @@ -140,8 +149,10 @@ test_that("add_event_index works over expanded endpoints with endpoint filter", fn_map <- merge(ep_fn_map[, .(endpoint_spec_id, fn_hash)], user_def_fn, by = "fn_hash") adam_db <- - fetch_db_data(study_metadata = list(), - fn_dt = user_def_fn) + fetch_db_data( + study_metadata = list(), + fn_dt = user_def_fn + ) ep_and_data <- filter_db_data(ep, ep_fn_map, adam_db) ep_expanded <- expand_over_endpoints(ep = ep_and_data$ep, ep_and_data$analysis_data_container) @@ -152,10 +163,14 @@ test_that("add_event_index works over expanded endpoints with endpoint filter", # EXPECT ------------------------------------------------------------------ for (i in 1:nrow(actual)) { - expect_equal(actual$event_index[[i]], - ep_and_data$analysis_data_container$dat[[1]][SAFFL == "Y" & - RACE %in% c("BLACK OR AFRICAN AMERICAN", "WHITE") & - eval(parse(text = - actual$endpoint_group_filter[[i]]))][["INDEX_"]]) + expect_equal( + actual$event_index[[i]], + ep_and_data$analysis_data_container$dat[[1]][SAFFL == "Y" & + RACE %in% c("BLACK OR AFRICAN AMERICAN", "WHITE") & + eval(parse( + text = + actual$endpoint_group_filter[[i]] + ))][["INDEX_"]] + ) } }) diff --git a/tests/testthat/test-apply_criterion_by_strata.R b/tests/testthat/test-apply_criterion_by_strata.R index 8f40ecd..021f19b 100644 --- a/tests/testthat/test-apply_criterion_by_strata.R +++ b/tests/testthat/test-apply_criterion_by_strata.R @@ -526,9 +526,9 @@ test_that("strata_var remains a character variable when some endpoint have been # ACT --------------------------------------------------------------------- actual <- apply_criterion_by_strata(ep, - analysis_data_container, - fn_map, - type = "by_strata_by_trt" + analysis_data_container, + fn_map, + type = "by_strata_by_trt" ) # EXPECT ------------------------------------------------------------------ @@ -541,5 +541,4 @@ test_that("strata_var remains a character variable when some endpoint have been # Check that the column type is correct expect_equal(typeof(actual[["strata_var"]]), "character") - }) diff --git a/tests/testthat/test-apply_criterion_endpoint.R b/tests/testthat/test-apply_criterion_endpoint.R index f0d996f..6633fa5 100644 --- a/tests/testthat/test-apply_criterion_endpoint.R +++ b/tests/testthat/test-apply_criterion_endpoint.R @@ -1,5 +1,4 @@ -test_that("base endpoint crit works", -{ +test_that("base endpoint crit works", { # SETUP ------------------------------------------------------------------- crit_endpoint <- function(dat, event_index, @@ -26,8 +25,10 @@ test_that("base endpoint crit works", fn_map <- merge(ep_fn_map[, .(endpoint_spec_id, fn_hash)], user_def_fn, by = "fn_hash") adam_db <- - fetch_db_data(study_metadata = list(), - fn_dt = user_def_fn) + fetch_db_data( + study_metadata = list(), + fn_dt = user_def_fn + ) ep_and_data <- filter_db_data(ep, ep_fn_map, adam_db) ep_data_key <- ep_and_data$ep @@ -46,8 +47,7 @@ test_that("base endpoint crit works", expect_equal(nrow(actual), nrow(ep)) }) -test_that("base endpoint crit works with multiple endpoints", -{ +test_that("base endpoint crit works with multiple endpoints", { # SETUP ------------------------------------------------------------------- crit_endpoint <- function(dat, event_index, @@ -75,8 +75,10 @@ test_that("base endpoint crit works with multiple endpoints", fn_map <- merge(ep_fn_map[, .(endpoint_spec_id, fn_hash)], user_def_fn, by = "fn_hash") adam_db <- - fetch_db_data(study_metadata = list(), - fn_dt = user_def_fn) + fetch_db_data( + study_metadata = list(), + fn_dt = user_def_fn + ) ep_and_data <- filter_db_data(ep, ep_fn_map, adam_db) ep_data_key <- ep_and_data$ep @@ -99,8 +101,7 @@ test_that("base endpoint crit works with multiple endpoints", }) -test_that("base endpoint crit works with naked function", -{ +test_that("base endpoint crit works with naked function", { # SETUP ------------------------------------------------------------------- crit_endpoint <- function(dat, event_index, @@ -127,8 +128,10 @@ test_that("base endpoint crit works with naked function", fn_map <- merge(ep_fn_map[, .(endpoint_spec_id, fn_hash)], user_def_fn, by = "fn_hash") adam_db <- - fetch_db_data(study_metadata = list(), - fn_dt = user_def_fn) + fetch_db_data( + study_metadata = list(), + fn_dt = user_def_fn + ) ep_and_data <- filter_db_data(ep, ep_fn_map, adam_db) ep_data_key <- ep_and_data$ep @@ -151,8 +154,7 @@ test_that("base endpoint crit works with naked function", }) -test_that("crit fn has access to correct data from chef", -{ +test_that("crit fn has access to correct data from chef", { # SETUP ------------------------------------------------------------------- @@ -170,9 +172,9 @@ test_that("crit fn has access to correct data from chef", endpoint_group_metadata, stratify_by, subjectid_var) { - out <- all( + out <- all( nrow(dat) == 7535, - #Same as nrows in filter adam data, + # Same as nrows in filter adam data, inherits(event_index, "integer"), is.na(endpoint_group_metadata), treatment_var == "TRT01A" @@ -194,8 +196,10 @@ test_that("crit fn has access to correct data from chef", fn_map <- merge(ep_fn_map[, .(endpoint_spec_id, fn_hash)], user_def_fn, by = "fn_hash") adam_db <- - fetch_db_data(study_metadata = list(), - fn_dt = user_def_fn) + fetch_db_data( + study_metadata = list(), + fn_dt = user_def_fn + ) ep_and_data <- filter_db_data(ep, ep_fn_map, adam_db) ep_data_key <- ep_and_data$ep analysis_data_container <- ep_and_data$analysis_data_container @@ -215,8 +219,7 @@ test_that("crit fn has access to correct data from chef", expect_true(actual$crit_accept_endpoint, label = "If this fails, check expectations inside crit_endpoint function") }) -test_that("error when crit fn does not return a logical value", -{ +test_that("error when crit fn does not return a logical value", { # SETUP ------------------------------------------------------------------- crit_endpoint <- function(dat, event_index, @@ -245,8 +248,10 @@ test_that("error when crit fn does not return a logical value", fn_map <- merge(ep_fn_map[, .(endpoint_spec_id, fn_hash)], user_def_fn, by = "fn_hash") adam_db <- - fetch_db_data(study_metadata = list(), - fn_dt = user_def_fn) + fetch_db_data( + study_metadata = list(), + fn_dt = user_def_fn + ) ep_and_data <- filter_db_data(ep, ep_fn_map, adam_db) ep_data_key <- ep_and_data$ep @@ -261,5 +266,6 @@ test_that("error when crit fn does not return a logical value", # EXPECT ------------------------------------------------------------------ expect_error(apply_criterion_endpoint(ep_ev_index, analysis_data_container, fn_map), - regexp = "The return value from the endpoint criterion function") + regexp = "The return value from the endpoint criterion function" + ) }) diff --git a/tests/testthat/test-apply_dt_filter.R b/tests/testthat/test-apply_dt_filter.R index 7d39d4a..d222101 100644 --- a/tests/testthat/test-apply_dt_filter.R +++ b/tests/testthat/test-apply_dt_filter.R @@ -1,35 +1,36 @@ -test_that('Applying filter works on low level', - { - # SETUP ------------------------------------------------------------------- - +test_that("Applying filter works on low level", { + # SETUP ------------------------------------------------------------------- - filter_str1 <- glue::glue("k2 == \"b\"") - filter_str2 <- glue::glue("k2 == \"a\" & k1 >= 5") - new_dt <- data.table::data.table(k1 = c(1, 2, 3, 4, 5), - k2 = c("a", "a", "b", "b", "a")) + filter_str1 <- glue::glue("k2 == \"b\"") + filter_str2 <- glue::glue("k2 == \"a\" & k1 >= 5") - # ACT --------------------------------------------------------------------- - out1 <- apply_dt_filter(new_dt, filter_str1) - out2 <- apply_dt_filter(new_dt, filter_str2) + new_dt <- data.table::data.table( + k1 = c(1, 2, 3, 4, 5), + k2 = c("a", "a", "b", "b", "a") + ) + # ACT --------------------------------------------------------------------- + out1 <- apply_dt_filter(new_dt, filter_str1) + out2 <- apply_dt_filter(new_dt, filter_str2) - # EXPECT ------------------------------------------------------------------ - expect_setequal(out1$k1, c(3, 4)) - expect_setequal(out2$k1, c(5)) + # EXPECT ------------------------------------------------------------------ + expect_setequal(out1$k1, c(3, 4)) + expect_setequal(out2$k1, c(5)) }) -test_that('Applying flags works on low level', -{ +test_that("Applying flags works on low level", { # SETUP ------------------------------------------------------------------- filter_str1 <- glue::glue("k2 == \"b\"") filter_str2 <- glue::glue("k2 == \"a\" & k1 >= 5") - new_dt <- data.table::data.table(k1 = c(1, 2, 3, 4, 5), - k2 = c("a", "a", "b", "b", "a")) + new_dt <- data.table::data.table( + k1 = c(1, 2, 3, 4, 5), + k2 = c("a", "a", "b", "b", "a") + ) # ACT --------------------------------------------------------------------- out1 <- apply_dt_filter(new_dt, filter_str1, type = "flag") @@ -38,22 +39,19 @@ test_that('Applying flags works on low level', # EXPECT ------------------------------------------------------------------ expect_setequal(out1$event_flag, c(FALSE, FALSE, TRUE, TRUE, FALSE)) expect_setequal(out2$event_flag, c(rep(FALSE, 5), TRUE)) - }) -test_that("Applying a simple filter works on adam level", -{ +test_that("Applying a simple filter works on adam level", { # SETUP ------------------------------------------------------------------- adam <- mk_adae() - age_max = min(adam$AGE) + 2 - filter_str = glue::glue("AGE <={age_max}") + age_max <- min(adam$AGE) + 2 + filter_str <- glue::glue("AGE <={age_max}") # ACT --------------------------------------------------------------------- out <- apply_dt_filter(adam, filter_str) # EXPECT ------------------------------------------------------------------ expect_lte(max(out$AGE), expected = age_max) - }) diff --git a/tests/testthat/test-apply_stats.R b/tests/testthat/test-apply_stats.R index 0044ca2..571cbab 100644 --- a/tests/testthat/test-apply_stats.R +++ b/tests/testthat/test-apply_stats.R @@ -1,82 +1,80 @@ -test_that("base: stat_by_strata_by_trt", - { - # SETUP ------------------------------------------------------------------- - - skip_on_devops() - ep <- mk_ep_0001_base( - stratify_by = list(c("SEX")), - data_prepare = mk_adcm, - stat_by_strata_by_trt = list(n_sub = n_sub) - ) - - ep <- add_id(ep) - ep_fn_map <- - suppressWarnings(unnest_endpoint_functions(ep)) - - user_def_fn <- - mk_userdef_fn_dt(ep_fn_map, env = environment()) - - fn_map <- - merge(ep_fn_map[, .(endpoint_spec_id, fn_hash)], user_def_fn, by = "fn_hash") - adam_db <- - fetch_db_data( - study_metadata = list(), - fn_dt = user_def_fn - ) - ep_and_data <- filter_db_data(ep, ep_fn_map, adam_db) - ep_data_key <- ep_and_data$ep - analysis_data_container <- - ep_and_data$analysis_data_container - ep_expanded <- - expand_over_endpoints(ep_data_key, analysis_data_container) - ep_ev_index <- - add_event_index(ep_expanded, analysis_data_container) - ep_crit_endpoint <- - apply_criterion_endpoint(ep_ev_index, analysis_data_container, fn_map) - crit_accept_by_strata_by_trt <- - apply_criterion_by_strata(ep_crit_endpoint, - analysis_data_container, - fn_map, - type = "by_strata_by_trt") - crit_accept_by_strata_across_trt <- - apply_criterion_by_strata(crit_accept_by_strata_by_trt, - analysis_data_container, - fn_map, - type = "by_strata_across_trt") - - ep_crit_by_strata_by_trt <- prepare_for_stats( - crit_accept_by_strata_across_trt, +test_that("base: stat_by_strata_by_trt", { + # SETUP ------------------------------------------------------------------- + + skip_on_devops() + ep <- mk_ep_0001_base( + stratify_by = list(c("SEX")), + data_prepare = mk_adcm, + stat_by_strata_by_trt = list(n_sub = n_sub) + ) + + ep <- add_id(ep) + ep_fn_map <- + suppressWarnings(unnest_endpoint_functions(ep)) + + user_def_fn <- + mk_userdef_fn_dt(ep_fn_map, env = environment()) + + fn_map <- + merge(ep_fn_map[, .(endpoint_spec_id, fn_hash)], user_def_fn, by = "fn_hash") + adam_db <- + fetch_db_data( + study_metadata = list(), + fn_dt = user_def_fn + ) + ep_and_data <- filter_db_data(ep, ep_fn_map, adam_db) + ep_data_key <- ep_and_data$ep + analysis_data_container <- + ep_and_data$analysis_data_container + ep_expanded <- + expand_over_endpoints(ep_data_key, analysis_data_container) + ep_ev_index <- + add_event_index(ep_expanded, analysis_data_container) + ep_crit_endpoint <- + apply_criterion_endpoint(ep_ev_index, analysis_data_container, fn_map) + crit_accept_by_strata_by_trt <- + apply_criterion_by_strata(ep_crit_endpoint, analysis_data_container, fn_map, - type = "stat_by_strata_by_trt" + type = "by_strata_by_trt" + ) + crit_accept_by_strata_across_trt <- + apply_criterion_by_strata(crit_accept_by_strata_by_trt, + analysis_data_container, + fn_map, + type = "by_strata_across_trt" ) - # ACT --------------------------------------------------------------------- - - actual <- - apply_stats(ep_crit_by_strata_by_trt, - analysis_data_container, - type = "stat_by_strata_by_trt") + ep_crit_by_strata_by_trt <- prepare_for_stats( + crit_accept_by_strata_across_trt, + analysis_data_container, + fn_map, + type = "stat_by_strata_by_trt" + ) - # EXPECT ------------------------------------------------------------------ + # ACT --------------------------------------------------------------------- - expect_equal(nrow(actual), 9) - expect_equal(setdiff(names(actual), names(ep_crit_by_strata_by_trt)), "stat_result") + actual <- + apply_stats(ep_crit_by_strata_by_trt, + analysis_data_container, + type = "stat_by_strata_by_trt" + ) - for (i in 1:nrow(actual)){ - stats <- actual[["stat_result"]][[i]] - expect_true(is.data.table(stats)) - expect_equal(nrow(stats), 1) - expect_same_items(names(stats), c( "label", "description", "qualifiers", "value")) - } + # EXPECT ------------------------------------------------------------------ + expect_equal(nrow(actual), 9) + expect_equal(setdiff(names(actual), names(ep_crit_by_strata_by_trt)), "stat_result") + for (i in 1:nrow(actual)) { + stats <- actual[["stat_result"]][[i]] + expect_true(is.data.table(stats)) + expect_equal(nrow(stats), 1) + expect_same_items(names(stats), c("label", "description", "qualifiers", "value")) + } }) -test_that("validate: by_strata_by_trt returns same value as manual calculation with period flag", -{ - +test_that("validate: by_strata_by_trt returns same value as manual calculation with period flag", { # SETUP ------------------------------------------------------------------- skip_on_devops() ep <- mk_ep_0001_base( @@ -114,14 +112,16 @@ test_that("validate: by_strata_by_trt returns same value as manual calculation w apply_criterion_endpoint(ep_ev_index, analysis_data_container, fn_map) crit_accept_by_strata_by_trt <- apply_criterion_by_strata(ep_crit_endpoint, - analysis_data_container, - fn_map, - type = "by_strata_by_trt") + analysis_data_container, + fn_map, + type = "by_strata_by_trt" + ) crit_accept_by_strata_across_trt <- apply_criterion_by_strata(crit_accept_by_strata_by_trt, - analysis_data_container, - fn_map, - type = "by_strata_across_trt") + analysis_data_container, + fn_map, + type = "by_strata_across_trt" + ) ep_crit_by_strata_by_trt <- prepare_for_stats( crit_accept_by_strata_across_trt, @@ -134,12 +134,13 @@ test_that("validate: by_strata_by_trt returns same value as manual calculation w # ACT --------------------------------------------------------------------- actual <- apply_stats(ep_crit_by_strata_by_trt, - analysis_data_container, - type = "stat_by_strata_by_trt") + analysis_data_container, + type = "stat_by_strata_by_trt" + ) # EXPECT ------------------------------------------------------------------ expected_counts <- pharmaverseadam::adcm %>% - as.data.table() %>% + as.data.table() %>% .[SAFFL == "Y" & ANL01FL == "Y" & AOCCPFL == "Y"] %>% unique(., by = c("SUBJID")) %>% .[, .N, by = TRT01A] %>% @@ -152,170 +153,169 @@ test_that("validate: by_strata_by_trt returns same value as manual calculation w .[["value"]] expect_equal(actual_counts, expected_counts, label = "Event counts match") - }) -test_that("by_strata_by_trt returns same value as manual calculation without period flag", - { - - # SETUP ------------------------------------------------------------------- - skip_on_devops() - ep <- mk_ep_0001_base( - stratify_by = list(c("SEX")), - data_prepare = mk_adcm, - endpoint_filter = "AOCCPFL=='Y'", - stat_by_strata_by_trt = list(n_subev = n_subev), - period_var = "ANL01FL", - period_value = "Y" - ) - - ep <- add_id(ep) - ep_fn_map <- - suppressWarnings(unnest_endpoint_functions(ep)) - - user_def_fn <- - mk_userdef_fn_dt(ep_fn_map, env = environment()) - - fn_map <- - merge(ep_fn_map[, .(endpoint_spec_id, fn_hash)], user_def_fn, by = "fn_hash") - adam_db <- - fetch_db_data( - study_metadata = list(), - fn_dt = user_def_fn - ) - ep_and_data <- filter_db_data(ep, ep_fn_map, adam_db) - ep_data_key <- ep_and_data$ep - analysis_data_container <- - ep_and_data$analysis_data_container - ep_expanded <- - expand_over_endpoints(ep_data_key, analysis_data_container) - ep_ev_index <- - add_event_index(ep_expanded, analysis_data_container) - ep_crit_endpoint <- - apply_criterion_endpoint(ep_ev_index, analysis_data_container, fn_map) - crit_accept_by_strata_by_trt <- - apply_criterion_by_strata(ep_crit_endpoint, - analysis_data_container, - fn_map, - type = "by_strata_by_trt") - crit_accept_by_strata_across_trt <- - apply_criterion_by_strata(crit_accept_by_strata_by_trt, - analysis_data_container, - fn_map, - type = "by_strata_across_trt") - - ep_crit_by_strata_by_trt <- prepare_for_stats( - crit_accept_by_strata_across_trt, - analysis_data_container, - fn_map, - type = "stat_by_strata_by_trt" - ) - - - # ACT --------------------------------------------------------------------- - actual <- - apply_stats(ep_crit_by_strata_by_trt, - analysis_data_container, - type = "stat_by_strata_by_trt") - - # EXPECT ------------------------------------------------------------------ - expected_counts <- pharmaverseadam::adcm %>% - as.data.table() %>% - .[SAFFL == "Y" & AOCCPFL == "Y"] %>% - unique(., by = c("SUBJID")) %>% - .[, .N, by = TRT01A] %>% - .[["N"]] - - actual_counts <- - actual[strata_var == "TOTAL_" & fn_name == "n_subev"] %>% - .[, stat_result] %>% - rbindlist() %>% - .[["value"]] - - expect_equal(actual_counts, expected_counts, label = "Event counts match") - - }) - - -test_that("validate: n_sub return correct value", - { - - # SETUP ------------------------------------------------------------------- - skip_on_devops() - ep <- mk_ep_0001_base( - stratify_by = list(c("SEX")), - data_prepare = mk_adcm, - stat_by_strata_by_trt = list(n_sub = n_sub) - ) - - ep <- add_id(ep) - ep_fn_map <- - suppressWarnings(unnest_endpoint_functions(ep)) - - user_def_fn <- - mk_userdef_fn_dt(ep_fn_map, env = environment()) - - fn_map <- - merge(ep_fn_map[, .(endpoint_spec_id, fn_hash)], user_def_fn, by = "fn_hash") - adam_db <- - fetch_db_data( - study_metadata = list(), - fn_dt = user_def_fn - ) - ep_and_data <- filter_db_data(ep, ep_fn_map, adam_db) - ep_data_key <- ep_and_data$ep - analysis_data_container <- - ep_and_data$analysis_data_container - ep_expanded <- - expand_over_endpoints(ep_data_key, analysis_data_container) - ep_ev_index <- - add_event_index(ep_expanded, analysis_data_container) - ep_crit_endpoint <- - apply_criterion_endpoint(ep_ev_index, analysis_data_container, fn_map) - crit_accept_by_strata_by_trt <- - apply_criterion_by_strata(ep_crit_endpoint, - analysis_data_container, - fn_map, - type = "by_strata_by_trt") - crit_accept_by_strata_across_trt <- - apply_criterion_by_strata(crit_accept_by_strata_by_trt, - analysis_data_container, - fn_map, - type = "by_strata_across_trt") - - ep_crit_by_strata_by_trt <- prepare_for_stats( - crit_accept_by_strata_across_trt, +test_that("by_strata_by_trt returns same value as manual calculation without period flag", { + # SETUP ------------------------------------------------------------------- + skip_on_devops() + ep <- mk_ep_0001_base( + stratify_by = list(c("SEX")), + data_prepare = mk_adcm, + endpoint_filter = "AOCCPFL=='Y'", + stat_by_strata_by_trt = list(n_subev = n_subev), + period_var = "ANL01FL", + period_value = "Y" + ) + + ep <- add_id(ep) + ep_fn_map <- + suppressWarnings(unnest_endpoint_functions(ep)) + + user_def_fn <- + mk_userdef_fn_dt(ep_fn_map, env = environment()) + + fn_map <- + merge(ep_fn_map[, .(endpoint_spec_id, fn_hash)], user_def_fn, by = "fn_hash") + adam_db <- + fetch_db_data( + study_metadata = list(), + fn_dt = user_def_fn + ) + ep_and_data <- filter_db_data(ep, ep_fn_map, adam_db) + ep_data_key <- ep_and_data$ep + analysis_data_container <- + ep_and_data$analysis_data_container + ep_expanded <- + expand_over_endpoints(ep_data_key, analysis_data_container) + ep_ev_index <- + add_event_index(ep_expanded, analysis_data_container) + ep_crit_endpoint <- + apply_criterion_endpoint(ep_ev_index, analysis_data_container, fn_map) + crit_accept_by_strata_by_trt <- + apply_criterion_by_strata(ep_crit_endpoint, analysis_data_container, fn_map, + type = "by_strata_by_trt" + ) + crit_accept_by_strata_across_trt <- + apply_criterion_by_strata(crit_accept_by_strata_by_trt, + analysis_data_container, + fn_map, + type = "by_strata_across_trt" + ) + + ep_crit_by_strata_by_trt <- prepare_for_stats( + crit_accept_by_strata_across_trt, + analysis_data_container, + fn_map, + type = "stat_by_strata_by_trt" + ) + + + # ACT --------------------------------------------------------------------- + actual <- + apply_stats(ep_crit_by_strata_by_trt, + analysis_data_container, type = "stat_by_strata_by_trt" ) + # EXPECT ------------------------------------------------------------------ + expected_counts <- pharmaverseadam::adcm %>% + as.data.table() %>% + .[SAFFL == "Y" & AOCCPFL == "Y"] %>% + unique(., by = c("SUBJID")) %>% + .[, .N, by = TRT01A] %>% + .[["N"]] - # ACT --------------------------------------------------------------------- + actual_counts <- + actual[strata_var == "TOTAL_" & fn_name == "n_subev"] %>% + .[, stat_result] %>% + rbindlist() %>% + .[["value"]] - actual <- - apply_stats(ep_crit_by_strata_by_trt, - analysis_data_container, - type = "stat_by_strata_by_trt") + expect_equal(actual_counts, expected_counts, label = "Event counts match") +}) - # EXPECT ------------------------------------------------------------------ - adsl <- pharmaverseadam::adsl |> setDT() - expected_counts <- adsl[TRT01A == "Placebo" & SAFFL == "Y"] |> - unique(by = "USUBJID") |> - nrow() +test_that("validate: n_sub return correct value", { + # SETUP ------------------------------------------------------------------- + skip_on_devops() + ep <- mk_ep_0001_base( + stratify_by = list(c("SEX")), + data_prepare = mk_adcm, + stat_by_strata_by_trt = list(n_sub = n_sub) + ) - actual_counts <- - actual[strata_var == "TOTAL_" & fn_name == "n_sub"][, stat_result] |> - rbindlist() + ep <- add_id(ep) + ep_fn_map <- + suppressWarnings(unnest_endpoint_functions(ep)) + user_def_fn <- + mk_userdef_fn_dt(ep_fn_map, env = environment()) - expect_equal(actual_counts$value[[1]], expected_counts, label = "Event counts match") + fn_map <- + merge(ep_fn_map[, .(endpoint_spec_id, fn_hash)], user_def_fn, by = "fn_hash") + adam_db <- + fetch_db_data( + study_metadata = list(), + fn_dt = user_def_fn + ) + ep_and_data <- filter_db_data(ep, ep_fn_map, adam_db) + ep_data_key <- ep_and_data$ep + analysis_data_container <- + ep_and_data$analysis_data_container + ep_expanded <- + expand_over_endpoints(ep_data_key, analysis_data_container) + ep_ev_index <- + add_event_index(ep_expanded, analysis_data_container) + ep_crit_endpoint <- + apply_criterion_endpoint(ep_ev_index, analysis_data_container, fn_map) + crit_accept_by_strata_by_trt <- + apply_criterion_by_strata(ep_crit_endpoint, + analysis_data_container, + fn_map, + type = "by_strata_by_trt" + ) + crit_accept_by_strata_across_trt <- + apply_criterion_by_strata(crit_accept_by_strata_by_trt, + analysis_data_container, + fn_map, + type = "by_strata_across_trt" + ) + + ep_crit_by_strata_by_trt <- prepare_for_stats( + crit_accept_by_strata_across_trt, + analysis_data_container, + fn_map, + type = "stat_by_strata_by_trt" + ) + + + # ACT --------------------------------------------------------------------- + + actual <- + apply_stats(ep_crit_by_strata_by_trt, + analysis_data_container, + type = "stat_by_strata_by_trt" + ) + + # EXPECT ------------------------------------------------------------------ + + adsl <- pharmaverseadam::adsl |> setDT() + expected_counts <- adsl[TRT01A == "Placebo" & SAFFL == "Y"] |> + unique(by = "USUBJID") |> + nrow() + + actual_counts <- + actual[strata_var == "TOTAL_" & fn_name == "n_sub"][, stat_result] |> + rbindlist() + + + expect_equal(actual_counts$value[[1]], expected_counts, label = "Event counts match") }) -test_that("apply_stats stat_by_strata_across_trt", -{ +test_that("apply_stats stat_by_strata_across_trt", { # SETUP ------------------------------------------------------------------- skip_on_devops() @@ -353,14 +353,16 @@ test_that("apply_stats stat_by_strata_across_trt", apply_criterion_endpoint(ep_ev_index, analysis_data_container, fn_map) crit_accept_by_strata_by_trt <- apply_criterion_by_strata(ep_crit_endpoint, - analysis_data_container, - fn_map, - type = "by_strata_by_trt") + analysis_data_container, + fn_map, + type = "by_strata_by_trt" + ) crit_accept_by_strata_across_trt <- apply_criterion_by_strata(crit_accept_by_strata_by_trt, - analysis_data_container, - fn_map, - type = "by_strata_across_trt") + analysis_data_container, + fn_map, + type = "by_strata_across_trt" + ) ep_crit_by_strata_by_trt <- prepare_for_stats( crit_accept_by_strata_across_trt, @@ -373,27 +375,26 @@ test_that("apply_stats stat_by_strata_across_trt", actual <- apply_stats( ep_crit_by_strata_by_trt, - analysis_data_container, type = "stat_by_strata_across_trt") + analysis_data_container, + type = "stat_by_strata_across_trt" + ) # EXPECT ------------------------------------------------------------------ expect_equal(nrow(actual), 3) expect_equal(setdiff(names(actual), names(ep_crit_by_strata_by_trt)), "stat_result") - for (i in 1:nrow(actual)){ + for (i in 1:nrow(actual)) { stats <- actual[["stat_result"]][[i]] expect_true(is.data.table(stats)) expect_equal(nrow(stats), 1) - expect_same_items(names(stats), c( "label", "description", "qualifiers", "value")) - + expect_same_items(names(stats), c("label", "description", "qualifiers", "value")) } - }) -test_that("apply_stats stat_across_strata_across_trt when no across_strata_across_trt fn supplied", -{ +test_that("apply_stats stat_across_strata_across_trt when no across_strata_across_trt fn supplied", { # SETUP ------------------------------------------------------------------- skip_on_devops() ep <- mk_endpoint_str( @@ -436,14 +437,16 @@ test_that("apply_stats stat_across_strata_across_trt when no across_strata_acros apply_criterion_endpoint(ep_ev_index, analysis_data_container, fn_map) crit_accept_by_strata_by_trt <- apply_criterion_by_strata(ep_crit_endpoint, - analysis_data_container, - fn_map, - type = "by_strata_by_trt") + analysis_data_container, + fn_map, + type = "by_strata_by_trt" + ) crit_accept_by_strata_across_trt <- apply_criterion_by_strata(crit_accept_by_strata_by_trt, - analysis_data_container, - fn_map, - type = "by_strata_across_trt") + analysis_data_container, + fn_map, + type = "by_strata_across_trt" + ) ep_crit_by_strata_by_trt <- prepare_for_stats( crit_accept_by_strata_across_trt, @@ -464,96 +467,95 @@ test_that("apply_stats stat_across_strata_across_trt when no across_strata_acros # EXPECT ------------------------------------------------------------------ expect_equal(actual, data.table(NULL)) - }) -test_that("apply_stats: with all FALSE for criteria", - { - # SETUP ------------------------------------------------------------------- +test_that("apply_stats: with all FALSE for criteria", { + # SETUP ------------------------------------------------------------------- + + skip_on_devops() + + crit_false <- function(...) FALSE + + ep <- mk_endpoint_str( + study_metadata = list(), + pop_var = "SAFFL", + pop_value = "Y", + treatment_var = "TRT01A", + treatment_refval = "Xanomeline High Dose", + period_var = "ANL01FL", + period_value = "Y", + stratify_by = list(c("SEX")), + data_prepare = mk_adcm, + endpoint_label = "A", + stat_by_strata_by_trt = list("n_events" = n_subev), + crit_by_strata_by_trt = crit_false + ) - skip_on_devops() + ep <- add_id(ep) + ep_fn_map <- + suppressWarnings(unnest_endpoint_functions(ep)) - crit_false <- function(...)FALSE + user_def_fn <- + mk_userdef_fn_dt(ep_fn_map, env = environment()) - ep <- mk_endpoint_str( + fn_map <- + merge(ep_fn_map[, .(endpoint_spec_id, fn_hash)], user_def_fn, by = "fn_hash") + adam_db <- + fetch_db_data( study_metadata = list(), - pop_var = "SAFFL", - pop_value = "Y", - treatment_var = "TRT01A", - treatment_refval = "Xanomeline High Dose", - period_var = "ANL01FL", - period_value = "Y", - stratify_by = list(c("SEX")), - data_prepare = mk_adcm, - endpoint_label = "A", - stat_by_strata_by_trt = list("n_events" = n_subev), - crit_by_strata_by_trt = crit_false - ) - - ep <- add_id(ep) - ep_fn_map <- - suppressWarnings(unnest_endpoint_functions(ep)) - - user_def_fn <- - mk_userdef_fn_dt(ep_fn_map, env = environment()) - - fn_map <- - merge(ep_fn_map[, .(endpoint_spec_id, fn_hash)], user_def_fn, by = "fn_hash") - adam_db <- - fetch_db_data( - study_metadata = list(), - fn_dt = user_def_fn - ) - ep_and_data <- filter_db_data(ep, ep_fn_map, adam_db) - ep_data_key <- ep_and_data$ep - analysis_data_container <- - ep_and_data$analysis_data_container - ep_expanded <- - expand_over_endpoints(ep_data_key, analysis_data_container) - ep_ev_index <- - add_event_index(ep_expanded, analysis_data_container) - ep_crit_endpoint <- - apply_criterion_endpoint(ep_ev_index, analysis_data_container, fn_map) - crit_accept_by_strata_by_trt <- - apply_criterion_by_strata(ep_crit_endpoint, - analysis_data_container, - fn_map, - type = "by_strata_by_trt") - crit_accept_by_strata_across_trt <- - apply_criterion_by_strata(crit_accept_by_strata_by_trt, - analysis_data_container, - fn_map, - type = "by_strata_across_trt") - - ep_prep_by_strata_by_trt <- prepare_for_stats( - crit_accept_by_strata_across_trt, + fn_dt = user_def_fn + ) + ep_and_data <- filter_db_data(ep, ep_fn_map, adam_db) + ep_data_key <- ep_and_data$ep + analysis_data_container <- + ep_and_data$analysis_data_container + ep_expanded <- + expand_over_endpoints(ep_data_key, analysis_data_container) + ep_ev_index <- + add_event_index(ep_expanded, analysis_data_container) + ep_crit_endpoint <- + apply_criterion_endpoint(ep_ev_index, analysis_data_container, fn_map) + crit_accept_by_strata_by_trt <- + apply_criterion_by_strata(ep_crit_endpoint, analysis_data_container, fn_map, - type = "stat_by_strata_by_trt" + type = "by_strata_by_trt" + ) + crit_accept_by_strata_across_trt <- + apply_criterion_by_strata(crit_accept_by_strata_by_trt, + analysis_data_container, + fn_map, + type = "by_strata_across_trt" ) - # ACT --------------------------------------------------------------------- - - actual <- - apply_stats(ep_prep_by_strata_by_trt, - analysis_data_container, - type = "stat_by_strata_by_trt") + ep_prep_by_strata_by_trt <- prepare_for_stats( + crit_accept_by_strata_across_trt, + analysis_data_container, + fn_map, + type = "stat_by_strata_by_trt" + ) - # EXPECT ------------------------------------------------------------------ + # ACT --------------------------------------------------------------------- - expect_equal( - nrow(actual), - nrow(ep_prep_by_strata_by_trt) - ) - expect_true( - all(unlist(lapply(actual$stat_results, is.null))) + actual <- + apply_stats(ep_prep_by_strata_by_trt, + analysis_data_container, + type = "stat_by_strata_by_trt" ) - }) + # EXPECT ------------------------------------------------------------------ + + expect_equal( + nrow(actual), + nrow(ep_prep_by_strata_by_trt) + ) + expect_true( + all(unlist(lapply(actual$stat_results, is.null))) + ) +}) -test_that("Complex application of stats functions", -{ +test_that("Complex application of stats functions", { # SETUP ------------------------------------------------------------------- # Statistical function across strata and treatment arms (does not make much @@ -596,8 +598,10 @@ test_that("Complex application of stats functions", ep_fn_map <- suppressWarnings(unnest_endpoint_functions(ep)) user_def_fn <- mk_userdef_fn_dt(ep_fn_map, env = environment()) fn_map <- merge(ep_fn_map[, .(endpoint_spec_id, fn_hash)], user_def_fn, by = "fn_hash") - adam_db <- fetch_db_data(study_metadata = ep$study_metadata[[1]], - fn_dt = user_def_fn) + adam_db <- fetch_db_data( + study_metadata = ep$study_metadata[[1]], + fn_dt = user_def_fn + ) ep_and_data <- filter_db_data(ep, ep_fn_map, adam_db) ep_data_key <- ep_and_data$ep analysis_data_container <- @@ -610,14 +614,16 @@ test_that("Complex application of stats functions", apply_criterion_endpoint(ep_ev_index, analysis_data_container, fn_map) crit_accept_by_strata_by_trt <- apply_criterion_by_strata(ep_crit_endpoint, - analysis_data_container, - fn_map, - type = "by_strata_by_trt") + analysis_data_container, + fn_map, + type = "by_strata_by_trt" + ) crit_accept_by_strata_across_trt <- apply_criterion_by_strata(crit_accept_by_strata_by_trt, - analysis_data_container, - fn_map, - type = "by_strata_across_trt") + analysis_data_container, + fn_map, + type = "by_strata_across_trt" + ) ep_prep_by_strata_by_trt <- prepare_for_stats( crit_accept_by_strata_across_trt, @@ -628,38 +634,45 @@ test_that("Complex application of stats functions", ep_prep_by_strata_across_trt <- prepare_for_stats(crit_accept_by_strata_across_trt, - analysis_data_container, - fn_map, - type = "stat_by_strata_across_trt") + analysis_data_container, + fn_map, + type = "stat_by_strata_across_trt" + ) ep_prep_across_strata_across_trt <- prepare_for_stats(crit_accept_by_strata_across_trt, - analysis_data_container, - fn_map, - type = "stat_across_strata_across_trt") + analysis_data_container, + fn_map, + type = "stat_across_strata_across_trt" + ) # ACT --------------------------------------------------------------------- ep_stat_by_strata_by_trt <- apply_stats(ep_prep_by_strata_by_trt, - analysis_data_container, - type = "stat_by_strata_by_trt") + analysis_data_container, + type = "stat_by_strata_by_trt" + ) ep_stat_by_strata_across_trt <- apply_stats(ep_prep_by_strata_across_trt, - analysis_data_container, - type = "stat_by_strata_across_trt") + analysis_data_container, + type = "stat_by_strata_across_trt" + ) ep_stat_across_strata_across_trt <- apply_stats(ep_prep_across_strata_across_trt, - analysis_data_container, - type = "stat_across_strata_across_trt") + analysis_data_container, + type = "stat_across_strata_across_trt" + ) ep_stat <- - rbind(ep_stat_by_strata_by_trt, - ep_stat_by_strata_across_trt, - ep_stat_across_strata_across_trt) %>% + rbind( + ep_stat_by_strata_by_trt, + ep_stat_by_strata_across_trt, + ep_stat_across_strata_across_trt + ) %>% tidyr::unnest(cols = stat_result) %>% as.data.table() @@ -672,22 +685,29 @@ test_that("Complex application of stats functions", expect_equal(sum(ep_stat$fn_type == "stat_across_strata_across_trt"), 18) # stat_by_strata_by_trt statistics - expect_equal(ep_stat[ep_stat$fn_type == "stat_by_strata_by_trt" & - ep_stat$endpoint_group_filter == 'CMCLAS == "SYSTEMIC HORMONAL PREPARATIONS, EXCL."'][["value"]], - c(2, 8, 1, 1, 2, 6, 2, 0, 6, 2)) - expect_equal(ep_stat[ep_stat$fn_type == "stat_by_strata_by_trt" & - ep_stat$endpoint_group_filter == 'CMCLAS == "RESPIRATORY SYSTEM"'][["value"]], - c(1, 1, 0, 1, 1, 0, 0, 1, 0, 1)) + expect_equal( + ep_stat[ep_stat$fn_type == "stat_by_strata_by_trt" & + ep_stat$endpoint_group_filter == 'CMCLAS == "SYSTEMIC HORMONAL PREPARATIONS, EXCL."'][["value"]], + c(2, 8, 1, 1, 2, 6, 2, 0, 6, 2) + ) + expect_equal( + ep_stat[ep_stat$fn_type == "stat_by_strata_by_trt" & + ep_stat$endpoint_group_filter == 'CMCLAS == "RESPIRATORY SYSTEM"'][["value"]], + c(1, 1, 0, 1, 1, 0, 0, 1, 0, 1) + ) # stat_by_strata_across_trt statistics - expect_equal(ep_stat[ep_stat$fn_type == "stat_by_strata_across_trt" & - ep_stat$endpoint_group_filter == 'CMCLAS == "SYSTEMIC HORMONAL PREPARATIONS, EXCL."'][["value"]], - c(10, 3, 7, 8, 2)) - expect_equal(ep_stat[ep_stat$fn_type == "stat_by_strata_across_trt" & - ep_stat$endpoint_group_filter == 'CMCLAS == "RESPIRATORY SYSTEM"'][["value"]], - c(2, 1, 1, 0, 2)) + expect_equal( + ep_stat[ep_stat$fn_type == "stat_by_strata_across_trt" & + ep_stat$endpoint_group_filter == 'CMCLAS == "SYSTEMIC HORMONAL PREPARATIONS, EXCL."'][["value"]], + c(10, 3, 7, 8, 2) + ) + expect_equal( + ep_stat[ep_stat$fn_type == "stat_by_strata_across_trt" & + ep_stat$endpoint_group_filter == 'CMCLAS == "RESPIRATORY SYSTEM"'][["value"]], + c(2, 1, 1, 0, 2) + ) # stat_across_strata_across_trt statistics expect_true(all(ep_stat[ep_stat$fn_type == "stat_across_strata_across_trt"][["value"]] == 158)) - }) diff --git a/tests/testthat/test-check_duplicate_functions.R b/tests/testthat/test-check_duplicate_functions.R index 25e66a2..af52495 100644 --- a/tests/testthat/test-check_duplicate_functions.R +++ b/tests/testthat/test-check_duplicate_functions.R @@ -1,8 +1,7 @@ -test_that("check_duplicate_functions handles empty directory correctly", - { - testr::create_local_project() - expect_null(check_duplicate_functions("R/")) - }) +test_that("check_duplicate_functions handles empty directory correctly", { + testr::create_local_project() + expect_null(check_duplicate_functions("R/")) +}) test_that( "check_duplicate_functions handles directory with no duplicate function names correctly", @@ -14,20 +13,21 @@ test_that( } ) -test_that("check_duplicate_functions correctly identifies duplicate function names", - { - testr::create_local_project() - write("f1 <- function(){}", "R/tmp.R") - write("f1 <- function(){}", "R/tmp.R", append = TRUE) - expect_error( - check_duplicate_functions("R/"), "The following functions") - - }) +test_that("check_duplicate_functions correctly identifies duplicate function names", { + testr::create_local_project() + write("f1 <- function(){}", "R/tmp.R") + write("f1 <- function(){}", "R/tmp.R", append = TRUE) + expect_error( + check_duplicate_functions("R/"), "The following functions" + ) +}) test_that("check_duplicate_functions handles non-existent directory correctly", { testr::create_local_project() - expect_error(check_duplicate_functions("R_fun"), - "Directory R_fun does not exist") + expect_error( + check_duplicate_functions("R_fun"), + "Directory R_fun does not exist" + ) }) test_that("check_duplicate_functions handles directory with non-R files correctly", { @@ -52,16 +52,19 @@ test_that("check_duplicate_functions correctly identifies all duplicate function write("f2 <- function(){}", "R/tmp.R", append = TRUE) expect_error( - check_duplicate_functions("R"), regexp = "-f2") - + check_duplicate_functions("R"), + regexp = "-f2" + ) }) test_that("check_duplicate_functions handles function definitions with different parameters but same name correctly", { testr::create_local_project() write("f1 <- function(x){x}", "R/tmp.R") write("f1 <- function(y){y}", "R/tmp.R", append = TRUE) - expect_error(check_duplicate_functions("R"), - "f1") + expect_error( + check_duplicate_functions("R"), + "f1" + ) }) diff --git a/tests/testthat/test-construct_filter_logic.R b/tests/testthat/test-construct_filter_logic.R index 009ef62..dc4ca84 100644 --- a/tests/testthat/test-construct_filter_logic.R +++ b/tests/testthat/test-construct_filter_logic.R @@ -42,8 +42,6 @@ test_that("constructing filter logic works with non-paired filters (singletons)" construct_data_filter_logic(list( c(ep$pop_var[[1]], ep$pop_value[[1]]), c(ep$period_var[[1]], ep$period_value[[1]]) - ),singletons = ep$endpoint_filter[[1]] - ) + ), singletons = ep$endpoint_filter[[1]]) expect_equal(actual1, "A==\"TT\" & period==\"F\" & AGE < 50") - }) diff --git a/tests/testthat/test-endpoint_bookkeeping.R b/tests/testthat/test-endpoint_bookkeeping.R index 81b0219..a79dae8 100644 --- a/tests/testthat/test-endpoint_bookkeeping.R +++ b/tests/testthat/test-endpoint_bookkeeping.R @@ -1,6 +1,5 @@ test_that("Bookkeeping of rejected endpoints/strata", { - -# SETUP ------------------------------------------------------------------- + # SETUP ------------------------------------------------------------------- crit_ep <- function(dat, event_index, @@ -21,13 +20,13 @@ test_that("Bookkeeping of rejected endpoints/strata", { endpoint_group_metadata, strata_var, ...) { - if (endpoint_group_metadata[["AESOC"]] == "CARDIAC DISORDERS" | - (endpoint_group_metadata[["AESOC"]] == "INFECTIONS AND INFESTATIONS" & strata_var == "TOTAL_") | - (endpoint_group_metadata[["AESOC"]] %in% c("SKIN AND SUBCUTANEOUS TISSUE DISORDERS", "VASCULAR DISORDERS") & - strata_var %in% c("TOTAL_", "AGEGR2") - )) { + if (endpoint_group_metadata[["AESOC"]] == "CARDIAC DISORDERS" | + (endpoint_group_metadata[["AESOC"]] == "INFECTIONS AND INFESTATIONS" & strata_var == "TOTAL_") | + (endpoint_group_metadata[["AESOC"]] %in% c("SKIN AND SUBCUTANEOUS TISSUE DISORDERS", "VASCULAR DISORDERS") & + strata_var %in% c("TOTAL_", "AGEGR2") + )) { return(TRUE) - } else{ + } else { return(FALSE) } } @@ -42,7 +41,7 @@ test_that("Bookkeeping of rejected endpoints/strata", { "SKIN AND SUBCUTANEOUS TISSUE DISORDERS" ) | (endpoint_group_metadata[["AESOC"]] == "VASCULAR DISORDERS" & strata_var == "TOTAL_")) { return(TRUE) - } else{ + } else { return(FALSE) } } @@ -53,8 +52,10 @@ test_that("Bookkeeping of rejected endpoints/strata", { custom_pop_filter = "TRT01A %in% c('Placebo', 'Xanomeline High Dose')", endpoint_label = "Test: ", group_by = list(list(AESOC = c())), - stat_by_strata_by_trt = list("n_subev" = n_subev, - "p_subev" = p_subev), + stat_by_strata_by_trt = list( + "n_subev" = n_subev, + "p_subev" = p_subev + ), stat_by_strata_across_trt = list("n_subev_trt_diff" = n_subev_trt_diff), stat_across_strata_across_trt = list("P-interaction" = contingency2x2_strata_test), crit_endpoint = list(crit_ep), @@ -92,147 +93,149 @@ test_that("Bookkeeping of rejected endpoints/strata", { apply_criterion_by_strata(ep_crit_endpoint, analysis_data_container, fn_map) ep_crit_by_strata_across_trt <- apply_criterion_by_strata(ep_crit_by_strata_by_trt, - analysis_data_container, - fn_map, - type = "by_strata_across_trt" + analysis_data_container, + fn_map, + type = "by_strata_across_trt" ) -# ACT --------------------------------------------------------------------- + # ACT --------------------------------------------------------------------- ep_prep_by_strata_by_trt <- prepare_for_stats(ep_crit_by_strata_across_trt, - analysis_data_container, - fn_map, - type = "stat_by_strata_by_trt") + analysis_data_container, + fn_map, + type = "stat_by_strata_by_trt" + ) ep_prep_by_strata_across_trt <- prepare_for_stats(ep_crit_by_strata_across_trt, - analysis_data_container, - fn_map, - type = "stat_by_strata_across_trt") + analysis_data_container, + fn_map, + type = "stat_by_strata_across_trt" + ) ep_prep_across_strata_across_trt <- prepare_for_stats(ep_crit_by_strata_across_trt, - analysis_data_container, - fn_map, - type = "stat_across_strata_across_trt") + analysis_data_container, + fn_map, + type = "stat_across_strata_across_trt" + ) ep_rejected <- ep_crit_by_strata_across_trt[!(crit_accept_endpoint) | - !(crit_accept_by_strata_by_trt) | - !(crit_accept_by_strata_across_trt)] + !(crit_accept_by_strata_by_trt) | + !(crit_accept_by_strata_across_trt)] -# EXPECT ------------------------------------------------------------------ + # EXPECT ------------------------------------------------------------------ # by_strata_by_trt: Summary expect_equal(nrow(ep_prep_by_strata_by_trt), 48) - expect_equal(nrow(ep_prep_by_strata_by_trt[fn_name == "n_subev",]), 24) - expect_equal(nrow(ep_prep_by_strata_by_trt[fn_name == "p_subev",]), 24) + expect_equal(nrow(ep_prep_by_strata_by_trt[fn_name == "n_subev", ]), 24) + expect_equal(nrow(ep_prep_by_strata_by_trt[fn_name == "p_subev", ]), 24) # by_strata_by_trt: CARDIAC DISORDERS - ep_soc1 <- ep_prep_by_strata_by_trt[grepl("CARDIAC DISORDERS", endpoint_label),] + ep_soc1 <- ep_prep_by_strata_by_trt[grepl("CARDIAC DISORDERS", endpoint_label), ] expect_equal(nrow(ep_soc1), 20) - expect_equal(nrow(ep_soc1[strata_var == "TOTAL_",]), 4) - expect_equal(nrow(ep_soc1[strata_var == "SEX",]), 8) - expect_equal(nrow(ep_soc1[strata_var == "AGEGR2",]), 8) + expect_equal(nrow(ep_soc1[strata_var == "TOTAL_", ]), 4) + expect_equal(nrow(ep_soc1[strata_var == "SEX", ]), 8) + expect_equal(nrow(ep_soc1[strata_var == "AGEGR2", ]), 8) # by_strata_by_trt: INFECTIONS AND INFESTATIONS - ep_soc2 <- ep_prep_by_strata_by_trt[grepl("INFECTIONS AND INFESTATIONS", endpoint_label),] + ep_soc2 <- ep_prep_by_strata_by_trt[grepl("INFECTIONS AND INFESTATIONS", endpoint_label), ] expect_equal(nrow(ep_soc2), 4) - expect_equal(nrow(ep_soc2[strata_var == "TOTAL_",]), 4) + expect_equal(nrow(ep_soc2[strata_var == "TOTAL_", ]), 4) # by_strata_by_trt: SKIN AND SUBCUTANEOUS TISSUE DISORDERS - ep_soc3 <- ep_prep_by_strata_by_trt[grepl("SKIN AND SUBCUTANEOUS TISSUE DISORDERS", endpoint_label),] + ep_soc3 <- ep_prep_by_strata_by_trt[grepl("SKIN AND SUBCUTANEOUS TISSUE DISORDERS", endpoint_label), ] expect_equal(nrow(ep_soc3), 12) - expect_equal(nrow(ep_soc3[strata_var == "TOTAL_",]), 4) - expect_equal(nrow(ep_soc3[strata_var == "AGEGR2",]), 8) + expect_equal(nrow(ep_soc3[strata_var == "TOTAL_", ]), 4) + expect_equal(nrow(ep_soc3[strata_var == "AGEGR2", ]), 8) # by_strata_by_trt: VASCULAR DISORDERS - ep_soc4 <- ep_prep_by_strata_by_trt[grepl("VASCULAR DISORDERS", endpoint_label),] + ep_soc4 <- ep_prep_by_strata_by_trt[grepl("VASCULAR DISORDERS", endpoint_label), ] expect_equal(nrow(ep_soc4), 12) - expect_equal(nrow(ep_soc4[strata_var == "TOTAL_",]), 4) - expect_equal(nrow(ep_soc4[strata_var == "AGEGR2",]), 8) + expect_equal(nrow(ep_soc4[strata_var == "TOTAL_", ]), 4) + expect_equal(nrow(ep_soc4[strata_var == "AGEGR2", ]), 8) # by_strata_across_trt: Summary expect_equal(nrow(ep_prep_by_strata_across_trt), 10) - expect_equal(nrow(ep_prep_by_strata_across_trt[fn_name == "n_subev_trt_diff",]), 10) + expect_equal(nrow(ep_prep_by_strata_across_trt[fn_name == "n_subev_trt_diff", ]), 10) # by_strata_across_trt: CARDIAC DISORDERS - ep_soc5 <- ep_prep_by_strata_across_trt[grepl("CARDIAC DISORDERS", endpoint_label),] + ep_soc5 <- ep_prep_by_strata_across_trt[grepl("CARDIAC DISORDERS", endpoint_label), ] expect_equal(nrow(ep_soc5), 5) - expect_equal(nrow(ep_soc5[strata_var == "TOTAL_",]), 1) - expect_equal(nrow(ep_soc5[strata_var == "SEX",]), 2) - expect_equal(nrow(ep_soc5[strata_var == "AGEGR2",]), 2) + expect_equal(nrow(ep_soc5[strata_var == "TOTAL_", ]), 1) + expect_equal(nrow(ep_soc5[strata_var == "SEX", ]), 2) + expect_equal(nrow(ep_soc5[strata_var == "AGEGR2", ]), 2) # by_strata_across_trt: INFECTIONS AND INFESTATIONS - ep_soc6 <- ep_prep_by_strata_across_trt[grepl("INFECTIONS AND INFESTATIONS", endpoint_label),] + ep_soc6 <- ep_prep_by_strata_across_trt[grepl("INFECTIONS AND INFESTATIONS", endpoint_label), ] expect_equal(nrow(ep_soc6), 1) - expect_equal(nrow(ep_soc6[strata_var == "TOTAL_",]), 1) + expect_equal(nrow(ep_soc6[strata_var == "TOTAL_", ]), 1) # by_strata_across_trt: SKIN AND SUBCUTANEOUS TISSUE DISORDERS - ep_soc7 <- ep_prep_by_strata_across_trt[grepl("SKIN AND SUBCUTANEOUS TISSUE DISORDERS", endpoint_label),] + ep_soc7 <- ep_prep_by_strata_across_trt[grepl("SKIN AND SUBCUTANEOUS TISSUE DISORDERS", endpoint_label), ] expect_equal(nrow(ep_soc7), 3) - expect_equal(nrow(ep_soc7[strata_var == "TOTAL_",]), 1) - expect_equal(nrow(ep_soc7[strata_var == "AGEGR2",]), 2) + expect_equal(nrow(ep_soc7[strata_var == "TOTAL_", ]), 1) + expect_equal(nrow(ep_soc7[strata_var == "AGEGR2", ]), 2) # by_strata_across_trt: VASCULAR DISORDERS - ep_soc8 <- ep_prep_by_strata_across_trt[grepl("VASCULAR DISORDERS", endpoint_label),] + ep_soc8 <- ep_prep_by_strata_across_trt[grepl("VASCULAR DISORDERS", endpoint_label), ] expect_equal(nrow(ep_soc8), 1) - expect_equal(nrow(ep_soc8[strata_var == "TOTAL_",]), 1) + expect_equal(nrow(ep_soc8[strata_var == "TOTAL_", ]), 1) # across_strata_across_trt: Summary expect_equal(nrow(ep_prep_across_strata_across_trt), 3) - expect_equal(nrow(ep_prep_across_strata_across_trt[fn_name == "P-interaction",]), 3) + expect_equal(nrow(ep_prep_across_strata_across_trt[fn_name == "P-interaction", ]), 3) # across_strata_across_trt: CARDIAC DISORDERS - ep_soc9 <- ep_prep_across_strata_across_trt[grepl("CARDIAC DISORDERS", endpoint_label),] + ep_soc9 <- ep_prep_across_strata_across_trt[grepl("CARDIAC DISORDERS", endpoint_label), ] expect_equal(nrow(ep_soc9), 2) - expect_equal(nrow(ep_soc9[strata_var == "SEX",]), 1) - expect_equal(nrow(ep_soc9[strata_var == "AGEGR2",]), 1) + expect_equal(nrow(ep_soc9[strata_var == "SEX", ]), 1) + expect_equal(nrow(ep_soc9[strata_var == "AGEGR2", ]), 1) # across_strata_across_trt: INFECTIONS AND INFESTATIONS - ep_soc10 <- ep_prep_across_strata_across_trt[grepl("INFECTIONS AND INFESTATIONS", endpoint_label),] + ep_soc10 <- ep_prep_across_strata_across_trt[grepl("INFECTIONS AND INFESTATIONS", endpoint_label), ] expect_equal(nrow(ep_soc10), 0) # across_strata_across_trt: SKIN AND SUBCUTANEOUS TISSUE DISORDERS - ep_soc11 <- ep_prep_across_strata_across_trt[grepl("SKIN AND SUBCUTANEOUS TISSUE DISORDERS", endpoint_label),] + ep_soc11 <- ep_prep_across_strata_across_trt[grepl("SKIN AND SUBCUTANEOUS TISSUE DISORDERS", endpoint_label), ] expect_equal(nrow(ep_soc11), 1) - expect_equal(nrow(ep_soc11[strata_var == "AGEGR2",]), 1) + expect_equal(nrow(ep_soc11[strata_var == "AGEGR2", ]), 1) # across_strata_across_trt: VASCULAR DISORDERS - ep_soc12 <- ep_prep_across_strata_across_trt[grepl("VASCULAR DISORDERS", endpoint_label),] + ep_soc12 <- ep_prep_across_strata_across_trt[grepl("VASCULAR DISORDERS", endpoint_label), ] expect_equal(nrow(ep_soc12), 0) # Rejected entities expect_equal(nrow(ep_rejected), 24) # Rejected endpoints - expect_equal(nrow(ep_rejected[crit_accept_endpoint==FALSE,]), 19) + expect_equal(nrow(ep_rejected[crit_accept_endpoint == FALSE, ]), 19) # Rejected by_strata_by_trt: Summary - ep_reject1 <- ep_rejected[crit_accept_endpoint==TRUE & crit_accept_by_strata_by_trt==FALSE,] + ep_reject1 <- ep_rejected[crit_accept_endpoint == TRUE & crit_accept_by_strata_by_trt == FALSE, ] expect_equal(nrow(ep_reject1), 4) # Rejected by_strata_by_trt: INFECTIONS AND INFESTATIONS - ep_reject2 <- ep_reject1[grepl("INFECTIONS AND INFESTATIONS", endpoint_label),] + ep_reject2 <- ep_reject1[grepl("INFECTIONS AND INFESTATIONS", endpoint_label), ] expect_equal(nrow(ep_reject2), 2) expect_equal(nrow(ep_reject2[strata_var == "SEX"]), 1) expect_equal(nrow(ep_reject2[strata_var == "AGEGR2"]), 1) # Rejected by_strata_by_trt: SKIN AND SUBCUTANEOUS TISSUE DISORDERS - ep_reject3 <- ep_reject1[grepl("SKIN AND SUBCUTANEOUS TISSUE DISORDERS", endpoint_label),] + ep_reject3 <- ep_reject1[grepl("SKIN AND SUBCUTANEOUS TISSUE DISORDERS", endpoint_label), ] expect_equal(nrow(ep_reject3), 1) expect_equal(nrow(ep_reject3[strata_var == "SEX"]), 1) # Rejected by_strata_by_trt: VASCULAR DISORDERS - ep_reject4 <- ep_reject1[grepl("VASCULAR DISORDERS", endpoint_label),] + ep_reject4 <- ep_reject1[grepl("VASCULAR DISORDERS", endpoint_label), ] expect_equal(nrow(ep_reject3), 1) expect_equal(nrow(ep_reject3[strata_var == "SEX"]), 1) # Rejected by_strata_across_trt - ep_reject5 <- ep_rejected[crit_accept_endpoint==TRUE & crit_accept_by_strata_by_trt==TRUE & crit_accept_by_strata_across_trt==FALSE,] + ep_reject5 <- ep_rejected[crit_accept_endpoint == TRUE & crit_accept_by_strata_by_trt == TRUE & crit_accept_by_strata_across_trt == FALSE, ] expect_equal(nrow(ep_reject5), 1) expect_equal(nrow(ep_reject5[grepl("VASCULAR DISORDERS", endpoint_label) & strata_var == "AGEGR2"]), 1) - }) diff --git a/tests/testthat/test-expand_over_endpoints.R b/tests/testthat/test-expand_over_endpoints.R index bf04692..f5d29af 100644 --- a/tests/testthat/test-expand_over_endpoints.R +++ b/tests/testthat/test-expand_over_endpoints.R @@ -1,209 +1,216 @@ -test_that("grp level criterion works", - { - # SETUP ------------------------------------------------------------------- - ep <- rbind( - mk_ep_0001_waiting_grps( - data_prepare = mk_adcm, - group_by = list(list(CMCLAS = c())), - endpoint_label = "a" - ) - ) - - ep <- add_id(ep) - ep_fn_map <- - suppressWarnings(unnest_endpoint_functions(ep)) - user_def_fn <- - mk_userdef_fn_dt(ep_fn_map, env = environment()) - fn_map <- - merge(ep_fn_map[, .(endpoint_spec_id, fn_hash)], user_def_fn, by = "fn_hash") - adam_db <- - fetch_db_data(study_metadata = list(), - fn_dt = user_def_fn) - ep_and_data <- filter_db_data(ep, ep_fn_map, adam_db) - - - # ACT --------------------------------------------------------------------- - actual <- - expand_over_endpoints( - ep = ep_and_data$ep, - analysis_data_container = ep_and_data$analysis_data_container - ) - # EXPECT ------------------------------------------------------------------ - expected_values <- - ep_and_data$analysis_data_container$dat[[1]][!is.na(CMCLAS)]$CMCLAS |> unique() - expect_equal(nrow(actual), length(expected_values)) - }) - - -test_that("grp level works when only 1 level available in the data", - { - # SETUP ------------------------------------------------------------------- - ep <- rbind( - mk_ep_0001_waiting_grps( - data_prepare = mk_adcm, - group_by = list(list(CMCLAS = c("UNCODED"))), - endpoint_label = "b" - ) - ) - ep <- add_id(ep) - ep_fn_map <- - suppressWarnings(unnest_endpoint_functions(ep)) - user_def_fn <- - mk_userdef_fn_dt(ep_fn_map, env = environment()) - fn_map <- - merge(ep_fn_map[, .(endpoint_spec_id, fn_hash)], user_def_fn, by = "fn_hash") - adam_db <- - fetch_db_data(study_metadata = list(), - fn_dt = user_def_fn) - ep_and_data <- filter_db_data(ep, ep_fn_map, adam_db) - - - # ACT --------------------------------------------------------------------- - actual <- - expand_over_endpoints( - ep = ep_and_data$ep, - analysis_data_container = ep_and_data$analysis_data_container - ) - - # EXPECT ------------------------------------------------------------------ - - expected_valued <- - ep_and_data$analysis_data_container$dat[[1]]$CMCLAS |> unique() - expect_equal(nrow(actual), 1) - expect_true(grepl("UNCODED", actual$endpoint_group_filter)) - - }) - - -test_that("grp level criterion works when group across multiple variables", - { - # SETUP ------------------------------------------------------------------- - ep <- rbind( - mk_ep_0001_waiting_grps( - data_prepare = mk_adcm, - group_by = list(list( - CMCLAS = c("UNCODED"), RACEGR1 = c() - )), - endpoint_label = "c" - ) - ) - ep <- add_id(ep) - ep_fn_map <- - suppressWarnings(unnest_endpoint_functions(ep)) - user_def_fn <- - mk_userdef_fn_dt(ep_fn_map, env = environment()) - fn_map <- - merge(ep_fn_map[, .(endpoint_spec_id, fn_hash)], user_def_fn, by = "fn_hash") - adam_db <- - fetch_db_data(study_metadata = list(), - fn_dt = user_def_fn) - ep_and_data <- filter_db_data(ep, ep_fn_map, adam_db) - - # ACT --------------------------------------------------------------------- - actual <- - expand_over_endpoints( - ep = ep_and_data$ep, - analysis_data_container = ep_and_data$analysis_data_container - ) - - - # EXPECT ------------------------------------------------------------------ - expected <- - ep_and_data$analysis_data_container$dat[[1]]$RACEGR1 |> unique() |> length() - expect_equal(NROW(actual), expected) - }) - - -test_that("grp level criterion works when group_by is empty", - { - # SETUP ------------------------------------------------------------------- - ep <- rbind( - mk_ep_0001_waiting_grps(data_prepare = mk_adcm, - endpoint_label = "e"), - mk_ep_0001_waiting_grps( - data_prepare = mk_adcm, - group_by = list(list(CMCLAS = c())), - endpoint_label = "f" - ) - ) - ep <- add_id(ep) - ep_fn_map <- - suppressWarnings(unnest_endpoint_functions(ep)) - - user_def_fn <- - mk_userdef_fn_dt(ep_fn_map, env = environment()) - - fn_map <- - merge(ep_fn_map[, .(endpoint_spec_id, fn_hash)], user_def_fn, by = "fn_hash") - adam_db <- - fetch_db_data(study_metadata = list(), - fn_dt = user_def_fn) - ep_and_data <- filter_db_data(ep, ep_fn_map, adam_db) - - - # ACT --------------------------------------------------------------------- - - actual <- - expand_over_endpoints( - ep = ep_and_data$ep, - analysis_data_container = ep_and_data$analysis_data_container - ) - - # EXPECT ------------------------------------------------------------------ - - expected <- - ep_and_data$analysis_data_container$dat[[1]]$CMCLAS |> - unique() |> - length() - - expect_equal(nrow(actual), expected) - expect_equal(nrow(actual[is.na(endpoint_group_filter)]), 1) - expect_equal(actual[is.na(endpoint_group_filter), endpoint_id], "1-0001") - }) - - -test_that("dynamic endpoint labels", - { - # SETUP ------------------------------------------------------------------- - ep <- mk_ep_0001_base( - stratify_by = list(c("SEX")), - data_prepare = mk_adcm, - custom_pop_filter = "TRT01A %in% c('Placebo', 'Xanomeline High Dose')", - group_by = list(list(CMCLAS = c( - "UNCODED", "NERVOUS SYSTEM" - ))), - endpoint_filter = "AGEGR1 == '18-64'", - endpoint_label = " - - - ", - ) - ep <- add_id(ep) - ep_fn_map <- - suppressWarnings(unnest_endpoint_functions(ep)) - user_def_fn <- - mk_userdef_fn_dt(ep_fn_map, env = environment()) - fn_map <- - merge(ep_fn_map[, .(endpoint_spec_id, fn_hash)], user_def_fn, by = "fn_hash") - adam_db <- - fetch_db_data(study_metadata = list(), - fn_dt = user_def_fn) - ep_and_data <- filter_db_data(ep, ep_fn_map, adam_db) - - - # ACT --------------------------------------------------------------------- - actual <- - expand_over_endpoints( - ep = ep_and_data$ep, - analysis_data_container = ep_and_data$analysis_data_container - ) - - - # EXPECT ------------------------------------------------------------------ - expect_equal(nrow(actual), 2) - expect_equal( - actual$endpoint_label, - c( - "SAFFL - TRT01A - UNCODED - AGEGR1 == '18-64'", - "SAFFL - TRT01A - NERVOUS SYSTEM - AGEGR1 == '18-64'" - ) - ) - - }) +test_that("grp level criterion works", { + # SETUP ------------------------------------------------------------------- + ep <- rbind( + mk_ep_0001_waiting_grps( + data_prepare = mk_adcm, + group_by = list(list(CMCLAS = c())), + endpoint_label = "a" + ) + ) + + ep <- add_id(ep) + ep_fn_map <- + suppressWarnings(unnest_endpoint_functions(ep)) + user_def_fn <- + mk_userdef_fn_dt(ep_fn_map, env = environment()) + fn_map <- + merge(ep_fn_map[, .(endpoint_spec_id, fn_hash)], user_def_fn, by = "fn_hash") + adam_db <- + fetch_db_data( + study_metadata = list(), + fn_dt = user_def_fn + ) + ep_and_data <- filter_db_data(ep, ep_fn_map, adam_db) + + + # ACT --------------------------------------------------------------------- + actual <- + expand_over_endpoints( + ep = ep_and_data$ep, + analysis_data_container = ep_and_data$analysis_data_container + ) + # EXPECT ------------------------------------------------------------------ + expected_values <- + ep_and_data$analysis_data_container$dat[[1]][!is.na(CMCLAS)]$CMCLAS |> unique() + expect_equal(nrow(actual), length(expected_values)) +}) + + +test_that("grp level works when only 1 level available in the data", { + # SETUP ------------------------------------------------------------------- + ep <- rbind( + mk_ep_0001_waiting_grps( + data_prepare = mk_adcm, + group_by = list(list(CMCLAS = c("UNCODED"))), + endpoint_label = "b" + ) + ) + ep <- add_id(ep) + ep_fn_map <- + suppressWarnings(unnest_endpoint_functions(ep)) + user_def_fn <- + mk_userdef_fn_dt(ep_fn_map, env = environment()) + fn_map <- + merge(ep_fn_map[, .(endpoint_spec_id, fn_hash)], user_def_fn, by = "fn_hash") + adam_db <- + fetch_db_data( + study_metadata = list(), + fn_dt = user_def_fn + ) + ep_and_data <- filter_db_data(ep, ep_fn_map, adam_db) + + + # ACT --------------------------------------------------------------------- + actual <- + expand_over_endpoints( + ep = ep_and_data$ep, + analysis_data_container = ep_and_data$analysis_data_container + ) + + # EXPECT ------------------------------------------------------------------ + + expected_valued <- + ep_and_data$analysis_data_container$dat[[1]]$CMCLAS |> unique() + expect_equal(nrow(actual), 1) + expect_true(grepl("UNCODED", actual$endpoint_group_filter)) +}) + + +test_that("grp level criterion works when group across multiple variables", { + # SETUP ------------------------------------------------------------------- + ep <- rbind( + mk_ep_0001_waiting_grps( + data_prepare = mk_adcm, + group_by = list(list( + CMCLAS = c("UNCODED"), RACEGR1 = c() + )), + endpoint_label = "c" + ) + ) + ep <- add_id(ep) + ep_fn_map <- + suppressWarnings(unnest_endpoint_functions(ep)) + user_def_fn <- + mk_userdef_fn_dt(ep_fn_map, env = environment()) + fn_map <- + merge(ep_fn_map[, .(endpoint_spec_id, fn_hash)], user_def_fn, by = "fn_hash") + adam_db <- + fetch_db_data( + study_metadata = list(), + fn_dt = user_def_fn + ) + ep_and_data <- filter_db_data(ep, ep_fn_map, adam_db) + + # ACT --------------------------------------------------------------------- + actual <- + expand_over_endpoints( + ep = ep_and_data$ep, + analysis_data_container = ep_and_data$analysis_data_container + ) + + + # EXPECT ------------------------------------------------------------------ + expected <- + ep_and_data$analysis_data_container$dat[[1]]$RACEGR1 |> + unique() |> + length() + expect_equal(NROW(actual), expected) +}) + + +test_that("grp level criterion works when group_by is empty", { + # SETUP ------------------------------------------------------------------- + ep <- rbind( + mk_ep_0001_waiting_grps( + data_prepare = mk_adcm, + endpoint_label = "e" + ), + mk_ep_0001_waiting_grps( + data_prepare = mk_adcm, + group_by = list(list(CMCLAS = c())), + endpoint_label = "f" + ) + ) + ep <- add_id(ep) + ep_fn_map <- + suppressWarnings(unnest_endpoint_functions(ep)) + + user_def_fn <- + mk_userdef_fn_dt(ep_fn_map, env = environment()) + + fn_map <- + merge(ep_fn_map[, .(endpoint_spec_id, fn_hash)], user_def_fn, by = "fn_hash") + adam_db <- + fetch_db_data( + study_metadata = list(), + fn_dt = user_def_fn + ) + ep_and_data <- filter_db_data(ep, ep_fn_map, adam_db) + + + # ACT --------------------------------------------------------------------- + + actual <- + expand_over_endpoints( + ep = ep_and_data$ep, + analysis_data_container = ep_and_data$analysis_data_container + ) + + # EXPECT ------------------------------------------------------------------ + + expected <- + ep_and_data$analysis_data_container$dat[[1]]$CMCLAS |> + unique() |> + length() + + expect_equal(nrow(actual), expected) + expect_equal(nrow(actual[is.na(endpoint_group_filter)]), 1) + expect_equal(actual[is.na(endpoint_group_filter), endpoint_id], "1-0001") +}) + + +test_that("dynamic endpoint labels", { + # SETUP ------------------------------------------------------------------- + ep <- mk_ep_0001_base( + stratify_by = list(c("SEX")), + data_prepare = mk_adcm, + custom_pop_filter = "TRT01A %in% c('Placebo', 'Xanomeline High Dose')", + group_by = list(list(CMCLAS = c( + "UNCODED", "NERVOUS SYSTEM" + ))), + endpoint_filter = "AGEGR1 == '18-64'", + endpoint_label = " - - - ", + ) + ep <- add_id(ep) + ep_fn_map <- + suppressWarnings(unnest_endpoint_functions(ep)) + user_def_fn <- + mk_userdef_fn_dt(ep_fn_map, env = environment()) + fn_map <- + merge(ep_fn_map[, .(endpoint_spec_id, fn_hash)], user_def_fn, by = "fn_hash") + adam_db <- + fetch_db_data( + study_metadata = list(), + fn_dt = user_def_fn + ) + ep_and_data <- filter_db_data(ep, ep_fn_map, adam_db) + + + # ACT --------------------------------------------------------------------- + actual <- + expand_over_endpoints( + ep = ep_and_data$ep, + analysis_data_container = ep_and_data$analysis_data_container + ) + + + # EXPECT ------------------------------------------------------------------ + expect_equal(nrow(actual), 2) + expect_equal( + actual$endpoint_label, + c( + "SAFFL - TRT01A - UNCODED - AGEGR1 == '18-64'", + "SAFFL - TRT01A - NERVOUS SYSTEM - AGEGR1 == '18-64'" + ) + ) +}) diff --git a/tests/testthat/test-fetch_db_data.R b/tests/testthat/test-fetch_db_data.R index 40d8f63..6ff444f 100644 --- a/tests/testthat/test-fetch_db_data.R +++ b/tests/testthat/test-fetch_db_data.R @@ -1,5 +1,4 @@ -test_that("Fetching/proccessing adam works", -{ +test_that("Fetching/proccessing adam works", { # SETUP ------------------------------------------------------------------- fn_dt <- suppressWarnings( data.table::data.table( @@ -13,7 +12,8 @@ test_that("Fetching/proccessing adam works", # ACT --------------------------------------------------------------------- adam <- fn_dt[, eval_data_fn( fn = fn_callable, - study_metadata = list()), by = seq_len(nrow(fn_dt))] + study_metadata = list() + ), by = seq_len(nrow(fn_dt))] # EXPECT ------------------------------------------------------------------ @@ -24,8 +24,7 @@ test_that("Fetching/proccessing adam works", }) -test_that("Fetching adam data works when single data_prepare specified", -{ +test_that("Fetching adam data works when single data_prepare specified", { # SETUP ------------------------------------------------------------------- ep <- rbind(suppressWarnings( @@ -54,25 +53,27 @@ test_that("Fetching adam data works when single data_prepare specified", }) -test_that("Only unique adam datasets are returned", -{ +test_that("Only unique adam datasets are returned", { # SETUP ------------------------------------------------------------------- ep <- - rbind(suppressWarnings( - mk_ep_0001_base( - data_prepare = mk_adae, - endpoint_label = "A" - ) - ), - suppressWarnings( - mk_ep_0001_base( - data_prepare = mk_adae, - endpoint_label = "B" + rbind( + suppressWarnings( + mk_ep_0001_base( + data_prepare = mk_adae, + endpoint_label = "A" + ) + ), + suppressWarnings( + mk_ep_0001_base( + data_prepare = mk_adae, + endpoint_label = "B" + ) ) - )) + ) ep <- add_id(ep) ep_long <- suppressWarnings( - unnest_endpoint_functions(ep, fn_cols = c("data_prepare"))) + unnest_endpoint_functions(ep, fn_cols = c("data_prepare")) + ) function_dt <- mk_userdef_fn_dt(ep_long) # ACT --------------------------------------------------------------------- @@ -81,17 +82,22 @@ test_that("Only unique adam datasets are returned", # EXPECT ------------------------------------------------------------------ expect_equal(nrow(adam), 1) - expect_equal(adam$fn_name, - c("mk_adae")) - expect_equal(intersect("AGEGR2", names(adam$dat[[1]])), - "AGEGR2") - expect_equal(setdiff("TESTVAR", names(adam$dat[[1]])), - "TESTVAR") + expect_equal( + adam$fn_name, + c("mk_adae") + ) + expect_equal( + intersect("AGEGR2", names(adam$dat[[1]])), + "AGEGR2" + ) + expect_equal( + setdiff("TESTVAR", names(adam$dat[[1]])), + "TESTVAR" + ) }) -test_that("Multiple, but unique adam datasets are returned", -{ +test_that("Multiple, but unique adam datasets are returned", { # SETUP ------------------------------------------------------------------- ep <- rbind( @@ -128,15 +134,17 @@ test_that("Multiple, but unique adam datasets are returned", # EXPECT ------------------------------------------------------------------ expect_equal(nrow(adam), 2) - expect_equal(adam$fn_name, - c("mk_adae", - "mk_adex")) - + expect_equal( + adam$fn_name, + c( + "mk_adae", + "mk_adex" + ) + ) }) -test_that("data_prepare with no specified input datasets error out", -{ +test_that("data_prepare with no specified input datasets error out", { # SETUP ------------------------------------------------------------------- mk_adam_training_error <- function() { @@ -173,13 +181,12 @@ test_that("data_prepare with no specified input datasets error out", expect_error( function_dt <- mk_userdef_fn_dt(ep_long), "Function (mk_adam_training_error) of type (data_prepare) is supplied arguments it does not expect", - fixed=TRUE + fixed = TRUE ) }) -test_that("data_prepare with internal error gives useful error msg", -{ +test_that("data_prepare with internal error gives useful error msg", { # SETUP ------------------------------------------------------------------- error_fn <- function(study_metadata) { @@ -213,12 +220,12 @@ test_that("data_prepare with internal error gives useful error msg", # EXPECT ------------------------------------------------------------------ expect_error(fetch_db_data(study_metadata = study_metadata, fn_dt = function_dt), - regexp = "error_fn: problem in function") + regexp = "error_fn: problem in function" + ) }) -test_that("Fetching/proccessing adsl works", -{ +test_that("Fetching/proccessing adsl works", { mk_adam_error <- function(study_metadata) { nonpackage::test() } @@ -238,7 +245,11 @@ test_that("Fetching/proccessing adsl works", # ACT --------------------------------------------------------------------- # EXPECT ------------------------------------------------------------------ - expect_error(fetch_db_data(study_metadata = - study_metadata, fn_dt = function_dt), - regexp = "mk_adam_error: there is no package called") + expect_error( + fetch_db_data( + study_metadata = + study_metadata, fn_dt = function_dt + ), + regexp = "mk_adam_error: there is no package called" + ) }) diff --git a/tests/testthat/test-filter_db_data.R b/tests/testthat/test-filter_db_data.R index 1b607ad..2c05ac2 100644 --- a/tests/testthat/test-filter_db_data.R +++ b/tests/testthat/test-filter_db_data.R @@ -1,73 +1,79 @@ -test_that("base case: filter_db_data works with pop filter and no custom filter", - { - # SETUP ------------------------------------------------------------------- - - adam <- mk_adcm() %>% .[, "INDEX_" := .I] - pop_var <- "SAFFL" - pop_value <- "Y" - period_var = NA_character_ - period_value = NA_character_ - custom_pop_filter <- NA_character_ - - ep <- - data.table( - pop_var = pop_var, - pop_value = pop_value, - period_var = period_var, - period_value = period_value, - custom_pop_filter = custom_pop_filter, - endpoint_spec_id = 1 - ) - ep_fn_map <- - data.table(endpoint_spec_id = 1, - fn_type = "data_prepare", - fn_hash = "a") - adam_db <- - data.table(fn_type = "data_prepare", - fn_hash = "a", - dat = list(adam)) - - # ACT --------------------------------------------------------------------- - - actual <- filter_db_data(ep, ep_fn_map, adam_db)$analysis_data_container - # EXPECT ------------------------------------------------------------------ - expect_equal(actual$dat[[1]], adam[SAFFL == "Y"]) - }) - - -test_that("base case: filter_db_data works with both pop filter and custom filter", - { - # SETUP ------------------------------------------------------------------- - adam <- mk_adcm() %>% .[, "INDEX_" := .I] - pop_var <- "SAFFL" - pop_value <- "Y" - period_var = "ANL01FL" - period_value = "Y" - custom_pop_filter <- "CMSEQ >= 60" - - ep <- - data.table( - pop_var = pop_var, - pop_value = pop_value, - period_var = period_var, - period_value = period_value, - custom_pop_filter = custom_pop_filter, - endpoint_spec_id = 1 - ) - ep_fn_map <- - data.table(endpoint_spec_id = 1, - fn_type = "data_prepare", - fn_hash = "a") - adam_db <- - data.table(fn_type = "data_prepare", - fn_hash = "a", - dat = list(adam)) - # ACT --------------------------------------------------------------------- - actual <- filter_db_data(ep, ep_fn_map, adam_db)$analysis_data_container - - # EXPECT ------------------------------------------------------------------ - expect_equal(actual$dat[[1]], adam[SAFFL == "Y" & CMSEQ >= 60]) - }) +test_that("base case: filter_db_data works with pop filter and no custom filter", { + # SETUP ------------------------------------------------------------------- + + adam <- mk_adcm() %>% .[, "INDEX_" := .I] + pop_var <- "SAFFL" + pop_value <- "Y" + period_var <- NA_character_ + period_value <- NA_character_ + custom_pop_filter <- NA_character_ + + ep <- + data.table( + pop_var = pop_var, + pop_value = pop_value, + period_var = period_var, + period_value = period_value, + custom_pop_filter = custom_pop_filter, + endpoint_spec_id = 1 + ) + ep_fn_map <- + data.table( + endpoint_spec_id = 1, + fn_type = "data_prepare", + fn_hash = "a" + ) + adam_db <- + data.table( + fn_type = "data_prepare", + fn_hash = "a", + dat = list(adam) + ) + + # ACT --------------------------------------------------------------------- + + actual <- filter_db_data(ep, ep_fn_map, adam_db)$analysis_data_container + # EXPECT ------------------------------------------------------------------ + expect_equal(actual$dat[[1]], adam[SAFFL == "Y"]) +}) + + +test_that("base case: filter_db_data works with both pop filter and custom filter", { + # SETUP ------------------------------------------------------------------- + adam <- mk_adcm() %>% .[, "INDEX_" := .I] + pop_var <- "SAFFL" + pop_value <- "Y" + period_var <- "ANL01FL" + period_value <- "Y" + custom_pop_filter <- "CMSEQ >= 60" + + ep <- + data.table( + pop_var = pop_var, + pop_value = pop_value, + period_var = period_var, + period_value = period_value, + custom_pop_filter = custom_pop_filter, + endpoint_spec_id = 1 + ) + ep_fn_map <- + data.table( + endpoint_spec_id = 1, + fn_type = "data_prepare", + fn_hash = "a" + ) + adam_db <- + data.table( + fn_type = "data_prepare", + fn_hash = "a", + dat = list(adam) + ) + # ACT --------------------------------------------------------------------- + actual <- filter_db_data(ep, ep_fn_map, adam_db)$analysis_data_container + + # EXPECT ------------------------------------------------------------------ + expect_equal(actual$dat[[1]], adam[SAFFL == "Y" & CMSEQ >= 60]) +}) test_that( "base case: filter_db_data throws error when pop_var or pop_value has not been specified", @@ -77,8 +83,8 @@ test_that( adam <- mk_adcm() %>% .[, "INDEX_" := .I] pop_var <- NULL pop_value <- NULL - period_var = "ANL01FL" - period_value = "Y" + period_var <- "ANL01FL" + period_value <- "Y" custom_pop_filter <- "CMSEQ >= 60" ep <- @@ -91,13 +97,17 @@ test_that( endpoint_spec_id = 1 ) ep_fn_map <- - data.table(endpoint_spec_id = 1, - fn_type = "data_prepare", - fn_hash = "a") + data.table( + endpoint_spec_id = 1, + fn_type = "data_prepare", + fn_hash = "a" + ) adam_db <- - data.table(fn_type = "data_prepare", - fn_hash = "a", - dat = list(adam)) + data.table( + fn_type = "data_prepare", + fn_hash = "a", + dat = list(adam) + ) # ACT --------------------------------------------------------------------- @@ -108,121 +118,129 @@ test_that( ) -test_that("filter_db_data works with >1 row in ep dataset", - { - # SETUP ------------------------------------------------------------------- - adam <- mk_adcm() %>% .[, "INDEX_" := .I] - pop_var <- "SAFFL" - pop_value <- "Y" - period_var = "ANL01FL" - period_value = "Y" - custom_pop_filter <- "CMSEQ >= 60" - - ep <- - data.table( - pop_var = pop_var, - pop_value = pop_value, - period_var = period_var, - period_value = period_value, - custom_pop_filter = custom_pop_filter, - endpoint_spec_id = 1 - ) - - ep <- rbind(ep, ep) - ep[2, custom_pop_filter := "CMSEQ >= 75"] - ep_fn_map <- - data.table(endpoint_spec_id = 1, - fn_type = "data_prepare", - fn_hash = "a") - adam_db <- - data.table(fn_type = "data_prepare", - fn_hash = "a", - dat = list(adam)) - # ACT --------------------------------------------------------------------- - actual <- filter_db_data(ep, ep_fn_map, adam_db) - - # EXPECT ------------------------------------------------------------------ - expect_equal(actual$analysis_data_container$dat[[1]], adam[SAFFL == "Y" & - CMSEQ >= 60]) - expect_equal(actual$analysis_data_container$dat[[2]], adam[SAFFL == "Y" & - CMSEQ >= 75]) - }) - - -test_that("data keys are same for same data, different for different data", - { - # SETUP ------------------------------------------------------------------- - adam <- mk_adcm() %>% .[, "INDEX_" := .I] - pop_var <- "SAFFL" - pop_value <- "Y" - period_var = "ANL01FL" - period_value = "Y" - custom_pop_filter <- "CMSEQ >= 60" - - ep <- - data.table( - pop_var = pop_var, - pop_value = pop_value, - period_var = period_var, - period_value = period_value, - custom_pop_filter = custom_pop_filter, - endpoint_spec_id = 1 - ) - - ep <- rbind(ep, ep, ep) - ep[2, custom_pop_filter := "CMSEQ >= 75"] - ep_fn_map <- - data.table(endpoint_spec_id = 1, - fn_type = "data_prepare", - fn_hash = "a") - adam_db <- - data.table(fn_type = "data_prepare", - fn_hash = "a", - dat = list(adam)) - # ACT --------------------------------------------------------------------- - actual <- - filter_db_data(ep, ep_fn_map, adam_db) - # EXPECT ------------------------------------------------------------------ - expect_equal(nrow(actual$analysis_data_container), 2) - expect_equal(nrow(actual$ep), 3) - - }) - - -test_that("output tables are keyed properly", - { - # SETUP ------------------------------------------------------------------- - adam <- mk_adcm() %>% .[, "INDEX_" := .I] - pop_var <- "SAFFL" - pop_value <- "Y" - period_var = "ANL01FL" - period_value = "Y" - custom_pop_filter <- "CMSEQ >= 60" - - ep <- - data.table( - pop_var = pop_var, - pop_value = pop_value, - period_var = period_var, - period_value = period_value, - custom_pop_filter = custom_pop_filter, - endpoint_spec_id = 1 - ) - - ep <- rbind(ep, ep, ep) - ep[2, custom_pop_filter := "CMSEQ >= 75"] - ep_fn_map <- - data.table(endpoint_spec_id = 1, - fn_type = "data_prepare", - fn_hash = "a") - adam_db <- - data.table(fn_type = "data_prepare", - fn_hash = "a", - dat = list(adam)) - # ACT --------------------------------------------------------------------- - actual <- - filter_db_data(ep, ep_fn_map, adam_db) - # EXPECT ------------------------------------------------------------------ - expect_equal(key(actual$analysis_data_container), "key_analysis_data") - expect_equal(key(actual$ep), "key_analysis_data") - }) +test_that("filter_db_data works with >1 row in ep dataset", { + # SETUP ------------------------------------------------------------------- + adam <- mk_adcm() %>% .[, "INDEX_" := .I] + pop_var <- "SAFFL" + pop_value <- "Y" + period_var <- "ANL01FL" + period_value <- "Y" + custom_pop_filter <- "CMSEQ >= 60" + + ep <- + data.table( + pop_var = pop_var, + pop_value = pop_value, + period_var = period_var, + period_value = period_value, + custom_pop_filter = custom_pop_filter, + endpoint_spec_id = 1 + ) + + ep <- rbind(ep, ep) + ep[2, custom_pop_filter := "CMSEQ >= 75"] + ep_fn_map <- + data.table( + endpoint_spec_id = 1, + fn_type = "data_prepare", + fn_hash = "a" + ) + adam_db <- + data.table( + fn_type = "data_prepare", + fn_hash = "a", + dat = list(adam) + ) + # ACT --------------------------------------------------------------------- + actual <- filter_db_data(ep, ep_fn_map, adam_db) + + # EXPECT ------------------------------------------------------------------ + expect_equal(actual$analysis_data_container$dat[[1]], adam[SAFFL == "Y" & + CMSEQ >= 60]) + expect_equal(actual$analysis_data_container$dat[[2]], adam[SAFFL == "Y" & + CMSEQ >= 75]) +}) + + +test_that("data keys are same for same data, different for different data", { + # SETUP ------------------------------------------------------------------- + adam <- mk_adcm() %>% .[, "INDEX_" := .I] + pop_var <- "SAFFL" + pop_value <- "Y" + period_var <- "ANL01FL" + period_value <- "Y" + custom_pop_filter <- "CMSEQ >= 60" + + ep <- + data.table( + pop_var = pop_var, + pop_value = pop_value, + period_var = period_var, + period_value = period_value, + custom_pop_filter = custom_pop_filter, + endpoint_spec_id = 1 + ) + + ep <- rbind(ep, ep, ep) + ep[2, custom_pop_filter := "CMSEQ >= 75"] + ep_fn_map <- + data.table( + endpoint_spec_id = 1, + fn_type = "data_prepare", + fn_hash = "a" + ) + adam_db <- + data.table( + fn_type = "data_prepare", + fn_hash = "a", + dat = list(adam) + ) + # ACT --------------------------------------------------------------------- + actual <- + filter_db_data(ep, ep_fn_map, adam_db) + # EXPECT ------------------------------------------------------------------ + expect_equal(nrow(actual$analysis_data_container), 2) + expect_equal(nrow(actual$ep), 3) +}) + + +test_that("output tables are keyed properly", { + # SETUP ------------------------------------------------------------------- + adam <- mk_adcm() %>% .[, "INDEX_" := .I] + pop_var <- "SAFFL" + pop_value <- "Y" + period_var <- "ANL01FL" + period_value <- "Y" + custom_pop_filter <- "CMSEQ >= 60" + + ep <- + data.table( + pop_var = pop_var, + pop_value = pop_value, + period_var = period_var, + period_value = period_value, + custom_pop_filter = custom_pop_filter, + endpoint_spec_id = 1 + ) + + ep <- rbind(ep, ep, ep) + ep[2, custom_pop_filter := "CMSEQ >= 75"] + ep_fn_map <- + data.table( + endpoint_spec_id = 1, + fn_type = "data_prepare", + fn_hash = "a" + ) + adam_db <- + data.table( + fn_type = "data_prepare", + fn_hash = "a", + dat = list(adam) + ) + # ACT --------------------------------------------------------------------- + actual <- + filter_db_data(ep, ep_fn_map, adam_db) + # EXPECT ------------------------------------------------------------------ + expect_equal(key(actual$analysis_data_container), "key_analysis_data") + expect_equal(key(actual$ep), "key_analysis_data") +}) diff --git a/tests/testthat/test-group_ep_for_targets.R b/tests/testthat/test-group_ep_for_targets.R index 1e95ae3..8e5a832 100644 --- a/tests/testthat/test-group_ep_for_targets.R +++ b/tests/testthat/test-group_ep_for_targets.R @@ -1,7 +1,7 @@ test_that("grouping works for different values", { dt <- data.table(value = 1:50) -actual <- group_ep_for_targets(dt, 10) -expect_equal(unique(actual$targets_group), 0:4) -actual <- group_ep_for_targets(dt, 25) -expect_equal(unique(actual$targets_group), 0:1) + actual <- group_ep_for_targets(dt, 10) + expect_equal(unique(actual$targets_group), 0:4) + actual <- group_ep_for_targets(dt, 25) + expect_equal(unique(actual$targets_group), 0:1) }) diff --git a/tests/testthat/test-mk_endpoint_str.R b/tests/testthat/test-mk_endpoint_str.R index 2ab4588..5049556 100644 --- a/tests/testthat/test-mk_endpoint_str.R +++ b/tests/testthat/test-mk_endpoint_str.R @@ -10,7 +10,8 @@ test_that("No specification of pop_var", { period_var = "ANL01FL", period_value = "Y", data_prepare = mk_adae - )) + ) + ) }) test_that("No specification of pop_value", { @@ -25,7 +26,8 @@ test_that("No specification of pop_value", { period_var = "ANL01FL", period_value = "Y", data_prepare = mk_adae - )) + ) + ) }) test_that("No specification of treatment_var", { @@ -40,7 +42,8 @@ test_that("No specification of treatment_var", { period_var = "ANL01FL", period_value = "Y", data_prepare = mk_adae - )) + ) + ) }) test_that("No specification of treatment_refval", { @@ -55,7 +58,8 @@ test_that("No specification of treatment_refval", { period_var = "ANL01FL", period_value = "Y", data_prepare = mk_adae - )) + ) + ) }) test_that("No specification of period_var", { @@ -69,7 +73,7 @@ test_that("No specification of period_var", { data_prepare = mk_adae ) # EXPECT ------------------------------------------------------------------ - expect_s3_class(actual, "data.table") + expect_s3_class(actual, "data.table") expect_equal(nrow(actual), 1) }) @@ -86,7 +90,8 @@ test_that("No specification of data_prepare", { treatment_refval = "Xanomeline High Dose", period_var = "ANL01FL", period_value = "Y" - )) + ) + ) }) test_that("Specification of non-existing data_prepare", { @@ -102,7 +107,8 @@ test_that("Specification of non-existing data_prepare", { period_var = "ANL01FL", period_value = "Y", data_prepare = mk_adae_notexist - )) + ) + ) }) test_that("Specification of non-existing stat_by_strata_by_trt function", { @@ -119,8 +125,10 @@ test_that("Specification of non-existing stat_by_strata_by_trt function", { period_value = "Y", data_prepare = mk_adae, stat_by_strata_by_trt = list( - "N_subjects" = n_subj_notexist) - )) + "N_subjects" = n_subj_notexist + ) + ) + ) }) test_that("Specification of non-existing stat_by_strata_by_trt function", { @@ -137,8 +145,10 @@ test_that("Specification of non-existing stat_by_strata_by_trt function", { period_value = "Y", data_prepare = mk_adae, stat_by_strata_across_trt = list( - "N_subjects" = n_subj_notexist) - )) + "N_subjects" = n_subj_notexist + ) + ) + ) }) test_that("Specification of non-existing stat_across_strata_across_trt function", { @@ -155,14 +165,18 @@ test_that("Specification of non-existing stat_across_strata_across_trt function" period_value = "Y", data_prepare = mk_adae, stat_across_strata_across_trt = list( - "N_subjects" = n_subj_notexist) - )) + "N_subjects" = n_subj_notexist + ) + ) + ) }) test_that("naked functions are correctly stored", { # SETUP ------------------------------------------------------------------- - crit_fn <- function(...){return(F)} + crit_fn <- function(...) { + return(F) + } # ACT --------------------------------------------------------------------- # EXPECT ------------------------------------------------------------------ @@ -178,7 +192,6 @@ test_that("naked functions are correctly stored", { crit_by_strata_by_trt = crit_fn, crit_by_strata_across_trt = crit_fn, stat_by_strata_by_trt = crit_fn, - ) expected <- mk_endpoint_str( @@ -194,10 +207,10 @@ test_that("naked functions are correctly stored", { crit_by_strata_across_trt = list(crit_fn), stat_by_strata_by_trt = list(crit_fn) ) - expect_equal(actual$crit_endpoint,expected$crit_endpoint) - expect_equal(actual$crit_by_strata_across_trt,expected$crit_by_strata_across_trt) - expect_equal(actual$crit_by_strata_by_trt,expected$crit_by_strata_by_trt) - expect_equal(actual$stat_by_strata_by_trt,expected$stat_by_strata_by_trt) + expect_equal(actual$crit_endpoint, expected$crit_endpoint) + expect_equal(actual$crit_by_strata_across_trt, expected$crit_by_strata_across_trt) + expect_equal(actual$crit_by_strata_by_trt, expected$crit_by_strata_by_trt) + expect_equal(actual$stat_by_strata_by_trt, expected$stat_by_strata_by_trt) }) @@ -358,56 +371,63 @@ test_that("naked functions are correctly stored", { # }) test_that("Column types of endpoint specification with complete function specification", { + # SETUP ------------------------------------------------------------------- -# SETUP ------------------------------------------------------------------- - - expected_cols <- c("study_metadata", "pop_var", "pop_value", "treatment_var", - "treatment_refval", "period_var", "period_value", "custom_pop_filter", - "endpoint_filter", "group_by", "stratify_by", "endpoint_label", - "data_prepare", "stat_by_strata_by_trt", "stat_by_strata_across_trt", - "stat_across_strata_across_trt", "crit_endpoint", "crit_by_strata_by_trt", - "crit_by_strata_across_trt", "only_strata_with_events") + expected_cols <- c( + "study_metadata", "pop_var", "pop_value", "treatment_var", + "treatment_refval", "period_var", "period_value", "custom_pop_filter", + "endpoint_filter", "group_by", "stratify_by", "endpoint_label", + "data_prepare", "stat_by_strata_by_trt", "stat_by_strata_across_trt", + "stat_across_strata_across_trt", "crit_endpoint", "crit_by_strata_by_trt", + "crit_by_strata_across_trt", "only_strata_with_events" + ) - chr_cols <- c("pop_var", "pop_value", "treatment_var", "treatment_refval", - "period_var", "period_value", "custom_pop_filter", - "endpoint_filter", "endpoint_label") + chr_cols <- c( + "pop_var", "pop_value", "treatment_var", "treatment_refval", + "period_var", "period_value", "custom_pop_filter", + "endpoint_filter", "endpoint_label" + ) - fn_cols <- c("data_prepare", "stat_by_strata_by_trt", - "stat_by_strata_across_trt", "stat_across_strata_across_trt", "crit_endpoint", - "crit_by_strata_by_trt", "crit_by_strata_across_trt") + fn_cols <- c( + "data_prepare", "stat_by_strata_by_trt", + "stat_by_strata_across_trt", "stat_across_strata_across_trt", "crit_endpoint", + "crit_by_strata_by_trt", "crit_by_strata_across_trt" + ) crit_ep_dummy <- function(...) { return(T) } - crit_sgd_dummy <- function(...){ + crit_sgd_dummy <- function(...) { return(T) } - crit_sga_dummy <- function(...){ + crit_sga_dummy <- function(...) { return(T) } -# ACT --------------------------------------------------------------------- + # ACT --------------------------------------------------------------------- ep <- mk_ep_0001_base( data_prepare = mk_adae, - group_by = list(list(RACE=c())), - stat_by_strata_by_trt = list("n_sub" = n_sub, - "n_subev" = n_subev), + group_by = list(list(RACE = c())), + stat_by_strata_by_trt = list( + "n_sub" = n_sub, + "n_subev" = n_subev + ), stat_by_strata_across_trt = list("n_sub" = n_sub), stat_across_strata_across_trt = list("n_subev" = n_subev), crit_endpoint = list(c(crit_ep_dummy, var1 = "test")), crit_by_strata_by_trt = list(c(crit_sgd_dummy, var1 = "test")), crit_by_strata_across_trt = list(c(crit_sga_dummy, var1 = "test")), endpoint_label = "This is a test" - ) + ) -# EXPECT ------------------------------------------------------------------ + # EXPECT ------------------------------------------------------------------ # Check set of output columns expect_equal(setdiff(names(ep), expected_cols), character(0)) # Check character columns - for (i in chr_cols){ + for (i in chr_cols) { # Check column type is character expect_equal(typeof(ep[[i]]), "character", info = paste("Column:", i)) } @@ -417,14 +437,13 @@ test_that("Column types of endpoint specification with complete function specifi # Check named list columns nlst_cols <- c("study_metadata", "group_by") - for (i in nlst_cols){ - + for (i in nlst_cols) { # Check column type is list # expect_equal(typeof(ep[[i]]), "list", info = paste("Column:", i)) # ** Temporary ** # Check column type is list or NA - expect_equal(typeof(ep[[i]]) %in% c("list","character"), TRUE, info = paste("Column:", i)) + expect_equal(typeof(ep[[i]]) %in% c("list", "character"), TRUE, info = paste("Column:", i)) } # Check that group_by entries are named or the list content is NULL @@ -434,23 +453,35 @@ test_that("Column types of endpoint specification with complete function specifi # ** Temporary ** # Check that group_by entries are named or is a character NA - expect_equal(unlist(lapply(ep[["group_by"]], - function(x){length(names(x))>0 | identical(x, NA_character_)})), TRUE, - info = paste("Column:", i)) + expect_equal( + unlist(lapply( + ep[["group_by"]], + function(x) { + length(names(x)) > 0 | identical(x, NA_character_) + } + )), TRUE, + info = paste("Column:", i) + ) # Check unnamed list columns lst_cols <- c("stratify_by") - for (i in lst_cols){ + for (i in lst_cols) { # Check column type is list expect_equal(typeof(ep[[i]]), "list", info = paste("Column:", i)) # Check that list entries are character - expect_equal(all(unlist(lapply(ep[[i]], - function(x){is.character(x)}))), TRUE, - info = paste("Column:", i)) + expect_equal( + all(unlist(lapply( + ep[[i]], + function(x) { + is.character(x) + } + ))), TRUE, + info = paste("Column:", i) + ) } # Check function columns - for (i in fn_cols){ + for (i in fn_cols) { # Check column type is list of length 1 expect_equal(typeof(ep[[i]]), "list", info = paste("Column:", i)) @@ -462,27 +493,31 @@ test_that("Column types of endpoint specification with complete function specifi expect_equal(typeof(names(eval(ep[["stat_by_strata_by_trt"]][[1]]))), "character") expect_equal(typeof(names(eval(ep[["stat_by_strata_across_trt"]][[1]]))), "character") expect_equal(typeof(names(eval(ep[["stat_across_strata_across_trt"]][[1]]))), "character") - }) test_that("Column types of minimal endpoint specification", { - # SETUP ------------------------------------------------------------------- - expected_cols <- c("study_metadata", "pop_var", "pop_value", "treatment_var", - "treatment_refval", "period_var", "period_value", "custom_pop_filter", - "endpoint_filter", "group_by", "stratify_by", "endpoint_label", - "data_prepare", "stat_by_strata_by_trt", "stat_by_strata_across_trt", - "stat_across_strata_across_trt", "crit_endpoint", "crit_by_strata_by_trt", - "crit_by_strata_across_trt", "only_strata_with_events") + expected_cols <- c( + "study_metadata", "pop_var", "pop_value", "treatment_var", + "treatment_refval", "period_var", "period_value", "custom_pop_filter", + "endpoint_filter", "group_by", "stratify_by", "endpoint_label", + "data_prepare", "stat_by_strata_by_trt", "stat_by_strata_across_trt", + "stat_across_strata_across_trt", "crit_endpoint", "crit_by_strata_by_trt", + "crit_by_strata_across_trt", "only_strata_with_events" + ) - chr_cols <- c("pop_var", "pop_value", "treatment_var", "treatment_refval", - "period_var", "period_value", "custom_pop_filter", - "endpoint_filter", "endpoint_label") + chr_cols <- c( + "pop_var", "pop_value", "treatment_var", "treatment_refval", + "period_var", "period_value", "custom_pop_filter", + "endpoint_filter", "endpoint_label" + ) - fn_cols <- c("data_prepare", "stat_by_strata_by_trt", - "stat_by_strata_across_trt", "stat_across_strata_across_trt", "crit_endpoint", - "crit_by_strata_by_trt", "crit_by_strata_across_trt") + fn_cols <- c( + "data_prepare", "stat_by_strata_by_trt", + "stat_by_strata_across_trt", "stat_across_strata_across_trt", "crit_endpoint", + "crit_by_strata_by_trt", "crit_by_strata_across_trt" + ) # ACT --------------------------------------------------------------------- @@ -494,7 +529,7 @@ test_that("Column types of minimal endpoint specification", { expect_equal(setdiff(names(ep), expected_cols), character(0)) # Check character columns - for (i in chr_cols){ + for (i in chr_cols) { # Check column type is character expect_equal(typeof(ep[[i]]), "character", info = paste("Column:", i)) } @@ -504,14 +539,13 @@ test_that("Column types of minimal endpoint specification", { # Check named list columns nlst_cols <- c("study_metadata", "group_by") - for (i in nlst_cols){ - + for (i in nlst_cols) { # Check column type is list # expect_equal(typeof(ep[[i]]), "list", info = paste("Column:", i)) # ** Temporary ** # Check column type is list or NA - expect_equal(typeof(ep[[i]]) %in% c("list","character"), TRUE, info = paste("Column:", i)) + expect_equal(typeof(ep[[i]]) %in% c("list", "character"), TRUE, info = paste("Column:", i)) } # Check that group_by entries are named or the list content is NULL @@ -521,32 +555,43 @@ test_that("Column types of minimal endpoint specification", { # ** Temporary ** # Check that group_by entries are named or is a character NA - expect_equal(unlist(lapply(ep[["group_by"]], - function(x){length(names(x))>0 | identical(x, NA_character_)})), TRUE, - info = paste("Column:", i)) + expect_equal( + unlist(lapply( + ep[["group_by"]], + function(x) { + length(names(x)) > 0 | identical(x, NA_character_) + } + )), TRUE, + info = paste("Column:", i) + ) # Check unnamed list columns lst_cols <- c("stratify_by") - for (i in lst_cols){ + for (i in lst_cols) { # Check column type is list expect_equal(typeof(ep[[i]]), "list", info = paste("Column:", i)) # Check that list entries are character - expect_equal(all(unlist(lapply(ep[[i]], - function(x){is.character(x)}))), TRUE, - info = paste("Column:", i)) + expect_equal( + all(unlist(lapply( + ep[[i]], + function(x) { + is.character(x) + } + ))), TRUE, + info = paste("Column:", i) + ) } # Check function columns - for (i in fn_cols){ + for (i in fn_cols) { # Check column type is list of length 1 expect_equal(typeof(ep[[i]]), "list", info = paste("Column:", i)) # Check that content of each list is language - #expect_equal(typeof(ep[[i]][[1]]), "language", info = paste("Column:", i)) + # expect_equal(typeof(ep[[i]][[1]]), "language", info = paste("Column:", i)) # ** Temporary ** # Check that content of each list is language or NULL expect_equal(typeof(ep[[i]][[1]]) %in% c("language", "NULL"), TRUE, info = paste("Column:", i)) } - }) diff --git a/tests/testthat/test-mk_userdef_fn_dt.R b/tests/testthat/test-mk_userdef_fn_dt.R index 3173f70..9a95e51 100644 --- a/tests/testthat/test-mk_userdef_fn_dt.R +++ b/tests/testthat/test-mk_userdef_fn_dt.R @@ -1,7 +1,6 @@ -test_that("Parse_all_user_function works on table with all valid inputs.", - { -# SETUP ------------------------------------------------------------------- - ep <- mk_ep_0001_base( +test_that("Parse_all_user_function works on table with all valid inputs.", { + # SETUP ------------------------------------------------------------------- + ep <- mk_ep_0001_base( endpoint_label = "a", data_prepare = mk_adae, ) @@ -9,21 +8,23 @@ test_that("Parse_all_user_function works on table with all valid inputs.", endpoints_long <- suppressWarnings(unnest_endpoint_functions(ep)) - expected_names = c("fn_type", - "fn_hash", - "fn_name", - "fn_call_char", - "fn_callable") - character_columns = c("fn_type", "fn_hash", "fn_name", "fn_call_char") + expected_names <- c( + "fn_type", + "fn_hash", + "fn_name", + "fn_call_char", + "fn_callable" + ) + character_columns <- c("fn_type", "fn_hash", "fn_name", "fn_call_char") -# ACT --------------------------------------------------------------------- + # ACT --------------------------------------------------------------------- function_table <- mk_userdef_fn_dt(endpoints_long) -# EXPECT ------------------------------------------------------------------ - column_types = sapply(function_table, class) + # EXPECT ------------------------------------------------------------------ + column_types <- sapply(function_table, class) for (col in character_columns) { expect_type(column_types[col], "character") @@ -32,14 +33,12 @@ test_that("Parse_all_user_function works on table with all valid inputs.", for (callable in function_table$fn_callable) { expect_type(callable, "closure") } - }) -test_that("Duplicate functions are collapsed", - { -# SETUP ------------------------------------------------------------------- +test_that("Duplicate functions are collapsed", { + # SETUP ------------------------------------------------------------------- ep <- rbind( - ep <- mk_ep_0001_base( + ep <- mk_ep_0001_base( endpoint_label = "A", data_prepare = mk_adae ), @@ -53,20 +52,18 @@ test_that("Duplicate functions are collapsed", suppressWarnings(unnest_endpoint_functions(ep)) -# ACT --------------------------------------------------------------------- + # ACT --------------------------------------------------------------------- function_table <- mk_userdef_fn_dt(endpoints_long) -# EXPECT ------------------------------------------------------------------ - n_unique_fun = length(unique(endpoints_long$fn_hash)) + # EXPECT ------------------------------------------------------------------ + n_unique_fun <- length(unique(endpoints_long$fn_hash)) expect_equal(n_unique_fun, nrow(function_table)) - }) -test_that("Parse_all_user_function works when additonal args passed to stat methods", - { -# SETUP ------------------------------------------------------------------- +test_that("Parse_all_user_function works when additonal args passed to stat methods", { + # SETUP ------------------------------------------------------------------- ep <- mk_ep_0001_base( endpoint_label = "a", @@ -82,21 +79,23 @@ test_that("Parse_all_user_function works when additonal args passed to stat meth ep )) - expected_names = c("fn_type", - "fn_hash", - "fn_name", - "fn_call_char", - "fn_callable") - character_columns = c("fn_type", "fn_hash", "fn_name", "fn_call_char") + expected_names <- c( + "fn_type", + "fn_hash", + "fn_name", + "fn_call_char", + "fn_callable" + ) + character_columns <- c("fn_type", "fn_hash", "fn_name", "fn_call_char") -# ACT --------------------------------------------------------------------- + # ACT --------------------------------------------------------------------- function_table <- mk_userdef_fn_dt(endpoints_long) -# EXPECT ------------------------------------------------------------------ + # EXPECT ------------------------------------------------------------------ - column_types = sapply(function_table, class) + column_types <- sapply(function_table, class) for (col in character_columns) { expect_type(column_types[col], "character") @@ -105,36 +104,37 @@ test_that("Parse_all_user_function works when additonal args passed to stat meth for (callable in function_table$fn_callable) { expect_type(callable, "closure") } - }) -test_that("Parse_all_user_function works when passed an emptly function slot", - { - -# SETUP ------------------------------------------------------------------- - ep <- mk_ep_0001_base(endpoint_label = "a", - data_prepare = mk_adae, - stratify_by = list(c("sex2")),) +test_that("Parse_all_user_function works when passed an emptly function slot", { + # SETUP ------------------------------------------------------------------- + ep <- mk_ep_0001_base( + endpoint_label = "a", + data_prepare = mk_adae, + stratify_by = list(c("sex2")), + ) ep <- add_id(ep) endpoints_long <- suppressWarnings(unnest_endpoint_functions( ep, )) - expected_names = c("fn_type", - "fn_hash", - "fn_name", - "fn_call_char", - "fn_callable") - character_columns = c("fn_type", "fn_hash", "fn_name", "fn_call_char") + expected_names <- c( + "fn_type", + "fn_hash", + "fn_name", + "fn_call_char", + "fn_callable" + ) + character_columns <- c("fn_type", "fn_hash", "fn_name", "fn_call_char") -# ACT --------------------------------------------------------------------- + # ACT --------------------------------------------------------------------- function_table <- mk_userdef_fn_dt(endpoints_long) -# EXPECT ------------------------------------------------------------------ - column_types = sapply(function_table, class) + # EXPECT ------------------------------------------------------------------ + column_types <- sapply(function_table, class) for (col in character_columns) { expect_type(column_types[col], "character") diff --git a/tests/testthat/test-parse_function_input.R b/tests/testthat/test-parse_function_input.R index 9470b99..524943a 100644 --- a/tests/testthat/test-parse_function_input.R +++ b/tests/testthat/test-parse_function_input.R @@ -1,10 +1,10 @@ test_that("parse function works with namesspace defined", { - test_data <- rnorm(20, mean=50, sd=100) + test_data <- rnorm(20, mean = 50, sd = 100) # Defining statistical functions of interest: # to be included in endpoints definition. - stat_funcs = list( + stat_funcs <- list( mean, c(base::mean, trim = 0.4), # include arguments. max, @@ -16,21 +16,22 @@ test_that("parse function works with namesspace defined", { }) test_that("functions parsed can be excecuted", { - withr::with_seed(123, {data <- rnbinom(n = 20, size = 2, prob = 0.1)}) + withr::with_seed(123, { + data <- rnbinom(n = 20, size = 2, prob = 0.1) + }) # Defining statistical functions of interest: # to be included in endpoints definition. - stat_funcs = list( + stat_funcs <- list( mean, c(base::mean, trim = 0.4), # include arguments. max ) fn_parsed <- lapply(stat_funcs, parse_function_input) # apply the functions - out <- sapply(fn_parsed, function(fn){ + out <- sapply(fn_parsed, function(fn) { fn(data) }) expect_equal(out, c(14.1, 12.75, 36)) - }) diff --git a/tests/testthat/test-pipeline_manual.R b/tests/testthat/test-pipeline_manual.R index 571318b..66c9d3a 100644 --- a/tests/testthat/test-pipeline_manual.R +++ b/tests/testthat/test-pipeline_manual.R @@ -51,7 +51,7 @@ test_that("Manual pipeline works", { group_by = list(list(RACE = c())), stat_by_strata_by_trt = list( "n_subev" = n_subev, - c("p_subev" = p_subev, a="USUBJID") + c("p_subev" = p_subev, a = "USUBJID") ), stat_by_strata_across_trt = list("n_subev_trt_diff" = n_subev_trt_diff), stat_across_strata_across_trt = list("P-interaction" = contingency2x2_strata_test), @@ -142,7 +142,8 @@ test_that("Manual pipeline works", { as.data.table() ep_stat <- rbind(ep_stat_eval, ep_crit_by_strata_across_trt[!(crit_accept_endpoint)], - fill = TRUE) |> + fill = TRUE + ) |> setorder(endpoint_id, stat_result_id, stat_result_label) expect_equal(nrow(ep_stat), 54) diff --git a/tests/testthat/test-prepare_for_stats.R b/tests/testthat/test-prepare_for_stats.R index 0964d4f..98788b7 100644 --- a/tests/testthat/test-prepare_for_stats.R +++ b/tests/testthat/test-prepare_for_stats.R @@ -6,12 +6,13 @@ test_that("Invalid 'type' errors out ", { # EXPECT ------------------------------------------------------------------ - expect_error(prepare_for_stats( - ep = data.table(), - fn_map = data.table(), - type = "x" - ), - regexp = "'arg' should be one of" + expect_error( + prepare_for_stats( + ep = data.table(), + fn_map = data.table(), + type = "x" + ), + regexp = "'arg' should be one of" ) }) @@ -476,7 +477,6 @@ test_that("base - dataprep", { }) test_that("Check that only strata levels with events are kept", { - # SETUP ------------------------------------------------------------------- ep <- @@ -527,9 +527,9 @@ test_that("Check that only strata levels with events are kept", { apply_criterion_by_strata(ep_crit_endpoint, analysis_data_container, fn_map) ep_crit_by_strata_across_trt <- apply_criterion_by_strata(ep_crit_by_strata_by_trt, - analysis_data_container, - fn_map, - type = "by_strata_across_trt" + analysis_data_container, + fn_map, + type = "by_strata_across_trt" ) @@ -537,15 +537,17 @@ test_that("Check that only strata levels with events are kept", { ep_prep_by_strata_by_trt <- prepare_for_stats(ep_crit_by_strata_across_trt, - analysis_data_container, - fn_map, - type = "stat_by_strata_by_trt") + analysis_data_container, + fn_map, + type = "stat_by_strata_by_trt" + ) ep_prep_by_strata_across_trt <- prepare_for_stats(ep_crit_by_strata_across_trt, - analysis_data_container, - fn_map, - type = "stat_by_strata_across_trt") + analysis_data_container, + fn_map, + type = "stat_by_strata_across_trt" + ) # INSPECT ----------------------------------------------------------------- @@ -557,9 +559,11 @@ test_that("Check that only strata levels with events are kept", { expected_n_combinations <- nrow(unique(dat[, c("AESOC", "RACE", "TRT01A")])) actual_n_combinations <- - nrow(unique(ep_prep_by_strata_by_trt[stat_event_exist == TRUE & - grepl("total", stat_filter) == 0, - c("endpoint_group_filter", "stat_filter")])) + nrow(unique(ep_prep_by_strata_by_trt[ + stat_event_exist == TRUE & + grepl("total", stat_filter) == 0, + c("endpoint_group_filter", "stat_filter") + ])) expect_equal(expected_n_combinations, actual_n_combinations) # Check specific SOC @@ -569,8 +573,8 @@ test_that("Check that only strata levels with events are kept", { expect_equal(nrow(ep_prep_bb_sub[strata_var == "RACE"]), 8) event_index <- ep_prep_bb_sub$event_index[[1]] - expected_stat_event_exist <- unlist(lapply(ep_prep_bb_sub$stat_filter, function(x){ - nrow(dat[list(event_index)][eval(parse(text=x))])>0 + expected_stat_event_exist <- unlist(lapply(ep_prep_bb_sub$stat_filter, function(x) { + nrow(dat[list(event_index)][eval(parse(text = x))]) > 0 })) actual_stat_event_exists <- ep_prep_bb_sub$stat_event_exist expect_equal(expected_stat_event_exist, actual_stat_event_exists) @@ -578,5 +582,4 @@ test_that("Check that only strata levels with events are kept", { # by_strata_across_trt expect_equal(nrow(ep_prep_by_strata_across_trt), 64) expect_equal(all(ep_prep_by_strata_across_trt$stat_event_exist), TRUE) - }) diff --git a/tests/testthat/test-targets.R b/tests/testthat/test-targets.R index ffb1173..aecbee1 100644 --- a/tests/testthat/test-targets.R +++ b/tests/testthat/test-targets.R @@ -1,479 +1,470 @@ -test_that("Base case: targets pipeline works", - { - - # SETUP ------------------------------------------------------------------- - testr::create_local_project() - crit_endpoint <- function(...) { - return(T) - } - crit_sga <- function(...) { - return(T) - } - crit_sgd <- function(...) { - return(T) - } - - mk_ep_def <- function() { - ep <- mk_endpoint_str( - study_metadata = list(), - pop_var = "SAFFL", - pop_value = "Y", - treatment_var = "TRT01A", - treatment_refval = "Xanomeline High Dose", - period_var = "ANL01FL", - period_value = "Y", - stratify_by = list(c("SEX")), - data_prepare = mk_adcm, - endpoint_label = "A", - custom_pop_filter = "TRT01A %in% c('Placebo', 'Xanomeline High Dose')", - group_by = list(list(RACE = c())), - stat_by_strata_by_trt = list("n_subev" = c(n_subev)), - stat_by_strata_across_trt = list("n_subev_trt_diff" = c(n_subev_trt_diff)), - stat_across_strata_across_trt = list("P-interaction" = c(contingency2x2_strata_test)), - crit_endpoint = list(crit_endpoint), - crit_by_strata_by_trt = list(crit_sgd), - crit_by_strata_across_trt = list(crit_sga) - ) - } - - # This is needed because mk_adcm it is calling from a new R session, it - # doesn't have access to the helper-* functions from chef - n_subev <- n_subev - n_subev_trt_diff <- n_subev_trt_diff - contingency2x2_ptest <- contingency2x2_ptest - - use_chef( - pipeline_dir = "pipeline", - r_functions_dir = "R/", - pipeline_id = "01", - mk_endpoint_def_fn = mk_ep_def, - mk_adam_fn = list(mk_adcm), - mk_criteria_fn = list(crit_endpoint, crit_sga, crit_sgd) - ) - - dump("n_subev", file = "R/custom_functions.R") - dump("n_subev_trt_diff", file = "R/custom_functions.R", append = TRUE) - dump("contingency2x2_strata_test", - file = "R/custom_functions.R", - append = TRUE) - # ACT --------------------------------------------------------------------- - - tar_make() - # EXPECT ------------------------------------------------------------------ - x <- tar_meta() %>% as.data.table() - expect_true(all(is.na(x$error))) - tar_load(ep_stat) - expect_equal(NROW(ep_stat), 36) - expect_equal(NCOL(ep_stat), 37) - expect_snapshot(ep_stat$stat_result_value) - }) - -test_that("targets pipeline works no criteria fn and missing by_* functions", - { - - # SETUP ------------------------------------------------------------------- - testr::create_local_project() - - mk_ep_def <- function() { - ep <- mk_endpoint_str( - study_metadata = list(), - pop_var = "SAFFL", - pop_value = "Y", - treatment_var = "TRT01A", - treatment_refval = "Xanomeline High Dose", - period_var = "ANL01FL", - period_value = "Y", - stratify_by = list(c("SEX")), - data_prepare = mk_adcm, - endpoint_label = "A", - custom_pop_filter = "TRT01A %in% c('Placebo', 'Xanomeline High Dose')", - group_by = list(list(RACE = c())), - stat_by_strata_by_trt = list("n_subev" = c(n_subev)) - ) - } - - # This is needed because mk_adcm it is calling from a new R session, it - # doesn't have access to the helper-* functions from chef - n_subev <- n_subev - n_subev_trt_diff <- n_subev_trt_diff - contingency2x2_ptest <- contingency2x2_ptest - - use_chef( - pipeline_dir = "pipeline", - r_functions_dir = "R/", - pipeline_id = "01", - mk_endpoint_def_fn = mk_ep_def, - mk_adam_fn = list(mk_adcm) - ) - dump("n_subev", file = "R/custom_functions.R") - dump("n_subev_trt_diff", file = "R/custom_functions.R", append = TRUE) - dump("contingency2x2_ptest", file = "R/custom_functions.R", append = TRUE) - - # ACT --------------------------------------------------------------------- - tar_make() - - # EXPECT ------------------------------------------------------------------ - x <- tar_meta() %>% as.data.table() - expect_true(all(is.na(x$error))) - tar_load(ep_stat) - expect_equal(NROW(ep_stat), 18) - expect_equal(NCOL(ep_stat), 37) - expect_snapshot(ep_stat$stat_result_value) - }) - -test_that("branching after prepare for stats step works", - { - # SETUP ------------------------------------------------------------------- - testr::create_local_project() - - mk_ep_def <- function() { - ep <- mk_endpoint_str( - study_metadata = list(), - pop_var = "SAFFL", - pop_value = "Y", - treatment_var = "TRT01A", - treatment_refval = "Xanomeline High Dose", - stratify_by = list(c("SEX")), - data_prepare = mk_adae, - custom_pop_filter = "TRT01A %in% c('Placebo', 'Xanomeline High Dose')", - stat_by_strata_by_trt = list("fn_1" = c(n_subev), - "fn_2" = c(n_sub)) - ) - } - - # This is needed because mk_adcm it is calling from a new R session, it - # doesn't have access to the helper-* functions from chef - n_subev <- n_subev - n_subev_trt_diff <- n_subev_trt_diff - contingency2x2_ptest <- contingency2x2_ptest - - use_chef( - pipeline_dir = "pipeline", - r_functions_dir = "R/", - pipeline_id = "01", - mk_endpoint_def_fn = mk_ep_def, - mk_adam_fn = list(mk_adae), - branch_group_size = 1 - - ) - dump("n_subev", file = "R/custom_functions.R") - dump("n_sub", file = "R/custom_functions.R", append = TRUE) - - # ACT --------------------------------------------------------------------- - tar_make() - +test_that("Base case: targets pipeline works", { + # SETUP ------------------------------------------------------------------- + testr::create_local_project() + crit_endpoint <- function(...) { + return(T) + } + crit_sga <- function(...) { + return(T) + } + crit_sgd <- function(...) { + return(T) + } + + mk_ep_def <- function() { + ep <- mk_endpoint_str( + study_metadata = list(), + pop_var = "SAFFL", + pop_value = "Y", + treatment_var = "TRT01A", + treatment_refval = "Xanomeline High Dose", + period_var = "ANL01FL", + period_value = "Y", + stratify_by = list(c("SEX")), + data_prepare = mk_adcm, + endpoint_label = "A", + custom_pop_filter = "TRT01A %in% c('Placebo', 'Xanomeline High Dose')", + group_by = list(list(RACE = c())), + stat_by_strata_by_trt = list("n_subev" = c(n_subev)), + stat_by_strata_across_trt = list("n_subev_trt_diff" = c(n_subev_trt_diff)), + stat_across_strata_across_trt = list("P-interaction" = c(contingency2x2_strata_test)), + crit_endpoint = list(crit_endpoint), + crit_by_strata_by_trt = list(crit_sgd), + crit_by_strata_across_trt = list(crit_sga) + ) + } + + # This is needed because mk_adcm it is calling from a new R session, it + # doesn't have access to the helper-* functions from chef + n_subev <- n_subev + n_subev_trt_diff <- n_subev_trt_diff + contingency2x2_ptest <- contingency2x2_ptest + + use_chef( + pipeline_dir = "pipeline", + r_functions_dir = "R/", + pipeline_id = "01", + mk_endpoint_def_fn = mk_ep_def, + mk_adam_fn = list(mk_adcm), + mk_criteria_fn = list(crit_endpoint, crit_sga, crit_sgd) + ) + + dump("n_subev", file = "R/custom_functions.R") + dump("n_subev_trt_diff", file = "R/custom_functions.R", append = TRUE) + dump("contingency2x2_strata_test", + file = "R/custom_functions.R", + append = TRUE + ) + # ACT --------------------------------------------------------------------- + + tar_make() # EXPECT ------------------------------------------------------------------ - x <- tar_meta() %>% as.data.table() - expect_true(all(is.na(x$error))) - tar_load(ep_stat) - expect_equal(NROW(ep_stat), 12) - expect_equal(NCOL(ep_stat), 37) - expect_snapshot(ep_stat$stat_result_value) + x <- tar_meta() %>% as.data.table() + expect_true(all(is.na(x$error))) + tar_load(ep_stat) + expect_equal(NROW(ep_stat), 36) + expect_equal(NCOL(ep_stat), 37) + expect_snapshot(ep_stat$stat_result_value) }) -test_that("ep_fn_map is always outdated", - { - # SETUP ------------------------------------------------------------------- - testr::create_local_project() - - mk_ep_def <- function() { - ep <- mk_endpoint_str( - study_metadata = list(), - pop_var = "SAFFL", - pop_value = "Y", - treatment_var = "TRT01A", - treatment_refval = "Xanomeline High Dose", - period_var = "ANL01FL", - period_value = "Y", - stratify_by = list(c("SEX")), - data_prepare = mk_adcm, - endpoint_label = "A", - custom_pop_filter = "TRT01A %in% c('Placebo', 'Xanomeline High Dose')", - stat_by_strata_by_trt = list("n_subev" = c(n_subev)), - ) - } - - # This is needed because mk_adcm it is calling from a new R session, it - # doesn't have access to the helper-* functions from chef - n_subev <- n_subev - - use_chef( - pipeline_dir = "pipeline", - r_functions_dir = "R/", - pipeline_id = "01", - mk_endpoint_def_fn = mk_ep_def, - mk_adam_fn = list(mk_adcm) - ) - - dump("n_subev", file = "R/custom_functions.R") - - # ACT --------------------------------------------------------------------- - tar_make(ep_fn_map) - # EXPECT ------------------------------------------------------------------ - expect_equal(tar_outdated(names = c(ep_fn_map, ep, ep_id)), "ep_fn_map") - x <- tar_meta() %>% as.data.table() - expect_true(all(is.na(x$error))) - }) - - -test_that("study_data responds to changes in source data", - { - # SETUP ------------------------------------------------------------------- - testr::create_local_project() - saveRDS(data.table(runif(10)), file = "tmp_data_obj.rds") - mk_test_fn <- function(study_metadata) { - readRDS("tmp_data_obj.rds") - } - mk_ep_def <- function() { - ep <- mk_endpoint_str( - study_metadata = list(), - pop_var = "SAFFL", - pop_value = "Y", - treatment_var = "TRT01A", - treatment_refval = "Xanomeline High Dose", - period_var = "ANL01FL", - period_value = "Y", - stratify_by = list(c("SEX")), - data_prepare = mk_test_fn, - endpoint_label = "A", - custom_pop_filter = "TRT01A %in% c('Placebo', 'Xanomeline High Dose')", - stat_by_strata_by_trt = list("n_subev" = c(n_subev)), - ) - } - - # This is needed because mk_adcm it is calling from a new R session, it - # doesn't have access to the helper-* functions from chef - n_subev <- n_subev - - use_chef( - pipeline_dir = "pipeline", - r_functions_dir = "R/", - pipeline_id = "01", - mk_endpoint_def_fn = mk_ep_def, - mk_adam_fn = list(mk_test_fn) - ) - - dump("n_subev", file = "R/custom_functions.R") - tar_make(study_data) - tar_load(study_data) - x <- tar_meta() %>% as.data.table() - expect_true(all(is.na(x$error))) - before <- study_data$dat - # ACT --------------------------------------------------------------------- - saveRDS(data.table(runif(10)), file = "tmp_data_obj.rds") - tar_make(study_data) - - # EXPECT ------------------------------------------------------------------ - tar_load(study_data) - after <- study_data$dat - expect_equal(intersect(c("study_data"), tar_outdated(names = study_data)), "study_data") - expect_failure(expect_equal(before, after)) - x <- tar_meta() %>% as.data.table() - expect_true(all(is.na(x$error))) - }) - - -test_that("Only affected branches outdated when new strata added", - { - # SETUP ------------------------------------------------------------------- - mk_endpoint_def <- function() { - mk_endpoint_str( - study_metadata = list(), - pop_var = "SAFFL", - pop_value = "Y", - treatment_var = "TRT01A", - treatment_refval = "Xanomeline High Dose", - stratify_by = list(c("SEX")), - group_by = list(list(AESEV = c())), - data_prepare = mk_adae, - custom_pop_filter = "TRT01A %in% c('Placebo', 'Xanomeline High Dose')", - stat_by_strata_by_trt = list( - "fn_1" = c(n_sub), - "fn_2_adae" = c(p_subev) - ) - ) - - } - - # This is needed because mk_adcm it is calling from a new R session, it - # doesn't have access to the helper-* functions from chef - path <- - system.file("templates", package = "chef") |> file.path("template-pipeline.R") - tmp <- readLines(path) - tar_dir({ - dir.create("R") - dump("p_subev", file = "R/custom_functions.R") - dump("n_sub", file = "R/custom_functions.R", append = TRUE) - dump("mk_adae", file = "R/mk_adae.R") - dump("mk_adcm", file = "R/mk_adcm.R") - dump("mk_endpoint_def", file = "R/mk_endpoint_def.R") - - x <- - whisker::whisker.render(tmp, data = list(r_script_dir = "R/")) - writeLines(whisker::whisker.render(tmp, data = list(r_script_dir = - "R/")), con = "_targets.R") - tar_make() - - mk_endpoint_def <- function() { - list( - mk_endpoint_str( - study_metadata = list(), - pop_var = "SAFFL", - pop_value = "Y", - treatment_var = "TRT01A", - treatment_refval = "Xanomeline High Dose", - stratify_by = list(c("SEX")), - group_by = list(list(AESEV = c())), - data_prepare = mk_adae, - custom_pop_filter = "TRT01A %in% c('Placebo', 'Xanomeline High Dose')", - stat_by_strata_by_trt = list( - "fn_1" = c(n_sub), - "fn_2_adae" = c(p_subev) - ) - ), - mk_endpoint_str( - study_metadata = list(), - pop_var = "SAFFL", - pop_value = "Y", - treatment_var = "TRT01A", - treatment_refval = "Xanomeline High Dose", - stratify_by = list(c("SEX")), - data_prepare = mk_adcm, - custom_pop_filter = "TRT01A %in% c('Placebo', 'Xanomeline High Dose')", - stat_by_strata_by_trt = list("fn_2_adcm" = c(n_sub)) - ) - ) |> data.table::rbindlist() - } - dump("mk_endpoint_def", file = "R/mk_endpoint_def.R") - tar_make() - x <- tar_meta() |> data.table::setDT() - - - expect_outdated_patterns <- - c( - "study_data", - "ep_prep_by_strata_by_trt_", - "ep_stat_by_strata_by_trt_", - "ep_crit_by_strata_by_trt_", - "ep_crit_endpoint_" - - ) - - timestamp_re_run_target <- - x[grepl("ep_fn_map", name), time][2] - - # Check that the targets we expected to be skipped were actually - # skipped - actual <- - vapply(expect_outdated_patterns, function(i) { - rgx <- paste0(i, collapse = "|") - compar_dt <- x[grepl(rgx, name), .(name, time)] - NROW(compar_dt[time < timestamp_re_run_target]) == 1 - }, FUN.VALUE = logical(1L)) - - - # We expect a FALSE for study_data, as this target should NOT run - # before ep_fn_map - expect_equal(actual, c(FALSE, TRUE, TRUE, TRUE, TRUE), ignore_attr = TRUE) - - }) - - }) +test_that("targets pipeline works no criteria fn and missing by_* functions", { + # SETUP ------------------------------------------------------------------- + testr::create_local_project() + + mk_ep_def <- function() { + ep <- mk_endpoint_str( + study_metadata = list(), + pop_var = "SAFFL", + pop_value = "Y", + treatment_var = "TRT01A", + treatment_refval = "Xanomeline High Dose", + period_var = "ANL01FL", + period_value = "Y", + stratify_by = list(c("SEX")), + data_prepare = mk_adcm, + endpoint_label = "A", + custom_pop_filter = "TRT01A %in% c('Placebo', 'Xanomeline High Dose')", + group_by = list(list(RACE = c())), + stat_by_strata_by_trt = list("n_subev" = c(n_subev)) + ) + } + + # This is needed because mk_adcm it is calling from a new R session, it + # doesn't have access to the helper-* functions from chef + n_subev <- n_subev + n_subev_trt_diff <- n_subev_trt_diff + contingency2x2_ptest <- contingency2x2_ptest + + use_chef( + pipeline_dir = "pipeline", + r_functions_dir = "R/", + pipeline_id = "01", + mk_endpoint_def_fn = mk_ep_def, + mk_adam_fn = list(mk_adcm) + ) + dump("n_subev", file = "R/custom_functions.R") + dump("n_subev_trt_diff", file = "R/custom_functions.R", append = TRUE) + dump("contingency2x2_ptest", file = "R/custom_functions.R", append = TRUE) + + # ACT --------------------------------------------------------------------- + tar_make() + # EXPECT ------------------------------------------------------------------ + x <- tar_meta() %>% as.data.table() + expect_true(all(is.na(x$error))) + tar_load(ep_stat) + expect_equal(NROW(ep_stat), 18) + expect_equal(NCOL(ep_stat), 37) + expect_snapshot(ep_stat$stat_result_value) +}) -test_that("Check for discordant columns in result data model when having one endpoint spec without grouping and one endpoint spec with grouping", { - - # SETUP ------------------------------------------------------------------- - mk_endpoint_def <- function() { - ep <- mk_endpoint_str( - study_metadata = list(), - pop_var = "SAFFL", - pop_value = "Y", - treatment_var = "TRT01A", - treatment_refval = "Xanomeline High Dose", - stratify_by = list(c("SEX", "AGEGR1")), - data_prepare = mk_adae, - endpoint_label = "A", - custom_pop_filter = - "TRT01A %in% c('Placebo', 'Xanomeline High Dose')", - group_by = list(list( - AESOC = c(), AESEV = c() - )), - stat_by_strata_by_trt = list(c(n_sub)) - ) - - ep2 <- mk_endpoint_str( - data_prepare = mk_advs, - treatment_var = "TRT01A", - treatment_refval = "Xanomeline High Dose", - pop_var = "SAFFL", - pop_value = "Y", - stratify_by = list(c("AGEGR1", "SEX")), - stat_by_strata_by_trt = list(c(n_sub)), - endpoint_label = "Demographics endpoint (categorical measures)" - ) +test_that("branching after prepare for stats step works", { + # SETUP ------------------------------------------------------------------- + testr::create_local_project() + + mk_ep_def <- function() { + ep <- mk_endpoint_str( + study_metadata = list(), + pop_var = "SAFFL", + pop_value = "Y", + treatment_var = "TRT01A", + treatment_refval = "Xanomeline High Dose", + stratify_by = list(c("SEX")), + data_prepare = mk_adae, + custom_pop_filter = "TRT01A %in% c('Placebo', 'Xanomeline High Dose')", + stat_by_strata_by_trt = list( + "fn_1" = c(n_subev), + "fn_2" = c(n_sub) + ) + ) + } + + # This is needed because mk_adcm it is calling from a new R session, it + # doesn't have access to the helper-* functions from chef + n_subev <- n_subev + n_subev_trt_diff <- n_subev_trt_diff + contingency2x2_ptest <- contingency2x2_ptest + + use_chef( + pipeline_dir = "pipeline", + r_functions_dir = "R/", + pipeline_id = "01", + mk_endpoint_def_fn = mk_ep_def, + mk_adam_fn = list(mk_adae), + branch_group_size = 1 + ) + dump("n_subev", file = "R/custom_functions.R") + dump("n_sub", file = "R/custom_functions.R", append = TRUE) + + # ACT --------------------------------------------------------------------- + tar_make() - data.table::rbindlist(list(ep, ep2)) - } + # EXPECT ------------------------------------------------------------------ + x <- tar_meta() %>% as.data.table() + expect_true(all(is.na(x$error))) + tar_load(ep_stat) + expect_equal(NROW(ep_stat), 12) + expect_equal(NCOL(ep_stat), 37) + expect_snapshot(ep_stat$stat_result_value) +}) - mk_advs <- function(study_metadata) { - # Read ADSL - adsl <- data.table::as.data.table(pharmaverseadam::adsl) +test_that("ep_fn_map is always outdated", { + # SETUP ------------------------------------------------------------------- + testr::create_local_project() + + mk_ep_def <- function() { + ep <- mk_endpoint_str( + study_metadata = list(), + pop_var = "SAFFL", + pop_value = "Y", + treatment_var = "TRT01A", + treatment_refval = "Xanomeline High Dose", + period_var = "ANL01FL", + period_value = "Y", + stratify_by = list(c("SEX")), + data_prepare = mk_adcm, + endpoint_label = "A", + custom_pop_filter = "TRT01A %in% c('Placebo', 'Xanomeline High Dose')", + stat_by_strata_by_trt = list("n_subev" = c(n_subev)), + ) + } + + # This is needed because mk_adcm it is calling from a new R session, it + # doesn't have access to the helper-* functions from chef + n_subev <- n_subev + + use_chef( + pipeline_dir = "pipeline", + r_functions_dir = "R/", + pipeline_id = "01", + mk_endpoint_def_fn = mk_ep_def, + mk_adam_fn = list(mk_adcm) + ) + + dump("n_subev", file = "R/custom_functions.R") + + # ACT --------------------------------------------------------------------- + tar_make(ep_fn_map) + # EXPECT ------------------------------------------------------------------ + expect_equal(tar_outdated(names = c(ep_fn_map, ep, ep_id)), "ep_fn_map") + x <- tar_meta() %>% as.data.table() + expect_true(all(is.na(x$error))) +}) - # Filter treatment arms - adsl <- adsl[adsl$TRT01A %in% c("Placebo", "Xanomeline High Dose")] - adsl[1, AGEGR1 := NA_character_] - adsl[2:10, SEX := NA_character_] - # Read ADVS - advs <- data.table::as.data.table(pharmaverseadam::advs) +test_that("study_data responds to changes in source data", { + # SETUP ------------------------------------------------------------------- + testr::create_local_project() + saveRDS(data.table(runif(10)), file = "tmp_data_obj.rds") + mk_test_fn <- function(study_metadata) { + readRDS("tmp_data_obj.rds") + } + mk_ep_def <- function() { + ep <- mk_endpoint_str( + study_metadata = list(), + pop_var = "SAFFL", + pop_value = "Y", + treatment_var = "TRT01A", + treatment_refval = "Xanomeline High Dose", + period_var = "ANL01FL", + period_value = "Y", + stratify_by = list(c("SEX")), + data_prepare = mk_test_fn, + endpoint_label = "A", + custom_pop_filter = "TRT01A %in% c('Placebo', 'Xanomeline High Dose')", + stat_by_strata_by_trt = list("n_subev" = c(n_subev)), + ) + } + + # This is needed because mk_adcm it is calling from a new R session, it + # doesn't have access to the helper-* functions from chef + n_subev <- n_subev + + use_chef( + pipeline_dir = "pipeline", + r_functions_dir = "R/", + pipeline_id = "01", + mk_endpoint_def_fn = mk_ep_def, + mk_adam_fn = list(mk_test_fn) + ) + + dump("n_subev", file = "R/custom_functions.R") + tar_make(study_data) + tar_load(study_data) + x <- tar_meta() %>% as.data.table() + expect_true(all(is.na(x$error))) + before <- study_data$dat + # ACT --------------------------------------------------------------------- + saveRDS(data.table(runif(10)), file = "tmp_data_obj.rds") + tar_make(study_data) - # Identify baseline body weight - advs_bw <- advs[advs$PARAMCD == "WEIGHT" & advs$VISIT == "BASELINE"] + # EXPECT ------------------------------------------------------------------ + tar_load(study_data) + after <- study_data$dat + expect_equal(intersect(c("study_data"), tar_outdated(names = study_data)), "study_data") + expect_failure(expect_equal(before, after)) + x <- tar_meta() %>% as.data.table() + expect_true(all(is.na(x$error))) +}) - # Create new variable BW_BASELINE - advs_bw[["BW_BASELINE"]] <- advs_bw[["AVAL"]] - # Merge ADSL, ADAE and baseline body weight from ADVS - adam_out <- - merge(adsl, advs_bw[, c("BW_BASELINE", "USUBJID")], by = "USUBJID", all.x = TRUE) +test_that("Only affected branches outdated when new strata added", { + # SETUP ------------------------------------------------------------------- + mk_endpoint_def <- function() { + mk_endpoint_str( + study_metadata = list(), + pop_var = "SAFFL", + pop_value = "Y", + treatment_var = "TRT01A", + treatment_refval = "Xanomeline High Dose", + stratify_by = list(c("SEX")), + group_by = list(list(AESEV = c())), + data_prepare = mk_adae, + custom_pop_filter = "TRT01A %in% c('Placebo', 'Xanomeline High Dose')", + stat_by_strata_by_trt = list( + "fn_1" = c(n_sub), + "fn_2_adae" = c(p_subev) + ) + ) + } + + # This is needed because mk_adcm it is calling from a new R session, it + # doesn't have access to the helper-* functions from chef + path <- + system.file("templates", package = "chef") |> file.path("template-pipeline.R") + tmp <- readLines(path) + tar_dir({ + dir.create("R") + dump("p_subev", file = "R/custom_functions.R") + dump("n_sub", file = "R/custom_functions.R", append = TRUE) + dump("mk_adae", file = "R/mk_adae.R") + dump("mk_adcm", file = "R/mk_adcm.R") + dump("mk_endpoint_def", file = "R/mk_endpoint_def.R") + + x <- + whisker::whisker.render(tmp, data = list(r_script_dir = "R/")) + writeLines(whisker::whisker.render(tmp, data = list( + r_script_dir = + "R/" + )), con = "_targets.R") + tar_make() - return(adam_out) + mk_endpoint_def <- function() { + list( + mk_endpoint_str( + study_metadata = list(), + pop_var = "SAFFL", + pop_value = "Y", + treatment_var = "TRT01A", + treatment_refval = "Xanomeline High Dose", + stratify_by = list(c("SEX")), + group_by = list(list(AESEV = c())), + data_prepare = mk_adae, + custom_pop_filter = "TRT01A %in% c('Placebo', 'Xanomeline High Dose')", + stat_by_strata_by_trt = list( + "fn_1" = c(n_sub), + "fn_2_adae" = c(p_subev) + ) + ), + mk_endpoint_str( + study_metadata = list(), + pop_var = "SAFFL", + pop_value = "Y", + treatment_var = "TRT01A", + treatment_refval = "Xanomeline High Dose", + stratify_by = list(c("SEX")), + data_prepare = mk_adcm, + custom_pop_filter = "TRT01A %in% c('Placebo', 'Xanomeline High Dose')", + stat_by_strata_by_trt = list("fn_2_adcm" = c(n_sub)) + ) + ) |> data.table::rbindlist() } + dump("mk_endpoint_def", file = "R/mk_endpoint_def.R") + tar_make() + x <- tar_meta() |> data.table::setDT() + + + expect_outdated_patterns <- + c( + "study_data", + "ep_prep_by_strata_by_trt_", + "ep_stat_by_strata_by_trt_", + "ep_crit_by_strata_by_trt_", + "ep_crit_endpoint_" + ) + + timestamp_re_run_target <- + x[grepl("ep_fn_map", name), time][2] + + # Check that the targets we expected to be skipped were actually + # skipped + actual <- + vapply(expect_outdated_patterns, function(i) { + rgx <- paste0(i, collapse = "|") + compar_dt <- x[grepl(rgx, name), .(name, time)] + NROW(compar_dt[time < timestamp_re_run_target]) == 1 + }, FUN.VALUE = logical(1L)) + + + # We expect a FALSE for study_data, as this target should NOT run + # before ep_fn_map + expect_equal(actual, c(FALSE, TRUE, TRUE, TRUE, TRUE), ignore_attr = TRUE) + }) +}) - # This is needed because mk_adcm it is calling from a new R session, it - # doesn't have access to the helper-* functions from chef - path <- - system.file("templates", package = "chef") |> - file.path("template-pipeline.R") - tmp <- readLines(path) - -# ACT --------------------------------------------------------------------- - - tar_dir({ - dir.create("R") - dump("n_sub", file = "R/custom_functions.R") - dump("mk_adae", file = "R/mk_adae.R") - dump("mk_advs", file = "R/mk_advs.R") - dump("mk_endpoint_def", file = "R/mk_endpoint_def.R") - - x <- whisker::whisker.render(tmp, data = list(r_script_dir = "R/")) - writeLines(whisker::whisker.render(tmp, data = list( - r_script_dir = "R/")), con = "_targets.R") - - tar_make() - -# EXPECT ------------------------------------------------------------------ - - - targets::tar_load(ep_stat) - expect_equal(nrow(ep_stat), 700) - expect_equal(ncol(ep_stat), 37) - expect_equal(sum(ep_stat$endpoint_spec_id == 1), 690) - expect_equal(sum(ep_stat$endpoint_spec_id == 2), 10) - - x <- tar_meta() |> data.table::setDT() - expect_false(any(!is.na(x$error))) - - }) + +test_that("Check for discordant columns in result data model when having one endpoint spec without grouping and one endpoint spec with grouping", { + # SETUP ------------------------------------------------------------------- + mk_endpoint_def <- function() { + ep <- mk_endpoint_str( + study_metadata = list(), + pop_var = "SAFFL", + pop_value = "Y", + treatment_var = "TRT01A", + treatment_refval = "Xanomeline High Dose", + stratify_by = list(c("SEX", "AGEGR1")), + data_prepare = mk_adae, + endpoint_label = "A", + custom_pop_filter = + "TRT01A %in% c('Placebo', 'Xanomeline High Dose')", + group_by = list(list( + AESOC = c(), AESEV = c() + )), + stat_by_strata_by_trt = list(c(n_sub)) + ) + + ep2 <- mk_endpoint_str( + data_prepare = mk_advs, + treatment_var = "TRT01A", + treatment_refval = "Xanomeline High Dose", + pop_var = "SAFFL", + pop_value = "Y", + stratify_by = list(c("AGEGR1", "SEX")), + stat_by_strata_by_trt = list(c(n_sub)), + endpoint_label = "Demographics endpoint (categorical measures)" + ) + + data.table::rbindlist(list(ep, ep2)) + } + + mk_advs <- function(study_metadata) { + # Read ADSL + adsl <- data.table::as.data.table(pharmaverseadam::adsl) + + # Filter treatment arms + adsl <- adsl[adsl$TRT01A %in% c("Placebo", "Xanomeline High Dose")] + adsl[1, AGEGR1 := NA_character_] + adsl[2:10, SEX := NA_character_] + + # Read ADVS + advs <- data.table::as.data.table(pharmaverseadam::advs) + + # Identify baseline body weight + advs_bw <- advs[advs$PARAMCD == "WEIGHT" & advs$VISIT == "BASELINE"] + + # Create new variable BW_BASELINE + advs_bw[["BW_BASELINE"]] <- advs_bw[["AVAL"]] + + # Merge ADSL, ADAE and baseline body weight from ADVS + adam_out <- + merge(adsl, advs_bw[, c("BW_BASELINE", "USUBJID")], by = "USUBJID", all.x = TRUE) + + return(adam_out) + } + + # This is needed because mk_adcm it is calling from a new R session, it + # doesn't have access to the helper-* functions from chef + path <- + system.file("templates", package = "chef") |> + file.path("template-pipeline.R") + tmp <- readLines(path) + + # ACT --------------------------------------------------------------------- + + tar_dir({ + dir.create("R") + dump("n_sub", file = "R/custom_functions.R") + dump("mk_adae", file = "R/mk_adae.R") + dump("mk_advs", file = "R/mk_advs.R") + dump("mk_endpoint_def", file = "R/mk_endpoint_def.R") + + x <- whisker::whisker.render(tmp, data = list(r_script_dir = "R/")) + writeLines(whisker::whisker.render(tmp, data = list( + r_script_dir = "R/" + )), con = "_targets.R") + + tar_make() + + # EXPECT ------------------------------------------------------------------ + + + targets::tar_load(ep_stat) + expect_equal(nrow(ep_stat), 700) + expect_equal(ncol(ep_stat), 37) + expect_equal(sum(ep_stat$endpoint_spec_id == 1), 690) + expect_equal(sum(ep_stat$endpoint_spec_id == 2), 10) + + x <- tar_meta() |> data.table::setDT() + expect_false(any(!is.na(x$error))) + }) }) diff --git a/tests/testthat/test-try_and_validate.R b/tests/testthat/test-try_and_validate.R index 6ff4e55..2ae5a11 100644 --- a/tests/testthat/test-try_and_validate.R +++ b/tests/testthat/test-try_and_validate.R @@ -56,8 +56,7 @@ test_that("validate_stat_output in simple cases", { test_that( "with_error_to_debug creates a debugging session if and only if evaluation fails - no output validation.", { - -# SETUP ------------------------------------------------------------------- + # SETUP ------------------------------------------------------------------- my_fun <- function(x) { @@ -73,7 +72,7 @@ test_that( expect_false(file.exists(filename)) -# ACT --------------------------------------------------------------------- + # ACT --------------------------------------------------------------------- # Check debug is created when a valid call is wrapped @@ -83,7 +82,7 @@ test_that( fixed = TRUE ) -# EXPECT ------------------------------------------------------------------ + # EXPECT ------------------------------------------------------------------ expect_true(file.exists(filename)) @@ -97,9 +96,7 @@ test_that( test_that( "with_error_to_debug creates a debugging session if and only if validation fails - valid calls", { - - -# SETUP ------------------------------------------------------------------- + # SETUP ------------------------------------------------------------------- fn_invalid <- function(x) { @@ -120,13 +117,13 @@ test_that( # Ensure no error and that debug is not create without validation problems. -# ACT --------------------------------------------------------------------- + # ACT --------------------------------------------------------------------- -# EXPECT ------------------------------------------------------------------ + # EXPECT ------------------------------------------------------------------ - expect_equal( + expect_equal( try_and_validate(fn_valid(10), debug_dir = tmp, validator = validate_stat_output diff --git a/tests/testthat/test-unnest_by_fns.R b/tests/testthat/test-unnest_by_fns.R index f77b6af..c6491ad 100644 --- a/tests/testthat/test-unnest_by_fns.R +++ b/tests/testthat/test-unnest_by_fns.R @@ -6,13 +6,14 @@ test_that("Errors on empty data table", { test_that("Errors when provided cols do not exist in data.table", { dt <- data.table::data.table(a = rnorm(10), b = rnorm(10)) - expect_error(unnest_by_fns(dt, cols = c("c", "d")), - "The following columns are not found") + expect_error( + unnest_by_fns(dt, cols = c("c", "d")), + "The following columns are not found" + ) }) -test_that("Expload data model based on fn's works", -{ +test_that("Expload data model based on fn's works", { # SETUP ------------------------------------------------------------------- ep <- mk_ep_0001_base(data_prepare = mk_adae) @@ -25,11 +26,12 @@ test_that("Expload data model based on fn's works", expect_equal(actual$fn_name, "mk_adae") }) -test_that("Duplicate fn's get their own row", -{ +test_that("Duplicate fn's get their own row", { # SETUP ------------------------------------------------------------------- - ep <- rbind(mk_ep_0001_base(data_prepare = mk_adae), - mk_ep_0001_base(data_prepare = mk_adae)) + ep <- rbind( + mk_ep_0001_base(data_prepare = mk_adae), + mk_ep_0001_base(data_prepare = mk_adae) + ) # ACT --------------------------------------------------------------------- actual <- unnest_by_fns(ep, cols = c("data_prepare")) @@ -40,97 +42,91 @@ test_that("Duplicate fn's get their own row", }) -test_that("Unnamed naked fns get nammed", - { - # SETUP ------------------------------------------------------------------- - ep <- mk_ep_0001_base(data_prepare = mk_adae,stat_by_strata_by_trt=n_sub) - # ACT --------------------------------------------------------------------- - actual <- unnest_by_fns(ep, cols = c("data_prepare", "stat_by_strata_by_trt")) - - # EXPECT ------------------------------------------------------------------ - expect_equal(nrow(actual), 2) - expect_equal(actual$fn[[1]], substitute(mk_adae)) - expect_equal(actual$fn[[2]], substitute(n_sub)) - }) - -test_that("Unnamed fns enclosed in list() get nammed", - { - # SETUP ------------------------------------------------------------------- - ep <- mk_ep_0001_base(data_prepare = mk_adae,stat_by_strata_by_trt=list(n_sub)) - # ACT --------------------------------------------------------------------- - actual <- unnest_by_fns(ep, cols = c("data_prepare", "stat_by_strata_by_trt")) - - # EXPECT ------------------------------------------------------------------ - expect_equal(nrow(actual), 2) - expect_equal(actual$fn[[1]], substitute(mk_adae)) - expect_equal(actual$fn[[2]], substitute(n_sub)) - }) - -test_that("Unnamed fns in style pkg::fn enclosed in list() get nammed", - { - # SETUP ------------------------------------------------------------------- - ep <- - - mk_ep_0001_base( - data_prepare = mk_adae, - stat_by_strata_by_trt = list( - n_sub, - stats::AIC, - c(stats::BIC, x = "1"), - c("rst" = n_sub), - c("gtgsr" = stats::acf) - ) - ) - - # ACT --------------------------------------------------------------------- - actual <- unnest_by_fns(ep, cols = c("data_prepare", "stat_by_strata_by_trt")) - - # EXPECT ------------------------------------------------------------------ - expect_equal(nrow(actual), 6) - expect_equal( - actual$fn_name, - c( - "mk_adae", - "n_sub", - "stats::AIC", - "stats::BIC", - "n_sub", - "stats::acf" - ) - ) - - }) - -test_that("Multiple unnamed fns enclosed in list() get nammed", - { - # SETUP ------------------------------------------------------------------- - ep <- mk_ep_0001_base(data_prepare = mk_adae,stat_by_strata_by_trt=list(n_sub, n_subev)) - # ACT --------------------------------------------------------------------- - actual <- unnest_by_fns(ep, cols = c("data_prepare", "stat_by_strata_by_trt")) - - # EXPECT ------------------------------------------------------------------ - expect_equal(nrow(actual), 3) - expect_equal(actual$fn[[1]], substitute(mk_adae)) - expect_equal(actual$fn[[2]], substitute(n_sub)) - expect_equal(actual$fn[[3]], substitute(n_subev)) - }) - -test_that("Unnamed fns supplied in following style: list(c(fn, arg), fn) get nammed", - { - # SETUP ------------------------------------------------------------------- - ep <- - mk_ep_0001_base(data_prepare = mk_adae, - stat_by_strata_by_trt = list( - c(n_sub, subject_var = "USUBJID"), - c("rst" = n_subev), - c("rst" = n_subev, subject_var = "gta") - )) - # ACT --------------------------------------------------------------------- - actual <- unnest_by_fns(ep, cols = c("data_prepare", "stat_by_strata_by_trt")) - - # EXPECT ------------------------------------------------------------------ - - expect_equal(nrow(actual), 4) - expect_equal(actual$fn_name, c("mk_adae", "n_sub", "n_subev", "n_subev")) - - }) +test_that("Unnamed naked fns get nammed", { + # SETUP ------------------------------------------------------------------- + ep <- mk_ep_0001_base(data_prepare = mk_adae, stat_by_strata_by_trt = n_sub) + # ACT --------------------------------------------------------------------- + actual <- unnest_by_fns(ep, cols = c("data_prepare", "stat_by_strata_by_trt")) + + # EXPECT ------------------------------------------------------------------ + expect_equal(nrow(actual), 2) + expect_equal(actual$fn[[1]], substitute(mk_adae)) + expect_equal(actual$fn[[2]], substitute(n_sub)) +}) + +test_that("Unnamed fns enclosed in list() get nammed", { + # SETUP ------------------------------------------------------------------- + ep <- mk_ep_0001_base(data_prepare = mk_adae, stat_by_strata_by_trt = list(n_sub)) + # ACT --------------------------------------------------------------------- + actual <- unnest_by_fns(ep, cols = c("data_prepare", "stat_by_strata_by_trt")) + + # EXPECT ------------------------------------------------------------------ + expect_equal(nrow(actual), 2) + expect_equal(actual$fn[[1]], substitute(mk_adae)) + expect_equal(actual$fn[[2]], substitute(n_sub)) +}) + +test_that("Unnamed fns in style pkg::fn enclosed in list() get nammed", { + # SETUP ------------------------------------------------------------------- + ep <- + mk_ep_0001_base( + data_prepare = mk_adae, + stat_by_strata_by_trt = list( + n_sub, + stats::AIC, + c(stats::BIC, x = "1"), + c("rst" = n_sub), + c("gtgsr" = stats::acf) + ) + ) + + # ACT --------------------------------------------------------------------- + actual <- unnest_by_fns(ep, cols = c("data_prepare", "stat_by_strata_by_trt")) + + # EXPECT ------------------------------------------------------------------ + expect_equal(nrow(actual), 6) + expect_equal( + actual$fn_name, + c( + "mk_adae", + "n_sub", + "stats::AIC", + "stats::BIC", + "n_sub", + "stats::acf" + ) + ) +}) + +test_that("Multiple unnamed fns enclosed in list() get nammed", { + # SETUP ------------------------------------------------------------------- + ep <- mk_ep_0001_base(data_prepare = mk_adae, stat_by_strata_by_trt = list(n_sub, n_subev)) + # ACT --------------------------------------------------------------------- + actual <- unnest_by_fns(ep, cols = c("data_prepare", "stat_by_strata_by_trt")) + + # EXPECT ------------------------------------------------------------------ + expect_equal(nrow(actual), 3) + expect_equal(actual$fn[[1]], substitute(mk_adae)) + expect_equal(actual$fn[[2]], substitute(n_sub)) + expect_equal(actual$fn[[3]], substitute(n_subev)) +}) + +test_that("Unnamed fns supplied in following style: list(c(fn, arg), fn) get nammed", { + # SETUP ------------------------------------------------------------------- + ep <- + mk_ep_0001_base( + data_prepare = mk_adae, + stat_by_strata_by_trt = list( + c(n_sub, subject_var = "USUBJID"), + c("rst" = n_subev), + c("rst" = n_subev, subject_var = "gta") + ) + ) + # ACT --------------------------------------------------------------------- + actual <- unnest_by_fns(ep, cols = c("data_prepare", "stat_by_strata_by_trt")) + + # EXPECT ------------------------------------------------------------------ + + expect_equal(nrow(actual), 4) + expect_equal(actual$fn_name, c("mk_adae", "n_sub", "n_subev", "n_subev")) +}) diff --git a/tests/testthat/test-unnest_endpoint_functions.R b/tests/testthat/test-unnest_endpoint_functions.R index 1f502a6..df043ed 100644 --- a/tests/testthat/test-unnest_endpoint_functions.R +++ b/tests/testthat/test-unnest_endpoint_functions.R @@ -4,17 +4,19 @@ test_that("Unnest all functions", { crit_ep_dummy <- function(...) { return(T) } - crit_sgd_dummy <- function(...){ + crit_sgd_dummy <- function(...) { return(T) } - crit_sga_dummy <- function(...){ + crit_sga_dummy <- function(...) { return(T) } ep <- mk_ep_0001_base( data_prepare = mk_adae, - stat_by_strata_by_trt = list("n_sub" = n_sub, - "n_subev" = n_subev), + stat_by_strata_by_trt = list( + "n_sub" = n_sub, + "n_subev" = n_subev + ), stat_by_strata_across_trt = list("n_subev_trt_diff" = n_subev_trt_diff), stat_across_strata_across_trt = list("P-interaction" = contingency2x2_strata_test), crit_endpoint = list(crit_ep_dummy), @@ -45,7 +47,9 @@ test_that("Unnest all functions", { # expect_equal(all(unlist(lapply(ep_fn[["fn"]], function(x){typeof(x) == "language"}))), TRUE) # ** Temporary ** # Check that content of each fn is language or symbol - expect_equal(all(unlist(lapply(ep_fn[["fn"]], function(x){typeof(x) %in% c("language", "symbol")}))), TRUE) + expect_equal(all(unlist(lapply(ep_fn[["fn"]], function(x) { + typeof(x) %in% c("language", "symbol") + }))), TRUE) # Check uniqueness of fn_hash expect_equal(anyDuplicated(ep_fn[["fn_hash"]]), 0) @@ -63,10 +67,12 @@ test_that("Unnest all functions", { "crit_sgd_dummy" = "crit_by_strata_by_trt", "crit_sga_dummy" = "crit_by_strata_across_trt" ) - expect_equal(all(apply(ep_fn, 1, - function(x) { - return(x[["fn_type"]] == lookup[[x[["fn_name"]]]]) - })), TRUE) + expect_equal(all(apply( + ep_fn, 1, + function(x) { + return(x[["fn_type"]] == lookup[[x[["fn_name"]]]]) + } + )), TRUE) }) @@ -76,10 +82,10 @@ test_that("Unnest criterion functions", { crit_ep_dummy <- function(...) { return(T) } - crit_sgd_dummy <- function(...){ + crit_sgd_dummy <- function(...) { return(T) } - crit_sga_dummy <- function(...){ + crit_sga_dummy <- function(...) { return(T) } @@ -87,7 +93,8 @@ test_that("Unnest criterion functions", { data_prepare = mk_adae, stat_by_strata_by_trt = list( "n_sub" = n_sub, - "n_subev" = n_subev), + "n_subev" = n_subev + ), stat_by_strata_across_trt = list("n_subev_trt_diff" = n_subev_trt_diff), stat_across_strata_across_trt = list("P-interaction" = contingency2x2_ptest), crit_endpoint = list(crit_ep_dummy), @@ -97,13 +104,15 @@ test_that("Unnest criterion functions", { ep <- add_id(ep) - fn_cols <- c("crit_endpoint", "crit_by_strata_by_trt", - "crit_by_strata_across_trt") + fn_cols <- c( + "crit_endpoint", "crit_by_strata_by_trt", + "crit_by_strata_across_trt" + ) # ACT --------------------------------------------------------------------- - ep_fn <- suppressWarnings(unnest_endpoint_functions(ep, fn_cols=fn_cols)) + ep_fn <- suppressWarnings(unnest_endpoint_functions(ep, fn_cols = fn_cols)) # EXPECT ------------------------------------------------------------------ @@ -121,7 +130,9 @@ test_that("Unnest criterion functions", { # expect_equal(all(unlist(lapply(ep_fn[["fn"]], function(x){typeof(x) == "language"}))), TRUE) # ** Temporary ** # Check that content of each fn is language or symbol - expect_equal(all(unlist(lapply(ep_fn[["fn"]], function(x){typeof(x) %in% c("language", "symbol")}))), TRUE) + expect_equal(all(unlist(lapply(ep_fn[["fn"]], function(x) { + typeof(x) %in% c("language", "symbol") + }))), TRUE) # Check uniqueness of fn_hash expect_equal(anyDuplicated(ep_fn[["fn_hash"]]), 0) @@ -134,10 +145,12 @@ test_that("Unnest criterion functions", { "crit_sgd_dummy" = "crit_by_strata_by_trt", "crit_sga_dummy" = "crit_by_strata_across_trt" ) - expect_equal(all(apply(ep_fn, 1, - function(x) { - return(x[["fn_type"]] == lookup[[x[["fn_name"]]]]) - })), TRUE) + expect_equal(all(apply( + ep_fn, 1, + function(x) { + return(x[["fn_type"]] == lookup[[x[["fn_name"]]]]) + } + )), TRUE) }) @@ -146,8 +159,10 @@ test_that("Unnest statistical functions", { ep <- mk_ep_0001_base( data_prepare = mk_adae, - stat_by_strata_by_trt = list("n_sub" = n_sub, - "n_subev" = n_subev), + stat_by_strata_by_trt = list( + "n_sub" = n_sub, + "n_subev" = n_subev + ), stat_by_strata_across_trt = list("n_subev_trt_diff" = n_subev_trt_diff), stat_across_strata_across_trt = list("P-interaction" = contingency2x2_strata_test) ) @@ -159,7 +174,7 @@ test_that("Unnest statistical functions", { # ACT --------------------------------------------------------------------- - ep_fn <- suppressWarnings(unnest_endpoint_functions(ep, fn_cols=fn_cols)) + ep_fn <- suppressWarnings(unnest_endpoint_functions(ep, fn_cols = fn_cols)) # EXPECT ------------------------------------------------------------------ @@ -177,7 +192,9 @@ test_that("Unnest statistical functions", { # expect_equal(all(unlist(lapply(ep_fn[["fn"]], function(x){typeof(x) == "language"}))), TRUE) # ** Temporary ** # Check that content of each fn is language or symbol - expect_equal(all(unlist(lapply(ep_fn[["fn"]], function(x){typeof(x) %in% c("language", "symbol")}))), TRUE) + expect_equal(all(unlist(lapply(ep_fn[["fn"]], function(x) { + typeof(x) %in% c("language", "symbol") + }))), TRUE) # Check uniqueness of fn_hash expect_equal(anyDuplicated(ep_fn[["fn_hash"]]), 0) @@ -191,10 +208,12 @@ test_that("Unnest statistical functions", { "n_subev_trt_diff" = "stat_by_strata_across_trt", "P-interaction" = "stat_across_strata_across_trt" ) - expect_equal(all(apply(ep_fn, 1, - function(x) { - return(x[["fn_type"]] == lookup[[x[["fn_name"]]]]) - })), TRUE) + expect_equal(all(apply( + ep_fn, 1, + function(x) { + return(x[["fn_type"]] == lookup[[x[["fn_name"]]]]) + } + )), TRUE) }) test_that("Unnest adam and adsl functions", { @@ -211,7 +230,7 @@ test_that("Unnest adam and adsl functions", { # ACT --------------------------------------------------------------------- - ep_fn <- suppressWarnings(unnest_endpoint_functions(ep, fn_cols=fn_cols)) + ep_fn <- suppressWarnings(unnest_endpoint_functions(ep, fn_cols = fn_cols)) # EXPECT ------------------------------------------------------------------ @@ -229,7 +248,9 @@ test_that("Unnest adam and adsl functions", { # expect_equal(all(unlist(lapply(ep_fn[["fn"]], function(x){typeof(x) == "language"}))), TRUE) # ** Temporary ** # Check that content of each fn is language or symbol - expect_equal(all(unlist(lapply(ep_fn[["fn"]], function(x){typeof(x) %in% c("language", "symbol")}))), TRUE) + expect_equal(all(unlist(lapply(ep_fn[["fn"]], function(x) { + typeof(x) %in% c("language", "symbol") + }))), TRUE) # Check uniqueness of fn_hash expect_equal(anyDuplicated(ep_fn[["fn_hash"]]), 0) @@ -240,8 +261,10 @@ test_that("Unnest adam and adsl functions", { lookup <- c( "mk_adae" = "data_prepare" ) - expect_equal(all(apply(ep_fn, 1, - function(x) { - return(x[["fn_type"]] == lookup[[x[["fn_name"]]]]) - })), TRUE) + expect_equal(all(apply( + ep_fn, 1, + function(x) { + return(x[["fn_type"]] == lookup[[x[["fn_name"]]]]) + } + )), TRUE) }) diff --git a/tests/testthat/test-use_chef.R b/tests/testthat/test-use_chef.R index e110df7..9049c66 100644 --- a/tests/testthat/test-use_chef.R +++ b/tests/testthat/test-use_chef.R @@ -1,156 +1,156 @@ -test_that("use_chef makes top-level dirs and files", - { - # SETUP ------------------------------------------------------------------- - testr::skip_on_devops() - testr::create_local_project() - - # ACT --------------------------------------------------------------------- - use_chef(pipeline_id = "001") - - # EXPECT ------------------------------------------------------------------ - actual <- list.dirs() - expect_equal(actual, c(".", "./R", "./pipeline")) - expect_equal(list.files(), sort(c("R", "_targets.yaml", "pipeline"))) - }) - -test_that("use_chef makes top-level dirs and fils when in Rproj", - { - # SETUP ------------------------------------------------------------------- - testr::skip_on_devops() - testr::create_local_project(rstudio = TRUE) - # ACT --------------------------------------------------------------------- - use_chef(pipeline_id = "001") - - # EXPECT ------------------------------------------------------------------ - actual <- list.dirs() - expect_equal(actual, c(".", "./R", "./pipeline")) - proj_files <- list.files( pattern = "\\.Rproj$") - actual <- setdiff(list.files(), proj_files) - expect_equal(actual, sort(c("R", "_targets.yaml", "pipeline"))) - }) - - -test_that("use_chef writes default R files", - { - # SETUP ------------------------------------------------------------------- - testr::skip_on_devops() - testr::create_local_project() - - # ACT --------------------------------------------------------------------- - use_chef(pipeline_id = "001") - - # EXPECT ------------------------------------------------------------------ - expect_equal(list.files("R/"), - sort(c("mk_adam_scaffold.R", "mk_endpoint_def.R", "packages.R"))) - expect_equal(list.files("pipeline/"), - c("pipeline_001.R")) - - }) - -test_that("use_chef writes ammnog crit functions", - { - # SETUP ------------------------------------------------------------------- - testr::skip_on_devops() - testr::create_local_project() - crit_endpoint <- function() { - "check" - } - # ACT --------------------------------------------------------------------- - use_chef(pipeline_id = "001", mk_criteria_fn = crit_endpoint) - - # EXPECT ------------------------------------------------------------------ - actual <- list.files("R/") - expect_equal( - actual, - c( - "crit_endpoint.R", - "mk_adam_scaffold.R", - "mk_endpoint_def.R", - "packages.R" - ) - ) - x <- readLines("R/crit_endpoint.R") - expect_true(any(grepl("\"check\"", x = x))) - }) - -test_that("use_chef writes custom mk_endpoint_def fn, and uses standard name", - { - # SETUP ------------------------------------------------------------------- - testr::skip_on_devops() - testr::create_local_project() - mk_endpoint_custom <- function() { - "check" - } - # ACT --------------------------------------------------------------------- - use_chef(pipeline_id = "001", mk_endpoint_def_fn = mk_endpoint_custom) - - # EXPECT ------------------------------------------------------------------ - - actual <- list.files("R/") - expect_equal(actual, - c("mk_adam_scaffold.R", "mk_endpoint_def.R", "packages.R")) - x <- readLines("R/mk_endpoint_def.R") - expect_true(any(grepl("\"check\"", x = x))) - }) - - -test_that("use_chef writes custom mk_adam fn", - { - # SETUP ------------------------------------------------------------------- - testr::skip_on_devops() - testr::create_local_project() - mk_adam_custom <- function() { - "check" - } - # ACT --------------------------------------------------------------------- - use_chef(pipeline_id = "001", mk_adam_fn = mk_adam_custom) - - # EXPECT ------------------------------------------------------------------ - actual <- list.files("R/") - expect_equal(actual, - c( - "mk_adam_custom.R", - "mk_endpoint_def.R", - "packages.R" - )) - x <- readLines("R/mk_adam_custom.R") - expect_true(any(grepl("\"check\"", x = x))) - }) - -test_that("use_chef writes multiple mk_adam fn's", - { - # SETUP ------------------------------------------------------------------- - testr::skip_on_devops() - testr::create_local_project() - mk_adam_custom <- function() { - "check" - } - mk_adam_custom_2 <- function() { - "check_2" - } - # ACT --------------------------------------------------------------------- - use_chef( - pipeline_id = "001", - mk_adam_fn = list(mk_adam_custom, mk_adam_custom_2) - ) - - # EXPECT ------------------------------------------------------------------ - actual <- list.files("R/") - expect_equal( - actual, - c( - "mk_adam_custom.R", - "mk_adam_custom_2.R", - "mk_endpoint_def.R", - "packages.R" - ) - ) - x <- readLines("R/mk_adam_custom.R") - expect_true(any(grepl("\"check\"", x = x))) - - x <- readLines("R/mk_adam_custom_2.R") - expect_true(any(grepl("\"check_2\"", x = x))) - }) +test_that("use_chef makes top-level dirs and files", { + # SETUP ------------------------------------------------------------------- + testr::skip_on_devops() + testr::create_local_project() + + # ACT --------------------------------------------------------------------- + use_chef(pipeline_id = "001") + + # EXPECT ------------------------------------------------------------------ + actual <- list.dirs() + expect_equal(actual, c(".", "./R", "./pipeline")) + expect_equal(list.files(), sort(c("R", "_targets.yaml", "pipeline"))) +}) + +test_that("use_chef makes top-level dirs and fils when in Rproj", { + # SETUP ------------------------------------------------------------------- + testr::skip_on_devops() + testr::create_local_project(rstudio = TRUE) + # ACT --------------------------------------------------------------------- + use_chef(pipeline_id = "001") + + # EXPECT ------------------------------------------------------------------ + actual <- list.dirs() + expect_equal(actual, c(".", "./R", "./pipeline")) + proj_files <- list.files(pattern = "\\.Rproj$") + actual <- setdiff(list.files(), proj_files) + expect_equal(actual, sort(c("R", "_targets.yaml", "pipeline"))) +}) + + +test_that("use_chef writes default R files", { + # SETUP ------------------------------------------------------------------- + testr::skip_on_devops() + testr::create_local_project() + + # ACT --------------------------------------------------------------------- + use_chef(pipeline_id = "001") + + # EXPECT ------------------------------------------------------------------ + expect_equal( + list.files("R/"), + sort(c("mk_adam_scaffold.R", "mk_endpoint_def.R", "packages.R")) + ) + expect_equal( + list.files("pipeline/"), + c("pipeline_001.R") + ) +}) + +test_that("use_chef writes ammnog crit functions", { + # SETUP ------------------------------------------------------------------- + testr::skip_on_devops() + testr::create_local_project() + crit_endpoint <- function() { + "check" + } + # ACT --------------------------------------------------------------------- + use_chef(pipeline_id = "001", mk_criteria_fn = crit_endpoint) + + # EXPECT ------------------------------------------------------------------ + actual <- list.files("R/") + expect_equal( + actual, + c( + "crit_endpoint.R", + "mk_adam_scaffold.R", + "mk_endpoint_def.R", + "packages.R" + ) + ) + x <- readLines("R/crit_endpoint.R") + expect_true(any(grepl("\"check\"", x = x))) +}) + +test_that("use_chef writes custom mk_endpoint_def fn, and uses standard name", { + # SETUP ------------------------------------------------------------------- + testr::skip_on_devops() + testr::create_local_project() + mk_endpoint_custom <- function() { + "check" + } + # ACT --------------------------------------------------------------------- + use_chef(pipeline_id = "001", mk_endpoint_def_fn = mk_endpoint_custom) + + # EXPECT ------------------------------------------------------------------ + + actual <- list.files("R/") + expect_equal( + actual, + c("mk_adam_scaffold.R", "mk_endpoint_def.R", "packages.R") + ) + x <- readLines("R/mk_endpoint_def.R") + expect_true(any(grepl("\"check\"", x = x))) +}) + + +test_that("use_chef writes custom mk_adam fn", { + # SETUP ------------------------------------------------------------------- + testr::skip_on_devops() + testr::create_local_project() + mk_adam_custom <- function() { + "check" + } + # ACT --------------------------------------------------------------------- + use_chef(pipeline_id = "001", mk_adam_fn = mk_adam_custom) + + # EXPECT ------------------------------------------------------------------ + actual <- list.files("R/") + expect_equal( + actual, + c( + "mk_adam_custom.R", + "mk_endpoint_def.R", + "packages.R" + ) + ) + x <- readLines("R/mk_adam_custom.R") + expect_true(any(grepl("\"check\"", x = x))) +}) + +test_that("use_chef writes multiple mk_adam fn's", { + # SETUP ------------------------------------------------------------------- + testr::skip_on_devops() + testr::create_local_project() + mk_adam_custom <- function() { + "check" + } + mk_adam_custom_2 <- function() { + "check_2" + } + # ACT --------------------------------------------------------------------- + use_chef( + pipeline_id = "001", + mk_adam_fn = list(mk_adam_custom, mk_adam_custom_2) + ) + + # EXPECT ------------------------------------------------------------------ + actual <- list.files("R/") + expect_equal( + actual, + c( + "mk_adam_custom.R", + "mk_adam_custom_2.R", + "mk_endpoint_def.R", + "packages.R" + ) + ) + x <- readLines("R/mk_adam_custom.R") + expect_true(any(grepl("\"check\"", x = x))) + + x <- readLines("R/mk_adam_custom_2.R") + expect_true(any(grepl("\"check_2\"", x = x))) +}) test_that("use_chef set-up in README works", { @@ -219,5 +219,4 @@ test_that("use_chef with custom pipeline_dir names works", { ) # EXPECT ------------------------------------------------------------------ expect_equal(list.files(path = "./pipeline"), "pipeline_01.R") - }) diff --git a/tests/testthat/test-validate_usr_fn_args.R b/tests/testthat/test-validate_usr_fn_args.R index 8fbef06..ba245ad 100644 --- a/tests/testthat/test-validate_usr_fn_args.R +++ b/tests/testthat/test-validate_usr_fn_args.R @@ -1,6 +1,5 @@ test_that("error if expecting more variables", { - - my_data_prepare <- function(study_metadata, some_specific_var){ + my_data_prepare <- function(study_metadata, some_specific_var) { a <- study_metadata b <- some_specific_var } @@ -12,15 +11,14 @@ test_that("error if expecting more variables", { ), sprintf( "Function (%s) of type (%s) expects argument(s) which is not supplied", - "my_data_prepare", "data_prepare"), - fixed=TRUE + "my_data_prepare", "data_prepare" + ), + fixed = TRUE ) - - }) -test_that("error is not thrown for partialized functions",{ - my_data_prepare <- function(study_metadata, some_specific_var){ +test_that("error is not thrown for partialized functions", { + my_data_prepare <- function(study_metadata, some_specific_var) { a <- study_metadata b <- some_specific_var @@ -39,26 +37,25 @@ test_that("error is not thrown for partialized functions",{ ), sprintf( "Function (%s) of type (%s) expects argument(s) which is not supplied", - "my_data_prepare", "data_prepare" ), - fixed=TRUE + "my_data_prepare", "data_prepare" + ), + fixed = TRUE ) expect_na_or_null( validate_usr_fn_args( fn = my_data_partial, fn_type = "data_prepare" - ) + ) ) -} -) - -test_that("Under defined functions fail, but is rescued by dots.",{ +}) - my_fun <- function(){ - 1+1 - } - my_fun_dots <- function(...){ - 1+1 +test_that("Under defined functions fail, but is rescued by dots.", { + my_fun <- function() { + 1 + 1 + } + my_fun_dots <- function(...) { + 1 + 1 } expect_error( @@ -67,7 +64,7 @@ test_that("Under defined functions fail, but is rescued by dots.",{ fn_type = "data_prepare" ), "is supplied arguments it does not expect", - fixed=TRUE + fixed = TRUE ) expect_na_or_null( @@ -76,39 +73,36 @@ test_that("Under defined functions fail, but is rescued by dots.",{ fn_type = "data_prepare" ) ) - }) -test_that("Ekstra args but with default args are allowed",{ - my_data_prep <- function(study_metadata, arg_no_default, ...){ +test_that("Ekstra args but with default args are allowed", { + my_data_prep <- function(study_metadata, arg_no_default, ...) { message(study_metadata, arg_no_default, ...) } expect_error( validate_usr_fn_args( fn = my_data_prep, - fn_type = "data_prepare"), + fn_type = "data_prepare" + ), "expects argument(s) which is not supplied", - fixed=TRUE - ) + fixed = TRUE + ) - my_data_prep <- function(study_metadata, arg_with_default=1, ...){ + my_data_prep <- function(study_metadata, arg_with_default = 1, ...) { message(study_metadata, arg_with_default) } expect_na_or_null( validate_usr_fn_args( - fn=my_data_prep, + fn = my_data_prep, fn_type = "data_prepare" ) ) - - }) -test_that("Test implementation in mk_userdef_fn_dt",{ - +test_that("Test implementation in mk_userdef_fn_dt", { crit_endpoint <- function(...) { return(T) } @@ -119,8 +113,12 @@ test_that("Test implementation in mk_userdef_fn_dt",{ return(T) } - stat_bad_input <- function(dat, missing_arg){"woooh"} - stat_good_input <- function(dat, cell_index, defaulted_arg=1, ...){"wububu"} + stat_bad_input <- function(dat, missing_arg) { + "woooh" + } + stat_good_input <- function(dat, cell_index, defaulted_arg = 1, ...) { + "wububu" + } ep_good <- mk_endpoint_str( study_metadata = list(), @@ -174,19 +172,17 @@ test_that("Test implementation in mk_userdef_fn_dt",{ ep_fn_map_good <- suppressWarnings(unnest_endpoint_functions(ep_good)) -# ACT --------------------------------------------------------------------- + # ACT --------------------------------------------------------------------- expect_true( inherits( mk_userdef_fn_dt(ep_fn_map_good, env = environment()), "data.table" - ) + ) ) expect_error( mk_userdef_fn_dt(ep_fn_map_err, env = environment()), "Function (stat_bad_input) of type (stat_by_strata_by_trt) expects argument(s) which is not supplied", - fixed=TRUE + fixed = TRUE ) - - })