diff --git a/.github/workflows/R-CMD-check-devel.yaml b/.github/workflows/R-CMD-check-devel.yaml index 22eae00a..55da5fcc 100644 --- a/.github/workflows/R-CMD-check-devel.yaml +++ b/.github/workflows/R-CMD-check-devel.yaml @@ -18,11 +18,9 @@ jobs: fail-fast: false matrix: config: - - {os: macOS-latest, r: 'release'} - - {os: windows-latest, r: 'release'} - - {os: ubuntu-latest, r: 'devel', http-user-agent: 'release'} - - {os: ubuntu-latest, r: 'release'} - - {os: ubuntu-latest, r: 'oldrel-1'} + - {os: macOS-latest, r: 'renv'} + - {os: windows-latest, r: 'renv'} + - {os: ubuntu-latest, r: 'renv'} env: GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} @@ -43,16 +41,11 @@ jobs: - uses: r-lib/actions/setup-pandoc@v2 - uses: r-lib/actions/setup-r@v2 - - uses: r-lib/actions/setup-renv@v2 with: r-version: ${{ matrix.config.r }} - http-user-agent: ${{ matrix.config.http-user-agent }} use-public-rspm: true - extra-packages: rcmdcheck - - uses: r-lib/actions/setup-r-dependencies@v2 - with: - extra-packages: rcmdcheck + - uses: r-lib/actions/setup-renv@v2 # likely not needed since 'r-lib/actions/check-r-package@v2' will build # the pkg, but including it for consistency with other workflows diff --git a/.github/workflows/pkgdown.yaml b/.github/workflows/pkgdown.yaml index 84edbf33..ca1b0577 100644 --- a/.github/workflows/pkgdown.yaml +++ b/.github/workflows/pkgdown.yaml @@ -27,14 +27,12 @@ jobs: - uses: r-lib/actions/setup-r@v2 with: use-public-rspm: true + r-version: 'renv' - uses: r-lib/actions/setup-renv@v2 - with: - extra-packages: any::pkgdown, local::. - needs: website - name: Install specific pkgdown version - run: install.packages("remotes") ; remotes::install_version("pkgdown", version = "2.0.3", repos = "cran.rstudio.com", dependencies = FALSE) + run: remotes::install_version("pkgdown", version = "2.0.3", repos = "cran.rstudio.com", dependencies = FALSE) shell: Rscript {0} - name: Install tidyCDISC diff --git a/.github/workflows/test-coverage.yaml b/.github/workflows/test-coverage.yaml index 880e83bb..4cb21830 100644 --- a/.github/workflows/test-coverage.yaml +++ b/.github/workflows/test-coverage.yaml @@ -22,10 +22,9 @@ jobs: - uses: r-lib/actions/setup-r@v2 with: use-public-rspm: true + r-version: 'renv' - uses: r-lib/actions/setup-renv@v2 - with: - extra-packages: covr - name: Install tidyCDISC shell: bash diff --git a/DESCRIPTION b/DESCRIPTION index 9ee87e15..2ec9bdb3 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: tidyCDISC Title: Quick Table Generation & Exploratory Analyses on ADaM-Ish Datasets -Version: 0.2.1 +Version: 0.2.1.9003 Authors@R: c( person("Aaron", "Clark", , "clark.aaronchris@gmail.com", role = c("aut", "cre"), comment = c(ORCID = "0000-0002-0123-0970")), @@ -50,8 +50,10 @@ Imports: gt, haven, IDEAFilter, + jsonlite, plotly, purrr, + R6, rlang, rmarkdown, shiny, diff --git a/NAMESPACE b/NAMESPACE index 728c434c..cd4a111a 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,8 +1,10 @@ # Generated by roxygen2: do not edit by hand +export(addBlock) export(app_methods) export(col_for_list_expr) export(common_rownames) +export(createBlockdata) export(data_to_filter) export(data_to_use_str) export(get_levels) @@ -10,10 +12,15 @@ export(prep_adae) export(prep_adsl) export(prep_bds) export(pretty_IDs) +export(removeBlock) export(run_app) +export(setGroup) +export(setTitle) export(std_footnote) export(tg_gt) export(varN_fctr_reorder) +export(writeJSON) +import(R6) import(dplyr) import(shiny) importFrom(GGally,ggsurv) @@ -65,6 +72,9 @@ importFrom(gt,text_transform) importFrom(haven,read_sas) importFrom(haven,zap_formats) importFrom(haven,zap_label) +importFrom(jsonlite,read_json) +importFrom(jsonlite,toJSON) +importFrom(jsonlite,write_json) importFrom(plotly,add_annotations) importFrom(plotly,config) importFrom(plotly,ggplotly) diff --git a/NEWS.md b/NEWS.md index 4eb72db7..ca508f66 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,9 @@ +# tidyCDISC (development version) +* Moved "recipe" for standard table creation from JavaScript to JSON file (#167) +* Improved code determining which standard tables to provide as options based on data uploaded (#167) +* Fixed bug causing standard tables to run twice when grouping selected (#167) +* Added var option functionality to "recipe" creation +* Added a new R6 class to create blockData (#126) # tidyCDISC 0.2.1 (CRAN Release) @@ -17,7 +23,7 @@ * Fixed bug where selected filters were not being applied when 'Apply Filters' was toggled on (#175) * Fixed bug where plots' visual appeal was destroyed when faceting variable labels were too long (#200) * Fixed bug where scatter plot wouldn't display by categorical variable with `NA` values (#192) -- Allowed for one-element lists in heatmap axis dropdowns (#214) +* Allowed for one-element lists in heatmap axis dropdowns (#214). ### Individual Explorer * Updated the look of the time visualization (#194) diff --git a/R/blockData.R b/R/blockData.R new file mode 100644 index 00000000..e18a26c4 --- /dev/null +++ b/R/blockData.R @@ -0,0 +1,535 @@ +#' @import R6 +#' @noRd +table_blocks <- + R6::R6Class("table_blocks", + list( + #' @field datalist A list of ADaM-ish datasets used to generate the table + datalist = NULL, + #' @field all_rows A list of parameters/fields from the datalist with descriptions + all_rows = NULL, + #' @field blocks A data frame containing the block data + blocks = dplyr::tibble( + agg = character(), + block = character(), + dataset = character(), + dropdown = character(), + filter = character(), + S3 = list(), + gt_group = glue::glue(), + label = character(), + label_source = character() + ), + #' @field title A string used for table title + title = character(), + #' @field group_by A string indicating the field to use for grouping the table + group_by = NULL, + #' @description + #' Create a new block data object + #' @param datalist A list of ADaM-ish datasets used to generate the table + #' @param title The title for the table + initialize = function(datalist, title) { + self$datalist <- datalist + + private$tbl_key <- paste("tbl", round(runif(1)*100000000), sep = "_") + if (missing(title) || length(title) != 1 || !is.character(title)) + title <- private$tbl_key + + self$title <- title + + init <- sapply(datalist, function(x) "PARAMCD" %in% colnames(x) & !("CNSR" %in% colnames(x))) + BDS <- datalist[init] + + ADSL <- datalist$ADSL + metadata <- data.frame(col_names = colnames(ADSL)) + metadata$code <- NA + + for (i in 1:nrow(metadata)) { + if("label" %in% names(attributes(ADSL[[metadata$col_names[i]]]))){ + metadata$code[i] <- attr(ADSL[[metadata$col_names[i]]], "label") + } + } + + new_list <- lapply(BDS, function(x) x %>% select(PARAMCD, PARAM) %>% distinct()) + + new_list[[length(new_list) + 1 ]] <- metadata + names(new_list)[length(new_list)] <- "ADSL" + + # only display ADAE column blocks if an ADAE is uploaded! + if ("ADAE" %in% names(datalist)) { + # this also doesn't need to depend on pre-filters + ADAE <- datalist$ADAE + # Display variable blocks that are only unique to ADAE + ADAE_blocks <- data.frame( + col_names = dplyr::setdiff(colnames(ADAE), metadata$col_names) + ) + ADAE_blocks$code <- NA + + for (i in 1:nrow(ADAE_blocks)) { + if("label" %in% names(attributes(ADAE[[ADAE_blocks$col_names[i]]]))){ + ADAE_blocks$code[i] <- attr(ADAE[[ADAE_blocks$col_names[i]]], "label") + } + } + new_list[[length(new_list) + 1 ]] <- ADAE_blocks + names(new_list)[length(new_list)] <- "ADAE" + } + + self$all_rows <- new_list + + private$my_weeks <- + if (!any(purrr::map_lgl(datalist, ~"AVISIT" %in% colnames(.x)))) { + NULL + } else { + create_avisit(datalist, BDS) %>% + as.vector() + } + + private$all_cols <- + create_all_cols(datalist) + + private$my_avals <- + if (!any(purrr::map_lgl(datalist, ~ "ATPT" %in% colnames(.x)))) { + list() + } else { + create_avals(datalist) + } + + }, + #' @description + #' Print the data frame containing the blocks + print = function() { + print(list( + Title = self$title, + "Group By" = self$group_by, + Blocks = self$blocks + )) + invisible(self) + }, + #' @description + #' Set the title for the table + #' @param title The title for the table + set_title = function(title) { + if (length(title) != 1 || !is.character(title)) + stop("Invalid input. Title must be a string.") + + self$title <- title + self + }, + #' @description + #' Set the group by field + #' @param group_by A field to group the table by + set_groupby = function(group_by) { + if (!group_by %in% private$all_cols) + stop("Invalid input. Must be a column from a data set in the data list.") + + self$group_by <- group_by + self + }, + #' @description + #' Add block to the block data object + #' @param variable The parameter or field the statistic is based on + #' @param stat The statistic to be calculated + #' @param dropdown A subgroup on which the statistic is calculated (usually an AVISIT) + #' @param tpnt A time point on which the calculation is filtered + #' @param df The dataset the parameter or field is from + #' @param after A subscript, after which the values are to be appended + add_block = function(variable, stat, dropdown, tpnt, df, after = NULL) { + arg_list <- c('variable', 'stat', 'dropdown', 'tpnt', 'df') + msg_call <- "addBlock(bd" + for (i in arg_list) { + if (do.call(missing, list(i))) + next + + argument <- glue::glue("{i} = '{eval(parse(text = i))}'") + msg_call <- paste(msg_call, argument, sep = ", ") + } + msg_call <- paste0(msg_call, ")") + user_interface <- list(triggered = FALSE, + message = paste("Requested user input for", msg_call)) + blocks <- list() + aggs <- list() + cat1 <- function(...) { + if(identical(Sys.getenv("TESTTHAT"), "true")) return(NULL) + + if (!user_interface$triggered) { + cat(user_interface$message, "\n\n") + user_interface$triggered <<- TRUE + } + cat(...) + } + get_var <- function(x) { + if (missing(x)) { + block_txt <- readLines(con = getOption("tidyCDISC.connection"), n = 1) + } else { + block_txt <- x + } + if (block_txt == "1") { + purrr::iwalk(tmp$all_rows, ~ {cat1(.y, ":\n ", sep = ""); cat1(.x[[1]], sep = ", "); cat1("\n")}) + return(get_var()) + } else if (block_txt == "2") { + cat1(names(self$all_rows), sep = ", ") + return(get_var()) + } else if (block_txt %in% names(self$all_rows)) { + cat1(self$all_rows[[block_txt]][[1]], sep = ","); cat1("\n") + return(get_var()) + } else { + if (!any(purrr::map_lgl(self$all_rows, ~ block_txt %in% .x[[1]]))) { + cat1("Param/field not found. Please type 1 to see all available options.\n") + return(get_var()) + } + return(block_txt) + } + } + get_filter <- function(x, atpt_lst) { + opt_lst <- c("NONE", purrr::imap(atpt_lst, ~ glue::glue("{.y} - {.x}")) %>% unlist()) + + if (missing(x)) { + filter_txt <- readLines(con = getOption("tidyCDISC.connection"), n = 1) + } else { + filter_txt <- x + } + if (filter_txt == "A") { + cat1("Please type the name or the number corresponding to the desired time point.\n") + cat1(paste0(seq_along(opt_lst), ": ", opt_lst), sep = "\n"); cat1("\n") + return(get_filter(atpt_lst = atpt_lst)) + } else if (filter_txt %in% seq_along(opt_lst)) { + if (filter_txt == "1") + return("NONE") + str_parse <- stringr::str_match(opt_lst[as.numeric(filter_txt)], "(^.*?) - (.*$)") + filter_return <- str_parse[3] + names(filter_return) <- str_parse[2] + return(filter_return) + } else if (filter_txt %in% opt_lst) { + if (filter_txt == "NONE") + return("NONE") + str_parse <- stringr::str_match(filter_txt, "(^.*?) - (.*$)") + filter_return <- str_parse[3] + names(filter_return) <- str_parse[2] + return(filter_return) + } else if (filter_txt %in% unlist(atpt_lst)) { + if (sum(filter_txt == unlist(atpt_lst)) > 1) { + cat1('Time point is not unique. Please type "A" to see all available options.\n') + get_filter(atpt_lst = atpt_lst) + } else { + x <- as.character(match(filter_txt, unlist(atpt_lst)) + 1) + return(get_filter(x, atpt_lst = atpt_lst)) + } + } else { + cat1('Time point not valid. Please type "A" to see all available options.\n') + return(get_filter(atpt_lst = atpt_lst)) + } + } + get_stat <- function(x) { + if (missing(x)) { + agg_txt <- readLines(con = getOption("tidyCDISC.connection"), n = 1) + } else { + agg_txt <- x + } + if (agg_txt == "A") { + cat1("Please type statistic or the number corresponding to desired stat.\n") + cat1(paste0(seq_along(private$stats), ": ", private$stats), sep = "\n"); cat1("\n") + return(get_stat()) + } else if (agg_txt %in% seq_along(private$stats)) { + return(private$stats[as.numeric(agg_txt)]) + } else if (agg_txt %in% private$stats) { + return(agg_txt) + } else { + cat1('Statistic not valid. Please type "A" to see all available options.\n') + return(get_stat()) + } + } + get_dropdown <- function(x, opts = c("weeks", "cols")) { + opts <- match.arg(opts) + + opt_lst <- + if (opts == "weeks") { + c("NONE", "ALL", private$my_weeks) + } else { + c("NONE", private$all_cols) + } + + if (missing(x)) { + agg_val <- readLines(con = getOption("tidyCDISC.connection"), n = 1) + } else { + agg_val <- x + } + if (is.null(agg_val) || is.na(agg_val)) { + return(NULL) + } else if (agg_val == "A") { + cat1("Please type the week or the number corresponding to the desired option.\n") + cat1(paste0(seq_along(opt_lst), ": ", opt_lst), sep = "\n"); cat1("\n") + return(get_dropdown(opts=opts)) + } else if (agg_val %in% seq_along(opt_lst)) { + return(opt_lst[as.numeric(agg_val)]) + } else if (agg_val %in% opt_lst) { + return(agg_val) + } else { + cat1('Option not valid. Please type "A" to see all available.\n') + return(get_dropdown(opts=opts)) + } + } + get_df <- function(x, possible_dfs) { + if (!missing(x) && !(x %in% possible_dfs || x %in% seq_along(possible_dfs))) { + cat1("The selected variable is not in the supplied dataset.\n") + } else if (!missing(x) && x %in% possible_dfs) { + return(x) + } else if (!missing(x) && x %in% seq_along(possible_dfs)) { + return(possible_dfs[as.numeric(x)]) + } else if (missing(x) & length(possible_dfs) == 1) { + return(possible_dfs) + } + + cat1("Please type the dataset or the number corresponding to the desired option.\n") + cat1(paste0(seq_along(possible_dfs), ": ", possible_dfs), sep = "\n"); cat1("\n") + df_val <- readLines(con = getOption("tidyCDISC.connection"), n = 1) + get_df(df_val, possible_dfs) + } + + if (missing(variable)) { + cat1('Please type a PARAMCD or field to use.', + 'To see all options, type 1. To see all datasets, type 2. To see options for a particular dataset, type its name (e.g. "ADAE").\n', sep = "\n") + } + blocks$txt <- get_var(variable) + possible_dfs <- names(self$all_rows)[purrr::map_lgl(self$all_rows, ~ blocks$txt %in% .x[[1]])] + blocks$df <- get_df(df, possible_dfs) + + if (blocks$df %in% names(private$my_avals) && blocks$txt %in% names(private$my_avals[[blocks$df]])) { + if (missing(tpnt)) { + cat1('Pleae type a time point to use.', + 'To see all options, type "A".\n', sep = "\n") + } + atpt_lst <- private$my_avals[[blocks$df]][[blocks$txt]] + filter_return <- get_filter(tpnt, atpt_lst = atpt_lst) + blocks$grp <- names(filter_return) + blocks$val <- as.character(filter_return) + if (blocks$val == "ALL") + blocks$lst <- atpt_lst[[blocks$grp]][-1] + } + + if (missing(stat)) { + cat1('Please type an aggregator to use.', + 'To see all options, type "A".\n', sep = "\n") + } + aggs$txt <- get_stat(stat) + + if (aggs$txt %in% c("ANOVA", "CHG", "MEAN") & !is.null(private$my_weeks)) { + if (missing(dropdown)) { + cat1('Please type an AVISIT to use.', + 'To see all options, type "A".\n', sep = "\n") + } + aggs$val <- get_dropdown(dropdown, "weeks") + if (!is.null(aggs$val) && aggs$val == "ALL") + aggs$lst <- as.list(private$my_weeks) + } else if (aggs$txt %in% c("NESTED_FREQ_DSC", "NESTED_FREQ_ABC")) { + if (missing(dropdown)) { + cat1('Please type a field to use.', + 'To see all options, type "A",\n', sep = "\n") + } + aggs$val <- get_dropdown(dropdown, "cols") + } + + if (is.null(after)) after <- length(self$blocks) + + process_drops <- process_droppables(list(list(aggs)), list(list(blocks))) + private$block_drop <- append(private$block_drop, process_drops$blocks, after = after) + private$agg_drop <- append(private$agg_drop, process_drops$aggs, after = after) + + blockData <- private$create_TG(process_drops$aggs, process_drops$blocks) + + self$blocks <- dplyr::add_row(self$blocks, blockData, .after = after) + self + }, + #' @description + #' Remove block from the block data object + #' @param x vector specifying elements to remove from block data object + remove_block = function(x) { + + private$block_drop <- private$block_drop[-x] + private$agg_drop <- private$agg_drop[-x] + + self$blocks <- self$blocks[-x, ] + + self + }, + #' @description + #' Export the table metadata as a JSON for 'recipe' inclusion + #' @param file File or connection to write to + #' @importFrom jsonlite toJSON write_json + json_export = function(file) { + block_lst <- + purrr::map2(private$agg_drop, private$block_drop, + function(agg, block) { + out_lst <- list() + out_lst$data <- block$df + out_lst$variable <- block$txt + out_lst$var_selection <- block$val + out_lst$var_options <- if (!is.null(block$val)) list(ATPT = as.list(block$val)) + out_lst$statistic <- agg$txt + out_lst$stat_selection <- agg$val + out_lst + }) + + out_lst <- list() + out_lst[[private$tbl_key]] <- list(title = self$title) + out_lst[[1]]$group_by <- self$group_by + out_lst[[1]]$blocks <- block_lst + jsonlite::write_json(path = file, out_lst, auto_unbox = TRUE, pretty = TRUE) + } + ), + list( + tbl_key = character(), + stats = c("ANOVA", "CHG", "MEAN", "FREQ", "Y_FREQ", "MAX_FREQ", "NON_MISSING", "NESTED_FREQ_DSC", "NESTED_FREQ_ABC"), + my_weeks = NULL, + all_cols = NULL, + my_avals = NULL, + block_drop = list(), + agg_drop = list(), + create_TG = function(aggs, blocks) { + blockData <- convertTGOutput(aggs, blocks) + + blockData$label <- + purrr::map2(blockData$block, blockData$dataset, function(var, dat) { + if(!is.null(attr(self$datalist[[dat]][[var]], 'label'))){ + attr(self$datalist[[dat]][[var]], 'label') + } else if(all(c("PARAM","PARAMCD") %in% colnames(self$datalist[[dat]]))){ + self$datalist[[dat]] %>% + filter(PARAMCD == var) %>% + distinct(PARAM) %>% + pull() %>% as.character() + } else { + var + } + }) %>% unname() %>% stringr::str_trim() + + blockData$label_source <- + purrr::map2(blockData$block, blockData$dataset, function(var, dat) { + if(!is.null(attr(self$datalist[[dat]][[var]], 'label'))){ + 'SAS "label" attribute' + } else if("PARAMCD" %in% colnames(self$datalist[[dat]])){ + 'PARAM' + } else { + 'No Label' + } + }) %>% unname() %>% stringr::str_trim() + + blockData + } + ) + ) + +#' Create Block Data Object +#' +#' @param datalist A list of ADaM-ish datasets used to generate the table +#' @param title The title for the table +#' +#' @return A block data object +#' +#' @export +#' @keywords table_blocks +#' +#' @examples +#' +#' datalist <- list(ADSL = tidyCDISC::adsl, ADVS = tidyCDISC::advs, +#' ADAE = tidyCDISC::adae, ADLBC = tidyCDISC::adlbc) +#' bd <- createBlockdata(datalist) +#' bd +createBlockdata <- function(datalist, title) { + table_blocks$new(datalist = datalist, title = title) +} + +#' Set the title for the table object +#' +#' @param bd A block data object +#' @param title The title for the table +#' +#' @return The \code{bd} block data object with supplied title +#' +#' @export +#' @keywords table_blocks +#' +#' @examples +#' +#' datalist <- list(ADSL = tidyCDISC::adsl, ADVS = tidyCDISC::advs, +#' ADAE = tidyCDISC::adae, ADLBC = tidyCDISC::adlbc) +#' bd <- createBlockdata(datalist) +#' setTitle(bd, "Table 1") +#' bd$title +setTitle <- function(bd, title) { + invisible(bd$set_title(title = title)) +} + +#' Set the title for the table object +#' +#' @param bd A block data object +#' @param group_by A field to group the table by +#' +#' @return The \code{bd} block data object with updated group by field +#' +#' @export +#' @keywords table_blocks +#' +#' @examples +#' +#' datalist <- list(ADSL = tidyCDISC::adsl, ADVS = tidyCDISC::advs, +#' ADAE = tidyCDISC::adae, ADLBC = tidyCDISC::adlbc) +#' bd <- createBlockdata(datalist) +#' setGroup(bd, "TRT01P") +#' bd$group_by +setGroup <- function(bd, group_by) { + invisible(bd$set_groupby(group_by = group_by)) +} + +#' Add Block to Block Data Object +#' +#' @param bd A block data object +#' @param variable The parameter or field the statistic is based on +#' @param stat The statistic to be calculated +#' @param dropdown A subgroup on which the statistic is calculated (usually an AVISIT) +#' @param tpnt A time point on which the calculation is filtered +#' @param df The dataset the parameter or field is from +#' @param after A subscript, after which the values are to be appended +#' +#' @return The \code{bd} block data object with additional block +#' +#' @export +#' @keywords table_blocks +#' +#' @examples +#' +#' datalist <- list(ADSL = tidyCDISC::adsl, ADVS = tidyCDISC::advs, +#' ADAE = tidyCDISC::adae, ADLBC = tidyCDISC::adlbc) +#' bd <- createBlockdata(datalist) +#' +#' \dontrun{ +#' addBlock(bd) +#' bd +#' } +#' +#' addBlock(bd, "DIABP", "MEAN", "ALL", "ALL") +#' bd +addBlock <- function(bd, variable, stat, dropdown, tpnt, df, after = NULL) { + invisible(bd$add_block(variable = variable, stat = stat, dropdown = dropdown, tpnt = tpnt, df = df, after = after)) +} + +#' Remove Block(s) from Block Data Object +#' +#' @param bd A block data object +#' @param x vector specifying elements to remove from block data object +#' +#' @return The \code{bd} block data object with additional block +#' +#' @export +#' @keywords table_blocks +removeBlock <- function(bd, x) { + invisible(bd$remove_block(x = x)) +} + +#' Write block data object to a JSON file +#' +#' @param bd A block data object +#' @param file File or connection to write to +#' +#' @export +#' @keywords table_blocks +writeJSON <- function(bd, file) { + bd$json_export(file = file) +} diff --git a/R/global.R b/R/global.R index 3ee7f870..16fe761e 100644 --- a/R/global.R +++ b/R/global.R @@ -126,7 +126,8 @@ utils::globalVariables(c( "pval_hover", "sort_n", "v", "var", "var_rn", "where", "y", "type", "title" ,":=", - "DATE", "EVENT_TIME", "DATE_ST", "DECODE_ST", "DATE_EN", "DECODE_EN" + "DATE", "EVENT_TIME", "DATE_ST", "DECODE_ST", "DATE_EN", "DECODE_EN", + "ATPT", "ATPTN" )) diff --git a/R/mod_tableGen.R b/R/mod_tableGen.R index d9be8e02..3d4336c5 100644 --- a/R/mod_tableGen.R +++ b/R/mod_tableGen.R @@ -28,7 +28,15 @@ mod_tableGen_server <- function(input, output, session, datafile = reactive(NULL old <- options() on.exit(options(old)) - observeEvent( input$help, { + recipes <- reactiveVal(load_recipes(golem::get_golem_options("recipes_json"))) + + observe({ + req(recipes()) + + session$sendCustomMessage("recipes", recipes()) + }) + + observeEvent(input$help, { tg_guide$init()$start() }) @@ -41,39 +49,61 @@ mod_tableGen_server <- function(input, output, session, datafile = reactive(NULL }) output$stan_recipe_ui <- renderUI({ - HTML(paste(' - + ', + opts, '')) }) - RECIPE <- reactive( if(rlang::is_empty(input$recipe)) "NONE" else input$recipe) - - observeEvent(RECIPE(), { - req(input$table_title) - val <- ifelse(RECIPE() == "NONE", "Table Title", RECIPE()) - updateTextInput(session, "table_title", value = val) + recipe <- eventReactive(input$RECIPE, { + if (input$RECIPE != "NONE") { + recipe <- recipes()[purrr::map_lgl(recipes(), ~ .x$title == input$RECIPE)][[1]] + blocks <- + recipe$blocks %>% + `[`(recipe_inclusion(., datafile())) + recipe$blocks <- blocks %>% + purrr::map(~ stat_options(.x, datalist = datafile())) %>% + purrr::map(~ var_options(.x, datalist = datafile())) + var_check <- recipe$blocks %>% + purrr::map(~ .x$var_selection %in% unlist(.x$var_options, use.names = FALSE)) %>% + purrr::compact() %>% + unlist() + stat_check <- recipe$blocks %>% + purrr::map(~ .x$stat_selection %in% c("ALL", .x$stat_options)) %>% + purrr::compact() %>% + unlist() + if (!is.null(var_check) && !all(var_check)) { + showNotification(h4("Variable drop down selection not contained in options."), type = "error") + } + if (!is.null(stat_check) && !all(stat_check)) { + showNotification(h4("Statistic drop down selection not contained in options."), type = "error") + } + } else { + recipe <- list(title = "NONE") + } + recipe }) + observeEvent(recipe(), { + session$sendCustomMessage("submit_recipe", recipe()) + updateTextInput(session, "table_title", value = if (recipe()$title == "NONE") "Table Title" else recipe()$title) + }) + + RECIPE <- reactive( if(rlang::is_empty(input$recipe)) "NONE" else input$recipe) + + observeEvent(input$recipe, { + column(recipe()$group_by) + updateSelectInput(session, "COLUMN", selected = if (is.null(recipe()$group_by)) "NONE" else recipe()$group_by) + }) + + # ---------------------------------------------------------------------- # input prep for table manipulation @@ -81,32 +111,17 @@ mod_tableGen_server <- function(input, output, session, datafile = reactive(NULL categ_vars <- reactive({ req(datafile()) # this also doesn't need to depend on pre-filters, so grabbing root df cols - if("ADAE" %in% names(datafile())){ - all_cols <- unique(c( - colnames(datafile()$ADSL)[sapply(datafile()$ADSL, class) %in% c('character', 'factor')], - colnames(datafile()$ADAE)[sapply(datafile()$ADAE, class) %in% c('character', 'factor')] - )) - } else { # just adsl cols - all_cols <- unique(c( - colnames(datafile()$ADSL)[sapply(datafile()$ADSL, class) %in% c('character', 'factor')] - )) - } - return( all_cols ) + create_all_cols(datafile()) }) - output$grp_col_ui <- renderUI({ - sel_grp <- dplyr::case_when( - is.null(RECIPE()) | length(RECIPE()) == 0 ~ "NONE", - !is.null(RECIPE()) & RECIPE() != "NONE" ~ "TRT01P", - TRUE ~ "NONE" - ) - selectInput(session$ns("COLUMN"), "Group Data By:", - choices = c("NONE", categ_vars()), - selected = sel_grp + observe({ + updateSelectInput(session, "COLUMN", + choices = c("NONE", categ_vars()), + selected = "NONE" ) }) - + # ---------------------------------------------------------------------- # convert list of dataframes to a single joined dataframe # containing only BDS and ADSL files @@ -131,45 +146,24 @@ mod_tableGen_server <- function(input, output, session, datafile = reactive(NULL # perform any pre-filters on the data, when a STAN table is selected - pre_ADSL <- reactive({ - req(RECIPE()) - tryCatch(prep_adsl(ADSL = datafile()$ADSL,input_recipe = RECIPE()), error = function(e) validate(error_handler(e))) + pre_ADSL <- eventReactive(input$recipe, { + tryCatch(filter_adsl(recipe(), datafile()$ADSL), error = function(e) validate(error_handler(e))) }) - - # clean_ADAE() now happens inside this reactive! - # use potentially pre-filtered ADSL when building/ joining w/ ADAE - # Then filter ADAE based on STAN table selected. pre_ADAE <- reactive({ - req(RECIPE()) - tryCatch(prep_adae(datafile = datafile(),ADSL = pre_ADSL()$data, input_recipe = RECIPE()), error = function(e) validate(error_handler(e))) - }) - + tryCatch(filter_adae(recipe(), datafile(), pre_ADSL()$data), error = function(e) validate(error_handler(e))) + }) %>% + bindEvent(input$recipe, pre_ADSL()) + # Create cleaned up versions of raw data - ADSL <- reactive({ - pre_ADSL()$data - # CANNOT inner_join on the ADAE subjects that were filtered because some - # subjects had no adverse events so you'd make a mistake by excluding them. - # Really, we'd have to identify the subjects in pre_ADSL$data and not in the - # datalist$ADAE Then keep those, plus subjects that exist in the inner_join - # of pre_ADSL$data & pre_ADAE()$data. Have to take this out of R script - # still too ############################################################ - - #%>% - # inner_join( - # pre_ADAE()$data %>% - # distinct(USUBJID) - # ) - }) BDS <- reactive({ init <- sapply(datafile(), function(x) "PARAMCD" %in% colnames(x) & !("CNSR" %in% colnames(x))) datafile()[init] # datafile()[sapply(datafile(), function(x) "PARAMCD" %in% colnames(x))] }) - ADAE <- reactive({ pre_ADAE()$data }) - + # combine all BDS data files into one large data set - bds_data <- reactive({ - prep_bds(datafile = datafile(), ADSL = ADSL()) + bds_data <- eventReactive(pre_ADSL(), { + prep_bds(datafile = datafile(), ADSL = pre_ADSL()$data) # OLD code removed 2/17/2021 }) @@ -190,7 +184,7 @@ mod_tableGen_server <- function(input, output, session, datafile = reactive(NULL # apply filters from selected dfs to tg data to create all data all_data <- reactive({suppressMessages(bds_data() %>% semi_join(filtered_data()))}) - ae_data <- reactive({suppressMessages(ADAE() %>% semi_join(filtered_data()))}) + ae_data <- reactive({suppressMessages(pre_ADAE()$data %>% semi_join(filtered_data()))}) pop_data <- reactive({ suppressMessages( pre_ADSL()$data %>% # Cannot be ADSL() because that has potentially been filtered to ADAE subj's @@ -210,62 +204,11 @@ mod_tableGen_server <- function(input, output, session, datafile = reactive(NULL # prepare the AVISIT dropdown of the statistics blocks # by converting them to a factor in the order of AVISITN # this allows our dropdown to be in chronological order - avisit_words <- reactive({ - req(datafile()) - - if(any(purrr::map_lgl(datafile(), ~"AVISIT" %in% colnames(.x)))){ - purrr::map(BDS(), function(x) x %>% dplyr::select(AVISIT)) %>% - dplyr::bind_rows() %>% - dplyr::distinct(AVISIT) %>% - dplyr::pull() - } else { - NULL #c("fake_weeky","dummy_weeky") # DON'T use this comment part. - # It's handled in AVISIT() - } - - }) - - avisit_fctr <- reactive({ - req(datafile()) - req(any(purrr::map_lgl(datafile(), ~"AVISIT" %in% colnames(.x)))) - - if(any(purrr::map_lgl(datafile(), ~"AVISIT" %in% colnames(.x)))){ - purrr::map(BDS(), function(x) x %>% dplyr::select(AVISITN)) %>% - dplyr::bind_rows() %>% - dplyr::distinct(AVISITN) %>% - dplyr::pull() - } else { - 1:2 - } - - }) - AVISIT <- reactive({ req(datafile()) + req(any(purrr::map_lgl(datafile(), ~"AVISIT" %in% colnames(.x)))) - if (is.null(avisit_words())) { - avisit_words <- c("fake_weeky","dummy_weeky") - } else { - # for testing - # nums <- c(2,4,6,8,12,16,20,24,26) - # avisit_words <- function() c("", "Baseline",paste("Week", nums), "End of Treatment") - # avisit_fctr <- function()c(NA, 0, nums, 99) - # rm(nums, avisit_words, avisit_fctr) - - awd <- tidyr::tibble(AVISIT = avisit_words(), AVISITN = avisit_fctr()) - avisit_words <- - # tidyr::tibble(AVISIT = avisit_words(), AVISITN = avisit_fctr()) %>% - # dplyr::mutate(AVISIT = as.factor(AVISIT)) %>% - # dplyr::mutate(AVISIT = forcats::fct_reorder(AVISIT, AVISITN)) %>% - awd %>% - dplyr::mutate(AVISIT = factor(AVISIT, - levels = awd[order(awd$AVISITN), "AVISIT"][[1]] %>% unique() )) %>% - dplyr::pull(AVISIT) %>% - unique() %>% - # Arrange by factor level (AVISITN) - sort() - } - avisit_words[avisit_words != ""] + create_avisit(datafile(), BDS()) }) @@ -280,41 +223,14 @@ mod_tableGen_server <- function(input, output, session, datafile = reactive(NULL # just character of factor vars from the ADSL or ADAE observe({ req(categ_vars()) - all_cols <- categ_vars() - session$sendCustomMessage("all_cols", all_cols) + session$sendCustomMessage("all_cols", categ_vars()) }) AVALS <- reactive({ req(datafile()) req(purrr::map_lgl(datafile(), ~ "ATPT" %in% colnames(.x))) - atpt_datasets <- purrr::map_lgl(datafile(), ~ "ATPT" %in% colnames(.x)) - - avals <- - purrr::map(datafile()[atpt_datasets], ~ .x %>% - dplyr::select(PARAMCD, dplyr::any_of(c("ATPT"))) %>% - dplyr::filter(dplyr::if_any(-PARAMCD, ~ !is.na(.x) & .x != "")) %>% - dplyr::pull(PARAMCD) %>% - get_levels() - ) - - ## TODO: Make this less confusing. I pity the soul who has to edit this. - purrr::imap(avals, ~ purrr::map(.x, function(i, j =.y) { - datafile()[[j]] %>% - dplyr::filter(PARAMCD == i) %>% - dplyr::select(dplyr::any_of(c("ATPT", "ATPTN"))) %>% - varN_fctr_reorder() %>% - dplyr::select(dplyr::any_of(c("ATPT"))) %>% - purrr::map(~ .x %>% - addNA(ifany = TRUE) %>% - purrr::possibly(relevel, otherwise = .)(NA_character_) %>% - get_levels() %>% - tidyr::replace_na("N/A") %>% - {if (length(.) > 1) c("ALL", .) else .} %>% - as.list()) - }) %>% - purrr::set_names(.x) - ) + create_avals(datafile()) }) observe({ @@ -322,69 +238,6 @@ mod_tableGen_server <- function(input, output, session, datafile = reactive(NULL session$sendCustomMessage("my_avals", AVALS()) }) - # Verify if certain lab params exist, and if so, which dataset they live in - # in case there are multiple ADLBs- to use later to send data to js side - chem_params <- reactive({ - req(datafile()) - check_params(datafile(), chem) - }) - hema_params <- reactive({ - req(datafile()) - check_params(datafile(), hema) - }) - urin_params <- reactive({ - req(datafile()) - check_params(datafile(), urin) - }) - loaded_labs <- reactive({ - my_loaded_adams()[substr(my_loaded_adams(),1,4) == "ADLB"] - }) - - - # Send to Client (JS) side: - # Hematology - # Blood Chemistry - # Urinalysis - - # Sending vector of specific params (if they exist) for certain labs (if they exist) - observe({ - req(datafile(), chem_params(), hema_params(), urin_params()) # don't req("ADLBC") because then the custom message will never get sent, and hang up the UI - - send_chem <- send_urin <- send_hema <- c("not","used","fake","vector","to","convert","to","js","array") - send_chem_wks <- send_urin_wks <- send_hema_wks <- c("fake_weeky","fake_weeky2") - - if(!(rlang::is_empty(loaded_labs())) & - (chem_params()$exist | hema_params()$exist| urin_params()$exist) - ){ - - - # Blood Chem - if(chem_params()$exist){ # add recipe() = 'tab 41'? - send_chem <- chem_params()$vctr - send_chem_wks <- chem_params()$tp - } - - # Hematology - if(hema_params()$exist){ # add specific recipe() = 'tab 41'? - send_hema <- hema_params()$vctr - send_hema_wks <- hema_params()$tp - } - - # Urinalysis - if(urin_params()$exist){ # add specific recipe() = 'tab 41'? - send_urin <- urin_params()$vctr - send_urin_wks <- urin_params()$tp - } - - } # end of "if labs exist" - - session$sendCustomMessage("adlbc", list(params = as.vector(send_chem), weeks = as.vector(send_chem_wks))) - session$sendCustomMessage("adlbh", list(params = as.vector(send_hema), weeks = as.vector(send_hema_wks))) - session$sendCustomMessage("adlbu", list(params = as.vector(send_urin), weeks = as.vector(send_urin_wks))) - - - }) - # ---------------------------------------------------------------------- # Generate table given the dropped blocks # ---------------------------------------------------------------------- @@ -393,7 +246,8 @@ mod_tableGen_server <- function(input, output, session, datafile = reactive(NULL # convert the custom shiny input to a table output blocks_and_functions <- reactive({ # create initial dataset - blockData <- tryCatch(convertTGOutput(input$agg_drop_zone, input$block_drop_zone), error = function(e) validate(error_handler(e))) + droppables_lst <- tryCatch(process_droppables(input$agg_drop_zone, input$block_drop_zone), error = function(e) validate(error_handler(e))) + blockData <- do.call(convertTGOutput, droppables_lst) blockData$label <- purrr::map2(blockData$block, blockData$dataset, function(var, dat) { @@ -423,12 +277,13 @@ mod_tableGen_server <- function(input, output, session, datafile = reactive(NULL return(blockData) }) - column <- reactive( if (input$COLUMN == "NONE") NULL else input$COLUMN) - + column <- reactiveVal() + observe({column(if (input$COLUMN == "NONE") NULL else input$COLUMN)}) + # check if the grouping column only exists in the ADAE is_grp_col_adae <- reactive({ - input$COLUMN %in% dplyr::setdiff(colnames(ae_data()), colnames(all_data())) + isTRUE(column() %in% dplyr::setdiff(colnames(ae_data()), colnames(all_data()))) }) # Decide which reactive data frame to use below @@ -455,23 +310,23 @@ mod_tableGen_server <- function(input, output, session, datafile = reactive(NULL distinct(USUBJID) %>% summarise(n_tot = n()) - if (input$COLUMN == "NONE") { + if (is.null(column())) { df } else { df <- df %>% mutate(temp = 'Total') %>% - rename_with(~paste(input$COLUMN), "temp") + rename_with(~paste(column()), "temp") - grp_lvls <- get_levels(use_preferred_pop_data()[[input$COLUMN]]) # PUT ADAE() somehow? + grp_lvls <- get_levels(use_preferred_pop_data()[[column()]]) # PUT ADAE() somehow? xyz <- data.frame(grp_lvls) %>% - rename_with(~paste(input$COLUMN), grp_lvls) + rename_with(~paste(column()), grp_lvls) groups <- xyz %>% left_join( use_preferred_pop_data() %>% - group_by(!!sym(input$COLUMN)) %>% + group_by(!!sym(column())) %>% distinct(USUBJID) %>% summarise(n_tot = n()) )%>% @@ -486,7 +341,6 @@ mod_tableGen_server <- function(input, output, session, datafile = reactive(NULL }) pre_filter_msgs <- reactive({ - req(RECIPE()) paste0(pre_ADSL()$message, "
", pre_ADAE()$message, collapse = "
") }) @@ -508,7 +362,6 @@ mod_tableGen_server <- function(input, output, session, datafile = reactive(NULL } }) - # create a gt table output by mapping over each row in the block input # and performing the correct statistical method given the blocks S3 class for_gt <- reactive({ @@ -533,7 +386,7 @@ mod_tableGen_server <- function(input, output, session, datafile = reactive(NULL return(d) }) - + output$for_gt_table <- renderTable({ for_gt() }) # remove the first two columns from the row names to use since @@ -733,7 +586,7 @@ mod_tableGen_server <- function(input, output, session, datafile = reactive(NULL # Depending on data source used in the app, create data for R script create_script_data <- reactive({ - if(any("CDISCPILOT01" %in% ADSL()$STUDYID)){ + if(any("CDISCPILOT01" %in% pre_ADSL()$data$STUDYID)){ glue::glue(" # create list of dataframes from CDISC pilot study datalist <- list({paste(purrr::map_chr(names(datafile()), ~ paste0(.x, ' = tidyCDISC::', tolower(.x))), collapse = ', ')}) @@ -756,7 +609,7 @@ mod_tableGen_server <- function(input, output, session, datafile = reactive(NULL }) footnote_src <- reactive({ - if(any("CDISCPILOT01" %in% ADSL()$STUDYID)){ + if(any("CDISCPILOT01" %in% pre_ADSL()$data$STUDYID)){ "'tidyCDISC app'" } else { "study_dir" diff --git a/R/mod_tableGen_fct_filter_adae.R b/R/mod_tableGen_fct_filter_adae.R new file mode 100644 index 00000000..06fc3328 --- /dev/null +++ b/R/mod_tableGen_fct_filter_adae.R @@ -0,0 +1,173 @@ +filter_adae <- function(recipe, datalist, ADSL) { + UseMethod("filter_adae", recipe) +} + +filter_adae.default <- function(recipe, datalist, ADSL) { + dat <- clean_ADAE(datafile = datalist, ADSL = ADSL) + msg <- "" + list(data = dat, message = msg) +} + +filter_adae.stan_25 <- + filter_adae.stan_26 <- function(recipe, datalist, ADSL) { + dat <- clean_ADAE(datafile = datalist, ADSL = ADSL) + msg <- "" + + if("AESEV" %in% colnames(dat)){ + dat <- dat %>% filter(AESEV == 'SEVERE') + msg <- "AESEV = 'SEVERE'" + } else { + msg <- "Variable 'AESEV' doesn't exist in ADAE. STAN table not displayed because filter \"AESEV = 'SEVERE'\" cannot be applied!" + stop(msg) + } + + if("TRTEMFL" %in% colnames(dat)){ + dat <- dat %>% filter(TRTEMFL == 'Y') + msg <- paste0(msg, "
TRTEMFL = 'Y'") + } else { + msg <- paste0(msg, "
Variable 'TRTEMFL' doesn't exist in ADAE. STAN table not displayed because filter \"TRTEMFL = 'Y'\" cannot be applied!") + stop(msg) + } + + list(data = dat, message = msg) +} + +filter_adae.stan_29 <- function(recipe, datalist, ADSL) { + dat <- clean_ADAE(datafile = datalist, ADSL = ADSL) + msg <- "" + + if("AREL" %in% colnames(dat)){ + dat <- dat %>% filter(AREL == 'RELATED') + msg <- "AREL = 'RELATED'" + } else { + msg <- "Variable 'AREL' doesn't exist in ADAE. STAN table not displayed because filter \"AREL = 'RELATED'\" cannot be applied!" + stop(msg) + } + + if("TRTEMFL" %in% colnames(dat)){ + dat <- dat %>% filter(TRTEMFL == 'Y') + msg <- paste0(msg, "
TRTEMFL = 'Y'") + } else { + msg <- paste0(msg, "
Variable 'TRTEMFL' doesn't exist in ADAE. STAN table not displayed because filter \"TRTEMFL = 'Y'\" cannot be applied!") + stop(msg) + } + + list(data = dat, message = msg) +} + +filter_adae.stan_30 <- + filter_adae.stan_31 <- function(recipe, datalist, ADSL) { + dat <- clean_ADAE(datafile = datalist, ADSL = ADSL) + msg <- "" + + if("AESER" %in% colnames(dat)){ + dat <- dat %>% filter(AESER == 'Y') + msg <- "AESER = 'Y'" + } else { + msg <- "Variable 'AESER' doesn't exist in ADAE. STAN table not displayed because filter \"AESER = 'Y'\" cannot be applied!" + stop(msg) + } + + if("TRTEMFL" %in% colnames(dat)){ + dat <- dat %>% filter(TRTEMFL == 'Y') + msg <- paste0(msg, "
TRTEMFL = 'Y'") + } else { + msg <- paste0(msg, "
Variable 'TRTEMFL' doesn't exist in ADAE. STAN table not displayed because filter \"TRTEMFL = 'Y'\" cannot be applied!") + stop(msg) + } + + list(data = dat, message = msg) +} + +filter_adae.stan_33 <- function(recipe, datalist, ADSL) { + dat <- clean_ADAE(datafile = datalist, ADSL = ADSL) + msg <- "" + + if("AREL" %in% colnames(dat) & "AESER" %in% colnames(dat)){ + dat <- dat %>% filter(AREL == 'RELATED' & AESER == 'Y') + msg <- "AREL = 'RELATED'
AESER = 'Y'" + } else if("AREL" %in% colnames(dat) & !("AESER" %in% colnames(dat))){ + dat <- dat %>% filter(AREL == 'RELATED') + msg <- "AREL = 'RELATED'
Variable 'AESER' doesn't exist in ADAE. STAN table not displayed because filter \"AESER = 'Y'\" cannot be applied!" + stop("Variable 'AESER' doesn't exist in ADAE. STAN table not displayed because filter \"AESER = 'Y'\" cannot be applied!") + } else if(!("AREL" %in% colnames(dat)) & "AESER" %in% colnames(dat)){ + dat <- dat %>% filter(AESER == 'Y') + msg <- "Variable 'AREL' doesn't exist in ADAE. STAN table not displayed because filter \"AREL = 'RELATED'\" cannot be applied!
AESER = 'Y'" + stop("Variable 'AREL' doesn't exist in ADAE. STAN table not displayed because filter \"AREL = 'RELATED'\" cannot be applied!") + } else{ + msg <- "Variables 'AREL' & 'AESER' do not exist in ADAE. STAN table not displayed because filters \"AREL = 'RELATED'\" and \"AESER = 'Y'\" cannot be applied!" + stop(msg) + } + + if("TRTEMFL" %in% colnames(dat)){ + dat <- dat %>% filter(TRTEMFL == 'Y') + msg <- paste0(msg, "
TRTEMFL = 'Y'") + } else { + msg <- paste0(msg, "
Variable 'TRTEMFL' doesn't exist in ADAE. STAN table not displayed because filter \"TRTEMFL = 'Y'\" cannot be applied!") + stop(msg) + } + + list(data = dat, message = msg) +} + +filter_adae.stan_34 <- function(recipe, datalist, ADSL) { + dat <- clean_ADAE(datafile = datalist, ADSL = ADSL) + msg <- "" + + if("AEACN" %in% colnames(dat)){ + dat <- dat %>% filter(AEACN == 'DRUG WITHDRAWN') + msg <- "AEACN = 'DRUG WITHDRAWN'" + } else{ + msg <- "Variable 'AEACN' doesn't exist in ADAE. STAN table not displayed because filter \"AEACN = 'DRUG WITHDRAWN'\" cannot be applied!" + stop(msg) + } + + list(data = dat, message = msg) +} + +filter_adae.stan_36 <- function(recipe, datalist, ADSL) { + dat <- clean_ADAE(datafile = datalist, ADSL = ADSL) + msg <- "" + + if("AEACNOTH" %in% colnames(dat)){ + dat <- dat %>% + filter(stringr::str_detect(tolower(AEACNOTH),"withdrawal") & + stringr::str_detect(tolower(AEACNOTH),"study")) + msg <- "AEACNOTH Contains 'withdrawal' and 'study'" + } else{ + msg <- "Variable 'AEACNOTH' doesn't exist in ADAE. STAN table not displayed because filter \"AEACNOTH Contains 'withdrawal' and 'study'\" cannot be applied!" + stop(msg) + } + + list(data = dat, message = msg) +} + +filter_adae.stan_38 <- function(recipe, datalist, ADSL) { + dat <- clean_ADAE(datafile = datalist, ADSL = ADSL) + msg <- "" + + if("AEACN" %in% colnames(dat)){ + dat <- dat %>% filter(AEACN %in% c('DRUG INTERRUPTED', 'DRUG REDUCED', 'DOSE REDUCED', 'DRUG INCREASED', 'DOSE INCREASED')) + msg <- "AEACN IN ('DRUG INTERRUPTED', 'DOSE REDUCED', 'DOSE INCREASED')" + } else{ + msg <- "Variable 'AEACN' doesn't exist in ADAE. STAN table not displayed because filter \"AEACN IN ('DRUG INTERRUPTED', 'DOSE REDUCED', 'DOSE INCREASED')\" cannot be applied!" + stop(msg) + } + + list(data = dat, message = msg) +} + +filter_adae.stan_39 <- function(recipe, datalist, ADSL) { + dat <- clean_ADAE(datafile = datalist, ADSL = ADSL) + msg <- "" + + if("TRTEMFL" %in% colnames(dat)){ + dat <- dat %>% filter(TRTEMFL == 'Y') + msg <- "TRTEMFL = 'Y'" + }else { + msg <- "Variable 'TRTEMFL' doesn't exist in ADAE. STAN table not displayed because filter \"TRTEMFL = 'Y'\" cannot be applied!" + stop(msg) + } + + list(data = dat, message = msg) +} diff --git a/R/mod_tableGen_fct_filter_adsl.R b/R/mod_tableGen_fct_filter_adsl.R new file mode 100644 index 00000000..5cfec90e --- /dev/null +++ b/R/mod_tableGen_fct_filter_adsl.R @@ -0,0 +1,71 @@ +filter_adsl <- function(recipe, ADSL) { + UseMethod("filter_adsl", recipe) +} + +filter_adsl.default <- function(recipe, ADSL) { + dat <- ADSL + msg <- "" + list(data = dat, message = msg) +} + +filter_adsl.stan_3 <- function(recipe, ADSL) { + dat <- ADSL + msg <- "" + if("FASFL" %in% colnames(dat)){ + dat <- dat %>% filter(FASFL == 'Y') + msg <- "Population Set: FASFL = 'Y'" + } else { + if("ITTFL" %in% colnames(dat)){ + dat <- dat %>% filter(ITTFL == 'Y') + msg <- "Population Set: ITTFL = 'Y'" + } else { + msg <- "Variable 'FASFL' or 'ITTFL' doesn't exist in ADSL. STAN table not displayed because filter \"FASFL == 'Y'\" or \"ITTFL == 'Y'\"cannot be applied!" + stop(msg) + } + } + list(data = dat, message = msg) +} + +filter_adsl.stan_18 <- + filter_adsl.stan_19 <- + filter_adsl.stan_20 <- + filter_adsl.stan_21 <- + filter_adsl.stan_22 <- + filter_adsl.stan_23 <- + filter_adsl.stan_24 <- + filter_adsl.stan_25 <- + filter_adsl.stan_26 <- + filter_adsl.stan_27 <- + filter_adsl.stan_28 <- + filter_adsl.stan_29 <- + filter_adsl.stan_30 <- + filter_adsl.stan_31 <- + filter_adsl.stan_32 <- + filter_adsl.stan_33 <- + filter_adsl.stan_34 <- + filter_adsl.stan_35 <- + filter_adsl.stan_36 <- + filter_adsl.stan_37 <- + filter_adsl.stan_38 <- + filter_adsl.stan_39 <- + filter_adsl.stan_41 <- + filter_adsl.stan_42 <- + filter_adsl.stan_43 <- + filter_adsl.stan_44 <- + filter_adsl.stan_45 <- + filter_adsl.stan_46 <- + filter_adsl.stan_47 <- + filter_adsl.stan_51 <- + filter_adsl.stan_52 <- + filter_adsl.stan_53 <- function(recipe, ADSL) { + dat <- ADSL + msg <- "" + if("SAFFL" %in% colnames(dat)) { + dat <- dat %>% filter(SAFFL == 'Y') + msg <- "Population Set: SAFFL = 'Y'" + } else { + msg <- "Variable 'SAFFL' doesn't exist in ADSL. STAN table not displayed because filter \"SAFFL == 'Y'\" cannot be applied!" + stop(msg) + } + list(data = dat, message = msg) +} \ No newline at end of file diff --git a/R/mod_tableGen_fct_methods.R b/R/mod_tableGen_fct_methods.R index 706ca76c..8f5dddcd 100644 --- a/R/mod_tableGen_fct_methods.R +++ b/R/mod_tableGen_fct_methods.R @@ -110,6 +110,63 @@ custom_class <- function(x, df) { return(x) } +#' Process the drag and drops blocks +#' +#' @param aggs the aggregate statistic block +#' to apply to the column +#' @param blocks the block corresponding +#' to the column name to apply statistic on +#' +#' @family tableGen Functions +#' @noRd +#' @importFrom purrr map +process_droppables <- function(aggs, blocks) { + + aggs <- unlist(aggs, recursive = FALSE) + blocks <- unlist(blocks, recursive = FALSE) + process_dropdown <- function(droppable) { + droppable$dropdown <- + if (is.null(droppable$val)) { + NA_character_ + } else if (droppable$val == "ALL") { + droppable$lst + } else { + droppable$val + } %>% + unname() %>% str_trim() + if (is.null(droppable$grp)) + droppable$grp <- NA_character_ + droppable + } + + if (length(aggs) == 0 && length(blocks) == 0) { + return(list(aggs = aggs, blocks = blocks)) + } else if (length(aggs) > length(blocks)) { + stop("Need addional variable block") + } else if (length(aggs) < length(blocks)) { + stop("Need additional statistics block") + } else { + aggs <- purrr::map(aggs, process_dropdown) + blocks <- purrr::map(blocks, process_dropdown) + aggs_out <- blocks_out <- list() + for (i in seq_along(aggs)) { + for (j in seq_along(aggs[[i]]$dropdown)) { + for (k in seq_along(blocks[[i]]$dropdown)) { + len <- length(aggs_out) + 1 + aggs_out[[len]] <- aggs[[i]] + aggs_out[[len]]$val <- aggs[[i]]$dropdown[[j]] + aggs_out[[len]]$lst <- NULL + aggs_out[[len]]$dropdown <- NULL + blocks_out[[len]] <- blocks[[i]] + blocks_out[[len]]$val <- blocks[[i]]$dropdown[[k]] + blocks_out[[len]]$lst <- NULL + blocks_out[[len]]$dropdown <- NULL + } + } + } + return(list(aggs = aggs_out, blocks = blocks_out)) + } +} #' Using the drag and drop blocks #' and the shiny inputs, @@ -132,23 +189,6 @@ custom_class <- function(x, df) { #' convertTGOutput <- function(aggs, blocks) { - aggs <- unlist(aggs, recursive = FALSE) - blocks <- unlist(blocks, recursive = FALSE) - process_dropdown <- function(droppable) { - for (i in 1:length(droppable)) { - if (is.null(droppable[[i]]$val)) { - droppable[[i]]$dropdown <- NA_character_ - } else if (droppable[[i]]$val == "ALL") { - droppable[[i]]$dropdown <- droppable[[i]]$lst %>% unname() %>% str_trim() - } else { - droppable[[i]]$dropdown <- droppable[[i]]$val %>% unname() %>% str_trim() - } - if (is.null(droppable[[i]]$grp)) - droppable[[i]]$grp <- NA_character_ - } - droppable - } - if (length(aggs) == 0 & length(blocks) == 0) { tidyr::tibble( agg = character(), @@ -159,29 +199,94 @@ convertTGOutput <- function(aggs, blocks) { S3 = character(), gt_group = character() ) - } else if (length(aggs) > length(blocks)) { - stop("Need addional variable block") - } else if (length(aggs) < length(blocks)) { - stop("Need additional statistics block") } else { - aggs <- process_dropdown(aggs) - blocks <- process_dropdown(blocks) purrr::map2_df(aggs, blocks, function(aggs, blocks) { - purrr::map_df(aggs$dropdown, function(aggs_dd) { - purrr::map_df(blocks$dropdown, function(blocks_dd) { - tidyr::tibble( - agg = aggs$txt %>% unname() %>% str_trim(), - block = blocks$txt %>% unname() %>% str_trim(), - dataset = blocks$df %>% unname() %>% str_trim(), - dropdown = aggs_dd, - filter = if (is.na(blocks$grp)) {NA_character_} - else if (blocks_dd == "N/A") {glue::glue("is.na({blocks$grp %>% unname() %>% str_trim()})")} - else {glue::glue("{blocks$grp %>% unname() %>% str_trim()} == '{blocks_dd}'")}, - S3 = map2(block, dataset, ~ custom_class(.x, .y)), - gt_group = glue("{agg} of {block}{if (is.na(dropdown) || dropdown == 'NONE') '' else if (tolower(substr(dropdown, 1, 4)) %in% c('week','base','scree','end ')) paste(' at', dropdown) else paste(' and', dropdown)}{if (is.na(blocks$grp) || blocks_dd == 'N/A' || blocks_dd == dropdown) '' else paste('/', blocks_dd)}") - ) - }) - }) + tidyr::tibble( + agg = aggs$txt %>% unname() %>% str_trim(), + block = blocks$txt %>% unname() %>% str_trim(), + dataset = blocks$df %>% unname() %>% str_trim(), + dropdown = aggs$val, + filter = if (is.na(blocks$grp)) {NA_character_} + else if (blocks$val == "N/A") {glue::glue("is.na({blocks$grp %>% unname() %>% str_trim()})")} + else {glue::glue("{blocks$grp %>% unname() %>% str_trim()} == '{blocks$val}'")}, + S3 = map2(block, dataset, ~ custom_class(.x, .y)), + gt_group = glue("{agg} of {block}{if (is.na(dropdown) || dropdown == 'NONE') '' else if (tolower(substr(dropdown, 1, 4)) %in% c('week','base','scree','end ')) paste(' at', dropdown) else paste(' and', dropdown)}{if (is.na(blocks$grp) || blocks$val == 'N/A' || blocks$val == dropdown) '' else paste('/', blocks$val)}") + ) }) } } + +create_avisit <- function(datalist, bds_data) { + if (!any(purrr::map_lgl(datalist, ~"AVISIT" %in% colnames(.x)))) + stop("The field AVISIT must be present in the data list") + + avisit_words <- + purrr::map(bds_data, function(x) x %>% dplyr::select(AVISIT)) %>% + dplyr::bind_rows() %>% + dplyr::distinct(AVISIT) %>% + dplyr::pull() + + avisit_fctr <- + purrr::map(bds_data, function(x) x %>% dplyr::select(AVISITN)) %>% + dplyr::bind_rows() %>% + dplyr::distinct(AVISITN) %>% + dplyr::pull() + + awd <- tidyr::tibble(AVISIT = avisit_words, AVISITN = avisit_fctr) + avisit_words <- + awd %>% + dplyr::mutate(AVISIT = factor(AVISIT, + levels = awd[order(awd$AVISITN), "AVISIT"][[1]] %>% unique() )) %>% + dplyr::pull(AVISIT) %>% + unique() %>% + sort() + + avisit_words[avisit_words != ""] +} + +create_all_cols <- function(datalist) { + if("ADAE" %in% names(datalist)){ + all_cols <- unique(c( + colnames(datalist$ADSL)[sapply(datalist$ADSL, class) %in% c('character', 'factor')], + colnames(datalist$ADAE)[sapply(datalist$ADAE, class) %in% c('character', 'factor')] + )) + } else { + all_cols <- unique(c( + colnames(datalist$ADSL)[sapply(datalist$ADSL, class) %in% c('character', 'factor')] + )) + } + all_cols +} + +create_avals <- function(datalist) { + if (!any(purrr::map_lgl(datalist, ~ "ATPT" %in% colnames(.x)))) + stop("The field ATPT must be present in the data list") + + atpt_datasets <- purrr::map_lgl(datalist, ~ "ATPT" %in% colnames(.x)) + + avals <- + purrr::map(datalist[atpt_datasets], ~ .x %>% + dplyr::select(PARAMCD, dplyr::any_of(c("ATPT"))) %>% + dplyr::filter(dplyr::if_any(-PARAMCD, ~ !is.na(.x) & .x != "")) %>% + dplyr::pull(PARAMCD) %>% + get_levels() + ) + + ## TODO: Make this less confusing. I pity the soul who has to edit this. + purrr::imap(avals, ~ purrr::map(.x, function(i, j =.y) { + datalist[[j]] %>% + dplyr::filter(PARAMCD == i) %>% + dplyr::select(dplyr::any_of(c("ATPT", "ATPTN"))) %>% + varN_fctr_reorder() %>% + dplyr::select(dplyr::any_of(c("ATPT"))) %>% + purrr::map(~ .x %>% + addNA(ifany = TRUE) %>% + purrr::possibly(relevel, otherwise = .)(NA_character_) %>% + get_levels() %>% + tidyr::replace_na("N/A") %>% + {if (length(.) > 1) c("ALL", .) else .} %>% + as.list()) + }) %>% + purrr::set_names(.x) + ) +} diff --git a/R/mod_tableGen_fct_param_opts.R b/R/mod_tableGen_fct_param_opts.R new file mode 100644 index 00000000..cb3ef1a2 --- /dev/null +++ b/R/mod_tableGen_fct_param_opts.R @@ -0,0 +1,73 @@ +stat_options <- function(block, datalist, ...) { + UseMethod("stat_options", block) +} + +stat_options.default <- function(block, datalist, ...) { + if (is.null(block$stat_options)) + block$stat_options <- block$stat_selection + + block +} + +stat_options.avisit <- function(block, datalist, ...) { + avisits <- + datalist[[block$data]] %>% + dplyr::filter(stringr::str_detect(toupper(AVISIT), "UNSCHEDULED", negate = TRUE), + AVISIT != "") %>% + dplyr::distinct(AVISIT, AVISITN) %>% + varN_fctr_reorder() %>% + dplyr::pull(AVISIT) %>% + get_levels() %>% + as.list() + + block$stat_options <- avisits + + block +} + +stat_options.avisit_lab <- function(block, datalist, ...) { + avisits <- + datalist[sapply(datalist, function(x) "PARAMCD" %in% colnames(x)) & substr(names(datalist), 1, 4) == "ADLB"] %>% + purrr::map_dfc(dplyr::select, PARAMCD, AVAL, AVISIT, AVISITN) %>% + dplyr::filter(PARAMCD == block$variable) %>% + dplyr::filter(!is.na(AVAL), + !is.na(AVISIT), + !(AVISIT %in% c(" ", "")), + stringr::str_detect(toupper(AVISIT),"UNSCHEDULED",negate = TRUE) + ) %>% + dplyr::distinct(AVISIT, AVISITN) %>% + varN_fctr_reorder() %>% + dplyr::pull(AVISIT) %>% + get_levels() %>% + as.list() + + block$stat_options <- avisits + + block +} + +var_options <- function(block, datalist, ...) { + UseMethod("var_options", block) +} + +var_options.default <- function(block, datalist, ...) { + if (is.null(block$var_options)) + block$var_options <- block$var_selection + + block +} + +var_options.atpt <- function(block, datalist, ...) { + atpts <- + datalist[[block$data]] %>% + dplyr::filter(PARAMCD == block$variable) %>% + dplyr::distinct(ATPT, ATPTN) %>% + varN_fctr_reorder() %>% + dplyr::pull(ATPT) %>% + get_levels() %>% + {list(ATPT = as.list(c("ALL", .)))} + + block$var_options <- atpts + + block +} diff --git a/R/mod_tableGen_fct_recipe_incl.R b/R/mod_tableGen_fct_recipe_incl.R new file mode 100644 index 00000000..cbc604dd --- /dev/null +++ b/R/mod_tableGen_fct_recipe_incl.R @@ -0,0 +1,40 @@ +#' @importFrom jsonlite read_json +load_recipes <- function(recipe_file) { + recipes <- jsonlite::read_json(recipe_file) + + for (i in seq_along(recipes)) { + class(recipes[[i]]) <- c(class(recipes[[i]]), names(recipes)[i]) + class(recipes[[i]]$blocks) <- c(class(recipes[[i]]$blocks), recipes[[i]]$recipe_inclusion) + for (j in seq_along(recipes[[i]]$blocks)) { + class(recipes[[i]]$blocks[[j]]) <- c(class(recipes[[i]]$blocks), recipes[[i]]$blocks[[j]]$stat_options_fn, recipes[[i]]$blocks[[j]]$var_options_fn) + } + } + + recipes +} + +recipe_inclusion <- function(blocks, datalist, ...) { + UseMethod("recipe_inclusion", blocks) +} + +recipe_inclusion.default <- function(blocks, datalist, ...) { + data_incl <- purrr::map_lgl(blocks, ~ .x$data %in% names(datalist)) + if (!all(data_incl)) + return(rep(FALSE, length(blocks))) + + param_col_incl <- purrr::map_lgl(blocks, ~ .x$variable %in% datalist[[.x$data]][["PARAMCD"]] || .x$variable %in% names(datalist[[.x$data]])) + if (!all(param_col_incl)) + return(rep(FALSE, length(blocks))) + + param_col_incl +} + +recipe_inclusion.stan_labs <- function(blocks, datalist, ...) { + data_incl <- purrr::map_lgl(blocks, ~ "ADLB" %in% substr(names(datalist), 1, 4)) + if (!all(data_incl)) + return(rep(FALSE, length(blocks))) + + param_incl <- purrr::map_lgl(blocks, ~ .x$variable %in% unlist(purrr::map(datalist["ADLB" == substr(names(datalist), 1, 4)], ~ unique(.x[["PARAMCD"]])), use.names = FALSE)) + + param_incl +} diff --git a/R/mod_tableGen_ui.R b/R/mod_tableGen_ui.R index 23424111..ffd13a97 100644 --- a/R/mod_tableGen_ui.R +++ b/R/mod_tableGen_ui.R @@ -40,7 +40,7 @@ mod_tableGen_ui <- function(id){ fluidRow(column(width = 12, div( id = "COLUMN-wrapper", - uiOutput(ns("grp_col_ui")) + selectInput(ns("COLUMN"), "Group Data By:", choices = "NONE", selected = "NONE") ), shinyUI(bootstrapPage( HTML('` + + `` +} + +/** + * Create dropdown menu from the array of AVISIT values +* @param {avisit} the text and value of the option +*/ +function createOption(opt, selection) { + return selection === undefined || selection != opt ? `` : `` +} + +Shiny.addCustomMessageHandler('submit_recipe', function(recipe) { + document.getElementById("droppable_blocks").innerHTML = ""; + document.getElementById("droppable_agg").innerHTML = ""; + + if (Object.keys(recipe).includes("blocks")) { + for(block of recipe.blocks){ + $("#droppable_blocks").append($(createRecipeBlock(block.variable, block.data, block.var_selection, block.var_options))); + $("#droppable_agg").append($(createRecipeBlock(block.statistic, block.data, block.stat_selection, block.stat_options))); + } + } + + Shiny.setInputValue('tableGen_ui_1-recipe', recipe.title) +}) +}); // $document.ready() diff --git a/inst/app/www/script.js b/inst/app/www/js/script.js similarity index 73% rename from inst/app/www/script.js rename to inst/app/www/js/script.js index a7983a93..7a9ff7e3 100644 --- a/inst/app/www/script.js +++ b/inst/app/www/js/script.js @@ -1,4 +1,4 @@ -$( document ).ready(function() { +$( document ).on('shiny:connected', function() { // setup sortable and draggable functionality $(function() { $("#sortable_agg").sortable(); @@ -31,6 +31,7 @@ $( document ).ready(function() { function setUpShiny(id, outputID, obj) { var obj = { numbers: [] } var str = ""; + var txt; var df; var grp; var val; var lst; $('#' + id).each(function() { txt = $(this).text() df = $(this).attr("class").split(" ")[1] @@ -131,7 +132,8 @@ selectChange("droppable_blocks", 'droppable_blocks label', 'tableGen_ui_1-block_ } - +let weeks_array = null +let week_opts = [''] /** * Function that brings in vectors from shiny and uses * them to create the appropriate style block for the agg chosen @@ -140,87 +142,58 @@ selectChange("droppable_blocks", 'droppable_blocks label', 'tableGen_ui_1-block_ Shiny.addCustomMessageHandler('my_weeks', function(df) { // the dataframe column is imported as an array weeks_array = Object.values(df) - week_opts = `${weeks_array.map(createOption).join("")}` - //console.log("weeks_array[0]:", weeks_array[0]) - + week_opts = weeks_array.map(createOption) +}); + +let col_array = null +let col_opts = [''] +Shiny.addCustomMessageHandler('all_cols', function(cols) { - Shiny.addCustomMessageHandler('all_cols', function(cols) { - // the dataframe column is imported as an array col_array = Object.values(cols) - col_opts = `${col_array.map(createOption).join("")}` - - + col_opts = col_array.map(createOption) +}); + /** * A function to run if no BDS dataframes are loaded: leave * week options blank since their default method is null and remove the * rows for the mean block since we don't need a dropdown for week */ - // if weeks array is undefined, then do all cols version, else all cols and weeks_array - if (weeks_array[0] === "fake_weeky") { - // no weeks, just col dropdowns - $(function() { - $(".draggable_agg").draggable(); - $("#droppable_agg").droppable({ - accept: ".agg", - drop: function(event, ui) { - var draggableId = ui.draggable.attr("id"); - var newid = getNewId(draggableId); - if (draggableId.includes("anova")) { - $(this).append(selectBlock(newid, "ANOVA")); - } else if (draggableId.includes("chg")) { - $(this).append(selectBlock(newid, "CHG")); - //} else if (draggableId.includes("mean")) { - // $(this).append(selectBlock(newid, "MEAN")); - } else if (draggableId.includes("nested_freq_dsc")) { - $(this).append(selectBlock(newid, "NESTED_FREQ_DSC", col_opts)); - } else if (draggableId.includes("nested_freq_abc")) { - $(this).append(selectBlock(newid, "NESTED_FREQ_ABC", col_opts)); - } else { - $(this).append(simpleBlock(newid, "df")); - } +$(function() { + $(".draggable_agg").draggable(); + $("#droppable_agg").droppable({ + accept: ".agg", + drop: function(event, ui) { + var draggableId = ui.draggable.attr("id"); + var newid = getNewId(draggableId); + if (weeks_array) { + if (draggableId.includes("anova")) { + $(this).append(selectBlock(newid, "ANOVA", week_opts)); + } else if (draggableId.includes("chg")) { + $(this).append(selectBlock(newid, "CHG", week_opts)); + } else if (draggableId.includes("mean")) { + $(this).append(selectBlock(newid, "MEAN", week_opts)); + } else if (draggableId.includes("nested_freq_dsc")) { + $(this).append(selectBlock(newid, "NESTED_FREQ_DSC", col_opts)); + } else if (draggableId.includes("nested_freq_abc")) { + $(this).append(selectBlock(newid, "NESTED_FREQ_ABC", col_opts)); + } else { + $(this).append(simpleBlock(newid, "df")); } - }).sortable({ - revert: false - }) - }); // end all_cols only function(), ie, no weeks! - - - } else { // Weeks exist in the function below - -/** - * A function to run if BDS dataframes are loaded and a - * week option needs to be created for some agg blocks -*/ - $(function() { - $(".draggable_agg").draggable(); - $("#droppable_agg").droppable({ - accept: ".agg", - drop: function(event, ui) { - var draggableId = ui.draggable.attr("id"); - var newid = getNewId(draggableId); - if (draggableId.includes("anova")) { - $(this).append(selectBlock(newid, "ANOVA", week_opts)); - } else if (draggableId.includes("chg")) { - $(this).append(selectBlock(newid, "CHG", week_opts)); - } else if (draggableId.includes("mean")) { - $(this).append(selectBlock(newid, "MEAN", week_opts)); - } else if (draggableId.includes("nested_freq_dsc")) { - $(this).append(selectBlock(newid, "NESTED_FREQ_DSC", col_opts)); - } else if (draggableId.includes("nested_freq_abc")) { - $(this).append(selectBlock(newid, "NESTED_FREQ_ABC", col_opts)); - } else { - $(this).append(simpleBlock(newid, "df")); - } + } else { + if (draggableId.includes("nested_freq_dsc")) { + $(this).append(selectBlock(newid, "NESTED_FREQ_DSC", col_opts)); + } else if (draggableId.includes("nested_freq_abc")) { + $(this).append(selectBlock(newid, "NESTED_FREQ_ABC", col_opts)); + } else { + $(this).append(simpleBlock(newid, "df")); } - }).sortable({ - revert: false - }) - }); // end all_cols and weeks function() - - } // end of if-then-else - }); // end "all_cols" handler -}); // end "my_weeks" handler + } + } + }).sortable({ + revert: false + }) +}) /** @@ -233,7 +206,7 @@ Shiny.addCustomMessageHandler('my_weeks', function(df) { ` diff --git a/inst/app/www/sync_divs.js b/inst/app/www/js/sync_divs.js similarity index 100% rename from inst/app/www/sync_divs.js rename to inst/app/www/js/sync_divs.js diff --git a/inst/app/www/recipe.js b/inst/app/www/recipe.js deleted file mode 100644 index fa7f674b..00000000 --- a/inst/app/www/recipe.js +++ /dev/null @@ -1,188 +0,0 @@ -$(document).ready(function(){ - -/* Function to create list of row blocks. If we need a block with a text String -or a dropdown, make a new function here */ -function simpleRecipeRowBlock(newid, df) { - return ` -
- - -
` -} - -function selectRecipeBlock(newid, df, selection, values = '') { - return `
- - - -
` -} - -// this is used for combining block rows (on either the Var or STAT agg -// side) scanning through the array, and appends to the html above -// and join() concatenates it all together, joining on nothing ("") -// the df (df name as a string) remains constant -function combineRows(block_array, df) { - let t = [] - block_array.forEach(function (blk) { - t.push(simpleRecipeRowBlock(blk, df)) - }); - t= t.join("") - return(t) -} - -/** - * Create dropdown menu from the array of AVISIT values -* @param {avisit} the text and value of the option -*/ -function createOption(opt) { - return `` -} - -// The following function creates a stat block for every var block on -// the LHS, and creates a dropdown. The var_block and select_input arrays -// must be of the same length. Used for Table 41. -function oneAgg_combineSelects(var_block, agg_stat, df, select_options) { - let t = Array(var_block.length); - for(var i = 0; i < var_block.length; i += 1){ - t.push(selectRecipeBlock(agg_stat, df, "ALL", select_options)) - }; - t= t.join("") - return(t) -} - -// These are called arrays -const demography_rows = ["AGEGR1", "AGE", "SEX", "ETHNIC", "RACE", "HEIGHTBL", "WEIGHTBL"] -const demography_agg = ["FREQ", "MEAN", "FREQ", "FREQ", "FREQ", "MEAN", "MEAN"] - - -const ae18_rows = ["AOCCFL", "AESEV", "AESER","DTHDT"] -const ae18_agg = ["Y_FREQ", "MAX_FREQ", "Y_FREQ", "NON_MISSING"] - -const soc_pt_rows = ["AOCCFL", "AEBODSYS"] -const soc_pt_agg = ["Y_FREQ", "NESTED_FREQ_DSC"] -const soc_pt_sel = ["NONE", "AEDECOD"] - -let bc_obj = null; -Shiny.addCustomMessageHandler('adlbc', function(adlbc) { - bc_obj = adlbc; -}); - -let he_obj = null; -Shiny.addCustomMessageHandler('adlbh', function(adlbh) { - he_obj = adlbh; -}); - -let ur_obj = null; -Shiny.addCustomMessageHandler('adlbu', function(adlbu) { - ur_obj = adlbu; -}) - -$(document).on('click', '#RECIPE', function(){ -/* Create custom block recipes to automatically populate when selected */ -$("#RECIPE").bind("change", function(event, ui) { - let publisher = $("#RECIPE").val(); - switch(publisher) { - case "Table 3: Accounting of Subjects": - document.getElementById("droppable_blocks").innerHTML = ""; - $("#droppable_blocks").append($(simpleRecipeRowBlock("RANDFL", "ADSL"))); - $("#droppable_blocks").append($(simpleRecipeRowBlock("SAFFL", "ADSL"))); - $("#droppable_blocks").append($(simpleRecipeRowBlock("EOTSTT", "ADSL"))); - $("#droppable_blocks").append($(simpleRecipeRowBlock("EOSSTT", "ADSL"))); - - document.getElementById("droppable_agg").innerHTML = ""; - $("#droppable_agg").append($(simpleRecipeRowBlock("Y_FREQ", "ADAE"))); - $("#droppable_agg").append($(simpleRecipeRowBlock("FREQ", "ADSL"))); - $("#droppable_agg").append($(selectRecipeBlock("NESTED_FREQ_ABC", "ADSL", "DCTREAS"))); - $("#droppable_agg").append($(selectRecipeBlock("NESTED_FREQ_ABC", "ADSL", "DCSREAS"))); - break; - case "Table 5: Demography": - document.getElementById("droppable_agg").innerHTML = ""; - $("#droppable_agg").append($(combineRows(demography_agg, "ADSL"))); - document.getElementById("droppable_blocks").innerHTML = ""; - $("#droppable_blocks").append($(combineRows(demography_rows, "ADSL"))); - break; - case "Table 18: Overall summary of adverse events": - document.getElementById("droppable_agg").innerHTML = ""; - $("#droppable_agg").append($(combineRows(ae18_agg, "ADAE"))); - document.getElementById("droppable_blocks").innerHTML = ""; - $("#droppable_blocks").append($(combineRows(ae18_rows, "ADAE"))); - break; - case "Table 20: Adverse events by system organ class and preferred term sorted by alphabetical order": - document.getElementById("droppable_agg").innerHTML = ""; - $("#droppable_agg").append($(simpleRecipeRowBlock("NON_MISSING", "ADAE"))); - $("#droppable_agg").append($(selectRecipeBlock("NESTED_FREQ_ABC", "ADAE", "AEDECOD"))); - document.getElementById("droppable_blocks").innerHTML = ""; - $("#droppable_blocks").append($(simpleRecipeRowBlock("USUBJID", "ADAE"))); - $("#droppable_blocks").append($(simpleRecipeRowBlock("AEBODSYS", "ADAE"))); - break; - case "Table 19: Adverse events by system organ class and preferred term sorted by decreasing frequency": - case "Table 25: Severe adverse events by system organ class and preferred term": - case "Table 29: Related adverse events by system organ class and preferred term": - case "Table 30: Serious adverse events by system organ class and preferred term": - case "Table 33: Related serious adverse events by system organ class and preferred term": - case "Table 34: Adverse events that led to discontinuation of study treatment by system organ class and preferred term": - case "Table 36: Adverse events that led to withdrawal from study by system organ class and preferred term": - case "Table 38: Adverse events that led to drug interrupted, dose reduced, or dose increased by system organ class and preferred term": - document.getElementById("droppable_agg").innerHTML = ""; - $("#droppable_agg").append($(simpleRecipeRowBlock("NON_MISSING", "ADAE"))); - $("#droppable_agg").append($(selectRecipeBlock("NESTED_FREQ_DSC", "ADAE", "AEDECOD"))); - document.getElementById("droppable_blocks").innerHTML = ""; - $("#droppable_blocks").append($(simpleRecipeRowBlock("USUBJID", "ADAE"))); - $("#droppable_blocks").append($(simpleRecipeRowBlock("AEBODSYS", "ADAE"))); - break; - case "Table 21: Adverse events by system organ class": - document.getElementById("droppable_agg").innerHTML = ""; - $("#droppable_agg").append($(simpleRecipeRowBlock("NON_MISSING", "ADAE"))); - $("#droppable_agg").append($(selectRecipeBlock("NESTED_FREQ_DSC", "ADAE", "NONE"))); - document.getElementById("droppable_blocks").innerHTML = ""; - $("#droppable_blocks").append($(simpleRecipeRowBlock("USUBJID", "ADAE"))); - $("#droppable_blocks").append($(simpleRecipeRowBlock("AEBODSYS", "ADAE"))); - break; - case "Table 23: Adverse events by preferred term": - case "Table 26: Severe adverse events by preferred term": - case "Table 31: Serious adverse events by preferred term": - document.getElementById("droppable_agg").innerHTML = ""; - $("#droppable_agg").append($(simpleRecipeRowBlock("NON_MISSING", "ADAE"))); - $("#droppable_agg").append($(selectRecipeBlock("NESTED_FREQ_DSC", "ADAE", "NONE"))); - document.getElementById("droppable_blocks").innerHTML = ""; - $("#droppable_blocks").append($(simpleRecipeRowBlock("USUBJID", "ADAE"))); - $("#droppable_blocks").append($(simpleRecipeRowBlock("AEDECOD", "ADAE"))); - break; - case "Table 41: Blood Chemistry actual values by visit": - var select_opts = `${bc_obj.weeks.map(createOption).join("")}` - document.getElementById("droppable_agg").innerHTML = ""; - $("#droppable_agg").append($(oneAgg_combineSelects(bc_obj.params, "MEAN", "ADLB", select_opts))); - document.getElementById("droppable_blocks").innerHTML = ""; - $("#droppable_blocks").append($(combineRows(bc_obj.params, "ADLB"))); - break; - case "Table 41: Hematology actual values by visit": - var select_opts = `${he_obj.weeks.map(createOption).join("")}` - document.getElementById("droppable_agg").innerHTML = ""; - $("#droppable_agg").append($(oneAgg_combineSelects(he_obj.params,"MEAN","ADLB", select_opts))); - document.getElementById("droppable_blocks").innerHTML = ""; - $("#droppable_blocks").append($(combineRows(he_obj.params, "ADLB"))); - break; - case "Table 41: Urinalysis actual values by visit": - var select_opts = `${ur_obj.weeks.map(createOption).join("")}` - document.getElementById("droppable_agg").innerHTML = ""; - $("#droppable_agg").append($(oneAgg_combineSelects(ur_obj.params,"MEAN","ADLB", select_opts))); - document.getElementById("droppable_blocks").innerHTML = ""; - $("#droppable_blocks").append($(combineRows(ur_obj.params, "ADLB"))); - break; - default: - document.getElementById("droppable_agg").innerHTML = ""; - document.getElementById("droppable_blocks").innerHTML = ""; - } -}); - -$('select#RECIPE').change(function() { - var selectedDropdown = $(this).children('option:selected').val() - Shiny.setInputValue('tableGen_ui_1-recipe', selectedDropdown) -}) - -}); // $(document).on('click', '#RECIPE' -}); // $document.ready() diff --git a/inst/recipes.json b/inst/recipes.json new file mode 100644 index 00000000..04cf24f6 --- /dev/null +++ b/inst/recipes.json @@ -0,0 +1,161 @@ +{ + "stan_3": { + "title": "Table 3: Accounting of Subjects", + "group_by": "TRT01P", + "blocks": [{"data":"ADSL", "variable":"RANDFL", "statistic":"Y_FREQ"}, + {"data":"ADSL", "variable":"SAFFL", "statistic":"FREQ"}, + {"data":"ADSL", "variable":"EOTSTT", "statistic":"NESTED_FREQ_ABC", "stat_selection":"DCTREAS"}, + {"data":"ADSL", "variable":"EOSSTT", "statistic":"NESTED_FREQ_ABC", "stat_selection":"DCSREAS"}] + }, + "stan_5": { + "title": "Table 5: Demography", + "group_by": "TRT01P", + "blocks": [{"data":"ADSL", "variable":"AGEGR1", "statistic":"FREQ"}, + {"data":"ADSL", "variable":"AGE", "statistic":"MEAN"}, + {"data":"ADSL", "variable":"SEX", "statistic":"FREQ"}, + {"data":"ADSL", "variable":"ETHNIC", "statistic":"FREQ"}, + {"data":"ADSL", "variable":"RACE", "statistic":"FREQ"}, + {"data":"ADSL", "variable":"HEIGHTBL", "statistic":"MEAN"}, + {"data":"ADSL", "variable":"WEIGHTBL", "statistic":"MEAN"}] + }, + "stan_18": { + "title": "Table 18: Overall summary of adverse events", + "group_by": "TRT01P", + "blocks": [{"data":"ADAE", "variable":"AOCCFL", "statistic":"Y_FREQ"}, + {"data":"ADAE", "variable":"AESEV", "statistic":"MAX_FREQ"}, + {"data":"ADAE", "variable":"AESER", "statistic":"Y_FREQ"}, + {"data":"ADSL", "variable":"DTHDT", "statistic":"NON_MISSING"}] + }, + "stan_19": { + "title": "Table 19: Adverse events by system organ class and preferred term sorted by decreasing frequency", + "group_by": "TRT01P", + "blocks": [{"data":"ADAE", "variable":"USUBJID", "statistic":"NON_MISSING"}, + {"data":"ADAE", "variable":"AEBODSYS", "statistic":"NESTED_FREQ_DSC", "stat_selection":"AEDECOD"}] + }, + "stan_20": { + "title": "Table 20: Adverse events by system organ class and preferred term sorted by alphabetical order", + "group_by": "TRT01P", + "blocks": [{"data":"ADAE", "variable":"USUBJID", "statistic":"NON_MISSING"}, + {"data":"ADAE", "variable":"AEBODSYS", "statistic":"NESTED_FREQ_ABC", "stat_selection":"AEDECOD"}] + }, + "stan_21": { + "title": "Table 21: Adverse events by system organ class", + "group_by": "TRT01P", + "blocks": [{"data":"ADAE", "variable":"USUBJID", "statistic":"NON_MISSING"}, + {"data":"ADAE", "variable":"AEBODSYS", "statistic":"NESTED_FREQ_ABC", "stat_selection":"NONE"}] + }, + "stan_23": { + "title": "Table 23: Adverse events by preferred term", + "group_by": "TRT01P", + "blocks": [{"data":"ADAE", "variable":"USUBJID", "statistic":"NON_MISSING"}, + {"data":"ADAE", "variable":"AEDECOD", "statistic":"NESTED_FREQ_ABC", "stat_selection":"NONE"}] + }, + "stan_25": { + "title": "Table 25: Severe adverse events by system organ class and preferred term", + "group_by": "TRT01P", + "blocks": [{"data":"ADAE", "variable":"USUBJID", "statistic":"NON_MISSING"}, + {"data":"ADAE", "variable":"AEBODSYS", "statistic":"NESTED_FREQ_DSC", "stat_selection":"AEDECOD"}] + }, + "stan_26": { + "title": "Table 26: Severe adverse events by preferred term", + "group_by": "TRT01P", + "blocks": [{"data":"ADAE", "variable":"USUBJID", "statistic":"NON_MISSING"}, + {"data":"ADAE", "variable":"AEDECOD", "statistic":"NESTED_FREQ_ABC", "stat_selection":"NONE"}] + }, + "stan_29": { + "title": "Table 29: Related adverse events by system organ class and preferred term", + "group_by": "TRT01P", + "blocks": [{"data":"ADAE", "variable":"USUBJID", "statistic":"NON_MISSING"}, + {"data":"ADAE", "variable":"AEBODSYS", "statistic":"NESTED_FREQ_DSC", "stat_selection":"AEDECOD"}] + }, + "stan_30": { + "title": "Table 30: Serious adverse events by system organ class and preferred term", + "group_by": "TRT01P", + "blocks": [{"data":"ADAE", "variable":"USUBJID", "statistic":"NON_MISSING"}, + {"data":"ADAE", "variable":"AEBODSYS", "statistic":"NESTED_FREQ_DSC", "stat_selection":"AEDECOD"}] + }, + "stan_31": { + "title": "Table 31: Serious adverse events by preferred term", + "group_by": "TRT01P", + "blocks": [{"data":"ADAE", "variable":"USUBJID", "statistic":"NON_MISSING"}, + {"data":"ADAE", "variable":"AEDECOD", "statistic":"NESTED_FREQ_ABC", "stat_selection":"NONE"}] + }, + "stan_33": { + "title": "Table 33: Related serious adverse events by system organ class and preferred term", + "group_by": "TRT01P", + "blocks": [{"data":"ADAE", "variable":"USUBJID", "statistic":"NON_MISSING"}, + {"data":"ADAE", "variable":"AEBODSYS", "statistic":"NESTED_FREQ_DSC", "stat_selection":"AEDECOD"}] + }, + "stan_34": { + "title": "Table 34: Adverse events that led to discontinuation of study treatment by system organ class and preferred term", + "group_by": "TRT01P", + "blocks": [{"data":"ADAE", "variable":"USUBJID", "statistic":"NON_MISSING"}, + {"data":"ADAE", "variable":"AEBODSYS", "statistic":"NESTED_FREQ_DSC", "stat_selection":"AEDECOD"}] + }, + "stan_36": { + "title": "Table 36: Adverse events that led to withdrawl from study by system organ class and preferred term", + "group_by": "TRT01P", + "blocks": [{"data":"ADAE", "variable":"USUBJID", "statistic":"NON_MISSING"}, + {"data":"ADAE", "variable":"AEBODSYS", "statistic":"NESTED_FREQ_DSC", "stat_selection":"AEDECOD"}] + }, + "stan_38": { + "title": "Table 38: Adverse events that led to drug interrupted, dose reduced, or dose increased by system organ class and preferred term", + "group_by": "TRT01P", + "blocks": [{"data":"ADAE", "variable":"USUBJID", "statistic":"NON_MISSING"}, + {"data":"ADAE", "variable":"AEBODSYS", "statistic":"NESTED_FREQ_DSC", "stat_selection":"AEDECOD"}] + }, + "stan_41_chem": { + "title": "Table 41: Blood Chemistry actual values by visit", + "group_by": "TRT01P", + "recipe_inclusion": "stan_labs", + "blocks": [{"data":"ADLB", "variable":"ALT", "statistic":"MEAN", "stat_selection":"ALL", "stat_options_fn":"avisit_lab"}, + {"data":"ADLB", "variable":"AST", "statistic":"MEAN", "stat_selection":"ALL", "stat_options_fn":"avisit_lab"}, + {"data":"ADLB", "variable":"ALP", "statistic":"MEAN", "stat_selection":"ALL", "stat_options_fn":"avisit_lab"}, + {"data":"ADLB", "variable":"BILI", "statistic":"MEAN", "stat_selection":"ALL", "stat_options_fn":"avisit_lab"}, + {"data":"ADLB", "variable":"GGT", "statistic":"MEAN", "stat_selection":"ALL", "stat_options_fn":"avisit_lab"}, + {"data":"ADLB", "variable":"BUN", "statistic":"MEAN", "stat_selection":"ALL", "stat_options_fn":"avisit_lab"}, + {"data":"ADLB", "variable":"CREAT", "statistic":"MEAN", "stat_selection":"ALL", "stat_options_fn":"avisit_lab"}, + {"data":"ADLB", "variable":"SODIUM", "statistic":"MEAN", "stat_selection":"ALL", "stat_options_fn":"avisit_lab"}, + {"data":"ADLB", "variable":"K", "statistic":"MEAN", "stat_selection":"ALL", "stat_options_fn":"avisit_lab"}, + {"data":"ADLB", "variable":"CL", "statistic":"MEAN", "stat_selection":"ALL", "stat_options_fn":"avisit_lab"}, + {"data":"ADLB", "variable":"BICARB", "statistic":"MEAN", "stat_selection":"ALL", "stat_options_fn":"avisit_lab"}, + {"data":"ADLB", "variable":"GLUC", "statistic":"MEAN", "stat_selection":"ALL", "stat_options_fn":"avisit_lab"}, + {"data":"ADLB", "variable":"CA", "statistic":"MEAN", "stat_selection":"ALL", "stat_options_fn":"avisit_lab"}, + {"data":"ADLB", "variable":"PHOS", "statistic":"MEAN", "stat_selection":"ALL", "stat_options_fn":"avisit_lab"}, + {"data":"ADLB", "variable":"ALB", "statistic":"MEAN", "stat_selection":"ALL", "stat_options_fn":"avisit_lab"}, + {"data":"ADLB", "variable":"CHOL", "statistic":"MEAN", "stat_selection":"ALL", "stat_options_fn":"avisit_lab"}, + {"data":"ADLB", "variable":"MG", "statistic":"MEAN", "stat_selection":"ALL", "stat_options_fn":"avisit_lab"}, + {"data":"ADLB", "variable":"TRIG", "statistic":"MEAN", "stat_selection":"ALL", "stat_options_fn":"avisit_lab"}, + {"data":"ADLB", "variable":"URATE", "statistic":"MEAN", "stat_selection":"ALL", "stat_options_fn":"avisit_lab"}] + }, + "stan_41_hema": { + "title": "Table 41: Hematology actual values by visit", + "group_by": "TRT01P", + "recipe_inclusion": "stan_labs", + "blocks": [{"data":"ADLB", "variable":"LYM", "statistic":"MEAN", "stat_selection":"ALL", "stat_options_fn":"avisit_lab_lab"}, + {"data":"ADLB", "variable":"NEUT", "statistic":"MEAN", "stat_selection":"ALL", "stat_options_fn":"avisit_lab"}, + {"data":"ADLB", "variable":"MONO", "statistic":"MEAN", "stat_selection":"ALL", "stat_options_fn":"avisit_lab"}, + {"data":"ADLB", "variable":"EOS", "statistic":"MEAN", "stat_selection":"ALL", "stat_options_fn":"avisit_lab"}, + {"data":"ADLB", "variable":"BASO", "statistic":"MEAN", "stat_selection":"ALL", "stat_options_fn":"avisit_lab"}, + {"data":"ADLB", "variable":"RBC", "statistic":"MEAN", "stat_selection":"ALL", "stat_options_fn":"avisit_lab"}, + {"data":"ADLB", "variable":"HGB", "statistic":"MEAN", "stat_selection":"ALL", "stat_options_fn":"avisit_lab"}, + {"data":"ADLB", "variable":"HCT", "statistic":"MEAN", "stat_selection":"ALL", "stat_options_fn":"avisit_lab"}, + {"data":"ADLB", "variable":"PLAT", "statistic":"MEAN", "stat_selection":"ALL", "stat_options_fn":"avisit_lab"}] + }, + "stan_41_urin": { + "title": "Table 41: Urinalysis actual values by visit", + "group_by": "TRT01P", + "recipe_inclusion": "stan_labs", + "blocks": [{"data":"ADLB", "variable":"SPGRAV", "statistic":"MEAN", "stat_selection":"ALL", "stat_options_fn":"avisit_lab"}, + {"data":"ADLB", "variable":"PH", "statistic":"MEAN", "stat_selection":"ALL", "stat_options_fn":"avisit_lab"}, + {"data":"ADLB", "variable":"COLOR", "statistic":"MEAN", "stat_selection":"ALL", "stat_options_fn":"avisit_lab"}, + {"data":"ADLB", "variable":"OCCBLD", "statistic":"MEAN", "stat_selection":"ALL", "stat_options_fn":"avisit_lab"}, + {"data":"ADLB", "variable":"GLUCU", "statistic":"MEAN", "stat_selection":"ALL", "stat_options_fn":"avisit_lab"}, + {"data":"ADLB", "variable":"KETONES", "statistic":"MEAN", "stat_selection":"ALL", "stat_options_fn": "avisit_lab"}, + {"data":"ADLB", "variable":"PROTU", "statistic":"MEAN", "stat_selection":"ALL", "stat_options_fn": "avisit_lab"}, + {"data":"ADLB", "variable":"MWBCQU", "statistic":"MEAN", "stat_selection":"ALL", "stat_options_fn": "avisit_lab"}, + {"data":"ADLB", "variable":"MWBCU", "statistic":"MEAN", "stat_selection":"ALL", "stat_options_fn": "avisit_lab"}, + {"data":"ADLB", "variable":"MRBCQU", "statistic":"MEAN", "stat_selection":"ALL", "stat_options_fn": "avisit_lab"}, + {"data":"ADLB", "variable":"MRBCU", "statistic":"MEAN", "stat_selection":"ALL", "stat_options_fn": "avisit_lab"}] + } +} diff --git a/man/addBlock.Rd b/man/addBlock.Rd new file mode 100644 index 00000000..6e1139fa --- /dev/null +++ b/man/addBlock.Rd @@ -0,0 +1,44 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/blockData.R +\name{addBlock} +\alias{addBlock} +\title{Add Block to Block Data Object} +\usage{ +addBlock(bd, variable, stat, dropdown, tpnt, df, after = NULL) +} +\arguments{ +\item{bd}{A block data object} + +\item{variable}{The parameter or field the statistic is based on} + +\item{stat}{The statistic to be calculated} + +\item{dropdown}{A subgroup on which the statistic is calculated (usually an AVISIT)} + +\item{tpnt}{A time point on which the calculation is filtered} + +\item{df}{The dataset the parameter or field is from} + +\item{after}{A subscript, after which the values are to be appended} +} +\value{ +The \code{bd} block data object with additional block +} +\description{ +Add Block to Block Data Object +} +\examples{ + +datalist <- list(ADSL = tidyCDISC::adsl, ADVS = tidyCDISC::advs, + ADAE = tidyCDISC::adae, ADLBC = tidyCDISC::adlbc) +bd <- createBlockdata(datalist) + +\dontrun{ + addBlock(bd) + bd +} + +addBlock(bd, "DIABP", "MEAN", "ALL", "ALL") +bd +} +\keyword{table_blocks} diff --git a/man/createBlockdata.Rd b/man/createBlockdata.Rd new file mode 100644 index 00000000..5e8df007 --- /dev/null +++ b/man/createBlockdata.Rd @@ -0,0 +1,27 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/blockData.R +\name{createBlockdata} +\alias{createBlockdata} +\title{Create Block Data Object} +\usage{ +createBlockdata(datalist, title) +} +\arguments{ +\item{datalist}{A list of ADaM-ish datasets used to generate the table} + +\item{title}{The title for the table} +} +\value{ +A block data object +} +\description{ +Create Block Data Object +} +\examples{ + +datalist <- list(ADSL = tidyCDISC::adsl, ADVS = tidyCDISC::advs, + ADAE = tidyCDISC::adae, ADLBC = tidyCDISC::adlbc) +bd <- createBlockdata(datalist) +bd +} +\keyword{table_blocks} diff --git a/man/removeBlock.Rd b/man/removeBlock.Rd new file mode 100644 index 00000000..811f2f1b --- /dev/null +++ b/man/removeBlock.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/blockData.R +\name{removeBlock} +\alias{removeBlock} +\title{Remove Block(s) from Block Data Object} +\usage{ +removeBlock(bd, x) +} +\arguments{ +\item{bd}{A block data object} + +\item{x}{vector specifying elements to remove from block data object} +} +\value{ +The \code{bd} block data object with additional block +} +\description{ +Remove Block(s) from Block Data Object +} +\keyword{table_blocks} diff --git a/man/run_app.Rd b/man/run_app.Rd index 6749fb75..dbbead7d 100644 --- a/man/run_app.Rd +++ b/man/run_app.Rd @@ -4,10 +4,12 @@ \alias{run_app} \title{Run the Shiny Application} \usage{ -run_app(...) +run_app(..., recipes_json = NULL) } \arguments{ \item{...}{A series of options to be used inside the app.} + +\item{recipes_json}{Path to JSON file with metadata} } \value{ No return value, called to run the application. diff --git a/man/setGroup.Rd b/man/setGroup.Rd new file mode 100644 index 00000000..426e430e --- /dev/null +++ b/man/setGroup.Rd @@ -0,0 +1,28 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/blockData.R +\name{setGroup} +\alias{setGroup} +\title{Set the title for the table object} +\usage{ +setGroup(bd, group_by) +} +\arguments{ +\item{bd}{A block data object} + +\item{group_by}{A field to group the table by} +} +\value{ +The \code{bd} block data object with updated group by field +} +\description{ +Set the title for the table object +} +\examples{ + +datalist <- list(ADSL = tidyCDISC::adsl, ADVS = tidyCDISC::advs, + ADAE = tidyCDISC::adae, ADLBC = tidyCDISC::adlbc) +bd <- createBlockdata(datalist) +setGroup(bd, "TRT01P") +bd$group_by +} +\keyword{table_blocks} diff --git a/man/setTitle.Rd b/man/setTitle.Rd new file mode 100644 index 00000000..0316e5c6 --- /dev/null +++ b/man/setTitle.Rd @@ -0,0 +1,28 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/blockData.R +\name{setTitle} +\alias{setTitle} +\title{Set the title for the table object} +\usage{ +setTitle(bd, title) +} +\arguments{ +\item{bd}{A block data object} + +\item{title}{The title for the table} +} +\value{ +The \code{bd} block data object with supplied title +} +\description{ +Set the title for the table object +} +\examples{ + +datalist <- list(ADSL = tidyCDISC::adsl, ADVS = tidyCDISC::advs, + ADAE = tidyCDISC::adae, ADLBC = tidyCDISC::adlbc) +bd <- createBlockdata(datalist) +setTitle(bd, "Table 1") +bd$title +} +\keyword{table_blocks} diff --git a/man/tg_gt.Rd b/man/tg_gt.Rd index 96e1dfe2..d0373bfb 100644 --- a/man/tg_gt.Rd +++ b/man/tg_gt.Rd @@ -9,7 +9,7 @@ tg_gt(tg_datalist, blockData, total_df, group) \arguments{ \item{tg_datalist}{A list containing the data frames used to create the table} -\item{blockData}{The data for the construction of the blocks in the table} +\item{blockData}{The data frame for the construction of the blocks in the table or the block data object} \item{total_df}{A data frame containing the totals by grouping variable} diff --git a/man/writeJSON.Rd b/man/writeJSON.Rd new file mode 100644 index 00000000..1a4162e5 --- /dev/null +++ b/man/writeJSON.Rd @@ -0,0 +1,17 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/blockData.R +\name{writeJSON} +\alias{writeJSON} +\title{Write block data object to a JSON file} +\usage{ +writeJSON(bd, file) +} +\arguments{ +\item{bd}{A block data object} + +\item{file}{File or connection to write to} +} +\description{ +Write block data object to a JSON file +} +\keyword{table_blocks} diff --git a/tests/testthat/test-blockData.R b/tests/testthat/test-blockData.R new file mode 100644 index 00000000..1be14e73 --- /dev/null +++ b/tests/testthat/test-blockData.R @@ -0,0 +1,151 @@ +table_blocks_tester <- R6::R6Class( + inherit = table_blocks, + public = list( + test_stats = function(expected) { + expect_equal(private$stats, expected) + }, + test_my_weeks = function(expected) { + expect_equal(private$my_weeks, expected) + }, + test_all_cols = function(expected) { + expect_equal(sort(private$all_cols), sort(expected)) + }, + test_my_avals = function(expected) { + expect_equal(private$my_avals, expected) + }, + test_block_drop = function(expected) { + expect_equal(private$block_drop, expected) + }, + test_agg_drop = function(expected) { + expect_equal(private$agg_drop, expected) + } + ) +) + +test_that("table_blocks is working", { + datalist <- list(ADSL = tidyCDISC::adsl, ADVS = tidyCDISC::advs) + + test_bd <- table_blocks_tester$new(datalist, "My Title") + + # Check initialization values + expect_equal(nrow(test_bd$blocks), 0) + expect_equal(test_bd$title, "My Title") + expect_equal(test_bd$group_by, NULL) + + stats <- c("ANOVA", "CHG", "MEAN", "FREQ", "Y_FREQ", "MAX_FREQ", "NON_MISSING", "NESTED_FREQ_DSC", "NESTED_FREQ_ABC") + test_bd$test_stats(stats) + + weeks <- c("Baseline", "Week 2", "Week 4", "Week 6", "Week 8", "Week 12", "Week 16", "Week 20", "Week 24", "Week 26", "End of Treatment") + test_bd$test_my_weeks(weeks) + + all_cols <- c("STUDYID", "USUBJID", "SUBJID", "SITEID", "SITEGR1", "ARM", "TRT01P", "TRT01A", "AGEGR1", "AGEU", "RACE", "SEX", "ETHNIC", "SAFFL", "ITTFL", "EFFFL", "COMP8FL", "COMP16FL", "COMP24FL", "DISCONFL", "DSRAEFL", "DTHFL", "BMIBLGR1", "DURDSGR1", "RFSTDTC", "RFENDTC", "DCDECOD", "EOSSTT", "DCSREAS", "FASFL", "RANDFL", "EOTSTT", "DCTREAS") + test_bd$test_all_cols(all_cols) + + avals <- list(ADVS = list(DIABP = list(ATPT = list("ALL", "AFTER LYING DOWN FOR 5 MINUTES", "AFTER STANDING FOR 1 MINUTE", "AFTER STANDING FOR 3 MINUTES")), + PULSE = list(ATPT = list("ALL", "AFTER LYING DOWN FOR 5 MINUTES", "AFTER STANDING FOR 1 MINUTE", "AFTER STANDING FOR 3 MINUTES")), + SYSBP = list(ATPT = list("ALL", "AFTER LYING DOWN FOR 5 MINUTES", "AFTER STANDING FOR 1 MINUTE", "AFTER STANDING FOR 3 MINUTES")))) + test_bd$test_my_avals(avals) + + test_bd$test_block_drop(list()) + + test_bd$test_agg_drop(list()) + + # Check addition of a block + test_bd$add_block("DIABP", "MEAN", "ALL", "ALL") + + expect_equal(nrow(test_bd$blocks), 33) + + expected_blocks <- list(txt = "DIABP", df = "ADVS", grp = "ATPT", val = "ALL", lst = c("AFTER LYING DOWN FOR 5 MINUTES", "AFTER STANDING FOR 1 MINUTE", "AFTER STANDING FOR 3 MINUTES")) + expected_aggs <- list(txt = "MEAN", val = "ALL", lst = weeks) + expected_drops <- process_droppables(list(list(expected_aggs)), list(list(expected_blocks))) + test_bd$test_block_drop(expected_drops$blocks) + test_bd$test_agg_drop(expected_drops$aggs) + + # Check removal of lines + test_bd$remove_block(-(1:3)) + + expect_equal(nrow(test_bd$blocks), 3) + + expected_blocks <- list(txt = "DIABP", df = "ADVS", grp = "ATPT", val = "ALL", lst = c("AFTER LYING DOWN FOR 5 MINUTES", "AFTER STANDING FOR 1 MINUTE", "AFTER STANDING FOR 3 MINUTES")) + expected_aggs <- list(txt = "MEAN", val = "ALL", lst = weeks[1]) + expected_drops <- process_droppables(list(list(expected_aggs)), list(list(expected_blocks))) + test_bd$test_block_drop(expected_drops$blocks) + test_bd$test_agg_drop(expected_drops$aggs) + +}) + +test_that("table_block wrappers work", { + datalist <- list(ADSL = tidyCDISC::adsl) + + bd <- createBlockdata(datalist) + + expect_equal(nrow(bd$blocks), 0) + + bd |> + addBlock("RANDFL", "Y_FREQ") |> + addBlock("EOSSTT", "NESTED_FREQ_ABC", "DCSREAS") + + block_table <- + structure(list(agg = c("Y_FREQ", "NESTED_FREQ_ABC"), + block = c("RANDFL", "EOSSTT"), + dataset = c("ADSL", "ADSL"), + dropdown = c(NA, "DCSREAS"), + filter = c(NA_character_, NA_character_), + S3 = list(structure("RANDFL", class = c("character", "ADSL")), + structure("EOSSTT", class = c("character", "ADSL"))), + gt_group = structure(c("Y_FREQ of RANDFL", "NESTED_FREQ_ABC of EOSSTT and DCSREAS"), + class = c("glue", "character")), + label = c("Randomized Population Flag", "End of Study Status"), + label_source = c("SAS \"label\" attribute", "SAS \"label\" attribute")), + row.names = c(NA, -2L), class = c("tbl_df", "tbl", "data.frame")) + expect_equal(bd$blocks, block_table) + + removeBlock(bd, 1) + + block_table <- + structure(list(agg = "NESTED_FREQ_ABC", + block = "EOSSTT", + dataset = "ADSL", + dropdown = "DCSREAS", + filter = NA_character_, + S3 = list(structure("EOSSTT", class = c("character", "ADSL"))), + gt_group = structure("NESTED_FREQ_ABC of EOSSTT and DCSREAS", class = c("glue", "character")), + label = "End of Study Status", + label_source = "SAS \"label\" attribute"), + row.names = c(NA, -1L), class = c("tbl_df", "tbl", "data.frame")) + expect_equal(bd$blocks, block_table) + + setTitle(bd, "My Title") + expect_equal(bd$title, "My Title") + + setGroup(bd, "TRT01P") + expect_equal(bd$group_by, "TRT01P") + +}) + +test_that("User input is working", { + con <- file() + options(tidyCDISC.connection = con) + + datalist <- list(ADSL = tidyCDISC::adsl, ADAE = tidyCDISC::adae) + + bd <- createBlockdata(datalist) + + user_input <- c("AGEGR1", "FREQ") + write(paste(user_input, collapse = "\n"), con) + addBlock(bd) + expect_equal(nrow(bd$blocks), 1) + + user_input <- c("AGE", "MEN") + write(paste(user_input, collapse = "\n"), con) + expect_error(addBlock(bd)) + expect_equal(nrow(bd$blocks), 1) + + user_input <- c("AGE", "MEN", "MEAN") + write(paste(user_input, collapse = "\n"), con) + addBlock(bd) + expect_equal(nrow(bd$blocks), 2) + + options(tidyCDISC.connection = stdin()) + close(con) +}) diff --git a/tests/testthat/test-tableGen_fct_methods.R b/tests/testthat/test-tableGen_fct_methods.R index 0634e3fa..09a29c5d 100644 --- a/tests/testthat/test-tableGen_fct_methods.R +++ b/tests/testthat/test-tableGen_fct_methods.R @@ -9,8 +9,8 @@ test_that("create custom class based on dataframe", { }) test_that("convertTGOutput creates a dataframe row from input blocks", { - output <- convertTGOutput(agg, block) - + output <- do.call(convertTGOutput, process_droppables(agg, block)) + expect_equal(output$agg, "MEAN") expect_equal(output$block, "AGE") expect_equal(output$dataset, "ADSL") @@ -19,6 +19,6 @@ test_that("convertTGOutput creates a dataframe row from input blocks", { }) test_that("combining all idea functions as app_methods", { - output <- convertTGOutput(agg, block) + output <- do.call(convertTGOutput, process_droppables(agg, block)) app_methods(output$agg, output$S3[[1]], output$dropdown, NULL, tg_data) }) diff --git a/vignettes/dev04_RECIPES.Rmd b/vignettes/dev04_RECIPES.Rmd new file mode 100644 index 00000000..3287b6a9 --- /dev/null +++ b/vignettes/dev04_RECIPES.Rmd @@ -0,0 +1,212 @@ +--- +title: "'Standard Analysis' Table RECIPE Processing" +output: rmarkdown::html_vignette +vignette: > + %\VignetteIndexEntry{'Standard Analysis' Table RECIPE Processing} + %\VignetteEngine{knitr::rmarkdown} + %\VignetteEncoding{UTF-8} +--- + +```{r, include = FALSE} +knitr::opts_chunk$set( + collapse = TRUE, + comment = "#>" +) +``` + +Learn how RECIPES metadata, used to populate the "standard analysis" dropdown list, are parsed by the application so that you can write your own custom tables. + + + +## The structure of `recipes.json` + +This tutorial will walk you through the structural components of the `recipes.json` file. + +### The table object + +Within the `recipes.json` file you'll find a list of table objects. Below is the standard table #3 object. + +```{r, eval=FALSE} +"stan_3": { + "title": "Table 3: Accounting of Subjects", + "group_by": "TRT01P", + "blocks": [{"data":"ADSL", "variable":"RANDFL", "statistic":"Y_FREQ"}, + {"data":"ADSL", "variable":"SAFFL", "statistic":"FREQ"}, + {"data":"ADSL", "variable":"EOTSTT", "statistic":"NESTED_FREQ_ABC", "stat_selection":"DCTREAS"}, + {"data":"ADSL", "variable":"EOSSTT", "statistic":"NESTED_FREQ_ABC", "stat_selection":"DCSREAS"}] +} +``` + +The **naming** of the table object ("stan_3") is important! When pulling this data into the application, S3 objects are heavily utilized. In this example, the table object will be given the class `stan_3`. The application will then use this information to correctly process the data for the creation of the table. + +The table object can contain a number of sub-objects. In the example, there are three such objects with the following key names: + +* `title`: the text to be used as the title in the table generation +* `group_by`: the name of the field that should be used for grouping +* `blocks`: an array containing table processing information. More details are provided below! + +#### The `blocks` object + +The `blocks` object is actually an array of `block` objects. The setup may feel familiar given it mimics the drag-and-drop blocks used within the Table Generator's interface. That is, each `block` is a named list that can contain important elements required to build a table. In our example: `data`, `variable`, and `statistic` are foundational. + +* The `data` element denotes which data set is being used to provide the variable referenced in the `variable` element. +* The `variable` element denotes the field or parameter from the `data` data set to analyze with a statistical computation. +* The `statistic` element denotes which statistical procedure to perform on said field/parameter. + +A few other elements can also be present within a `block` object, such as: `var_selection`, `var_options`, `var_options_fn` and their statistic counterparts `stat_selection`, `stat_options`, and `stat_options_fn`. A `var_selection` element can be used in conjunction with `var_options` to create a subgroup filter for the variable. A `stat_selection` element is only required when the `statistic` element requires it. As seen in the example above, the "NESTED_FREQ_ABC" `statistic` needs to know a secondary variable by which to produce its "nested" output. Besides those mentioned, no other elements are used in the `recipes.json` file or within the application's code base, but active development will be changing this soon. + +## Parsing `recipes.json` + +### The table object + +As stated previously, the **name** of the table object is assigned as an S3 class in the app's codebase. This class is used to manage how population filters are applied, if necessary, in the functions `filter_adsl()` and `filter_adae()`. Thus, when engineering a new standard analysis in `recipes.json`, then a new S3 class must also be created if population filters are desired. For example, for a hypothetical table with key **name** `tbl_01`, you must also define methods for `filter_adsl.tbl_01()` and `filter_adae.tbl_01()`. + +```{r, eval=FALSE} +# For example a Safety Population filter +filter_adsl.tbl_01 <- function(recipe, ADSL) { + dat <- ADSL + msg <- "" + if("SAFFL" %in% colnames(dat)) { + dat <- dat %>% filter(SAFFL == 'Y') + msg <- "Population Set: SAFFL = 'Y'" + } else { + msg <- "Variable 'SAFFL' doesn't exist in ADSL. STAN table not displayed because filter \"SAFFL == 'Y'\" cannot be applied!" + stop(msg) + } + list(data = dat, message = msg) +} +``` + +The **name** of the table along with the `title` element will be used to generate the recipe dropdown in the Table Generator's user interface. + +### The `blocks` object + +There is one additional sub-object not yet mentioned, the `recipe_inclusion` object, which can assign a class to the `blocks` object. The standard inclusion criteria is for all data sets in a `blocks` object to be present in the list of data sets uploaded and for all variables listed in the `block` objects to be present in the data set identified with them. Assigning a value to `recipe_inclusion` can affect the rules for inclusion in the recipes select input HTML element. If a user had a special set of criteria, they could assign `crit_01` to `recipe_inclusion` and assign the function `recipe_inclusion.crit_01()` to determine the criteria. + +```{r, eval=FALSE} +# The default +recipe_inclusion.default <- function(blocks, datalist, ...) { + # Checks that all data sets are present in the uploaded data list + data_incl <- purrr::map_lgl(blocks, ~ .x$data %in% names(datalist)) + if (!all(data_incl)) + return(rep(FALSE, length(blocks))) + + # Checks that all variables are present in the associated data set + param_col_incl <- purrr::map_lgl(blocks, ~ .x$variable %in% datalist[[.x$data]][["PARAMCD"]] || .x$variable %in% names(datalist[[.x$data]])) + if (!all(param_col_incl)) + return(rep(FALSE, length(blocks))) + + # Note that a vector the same length of blocks is returned + # This is an all or nothing check. Every `block` must be present for inclusion. + param_col_incl +} + +# Standard lab tables +recipe_inclusion.stan_labs <- function(blocks, datalist, ...) { + # Checks that at least one data set with naming convention "ADLBXX" is present in the uploaded data list + data_incl <- purrr::map_lgl(blocks, ~ "ADLB" %in% substr(names(datalist), 1, 4)) + if (!all(data_incl)) + return(rep(FALSE, length(blocks))) + + # Checks that the variables are located in "PARAMCD" + param_incl <- purrr::map_lgl(blocks, ~ .x$variable %in% unlist(purrr::map(datalist["ADLB" == substr(names(datalist), 1, 4)], ~ unique(.x[["PARAMCD"]])), use.names = FALSE)) + + # Note that this vector need not be all TRUE or FALSE like the default. + # If at least one variable returns TRUE, the table will appear in the dropdown. + # However, only the `block`'s that return TRUE will be passed to the table generator. + param_incl +} +``` + +### The `block` object + +Up to two classes can be assigned to the `block` object via the elements `var_options_fn` and `stat_options_fn`. If you recall, when the `MEAN` statistic is selected in the app, a dropdown list is displayed containing different `AVISIT` values. Thus, if the user wants a block to output multiple weeks, they can provide a class for `stat_options_fn`. For example, with a value of `opt_01` you would create the function `stat_options.opt_01()`. The user could also opt to hard code these values using the element `stat_options`. + +```{r, eval=FALSE} +# Example for `avisit` class +stat_options.avisit <- function(block, datalist, ...) { + # This grabs all scheduled `AVISIT`s ordered by `AVISITN` + avisits <- + datalist[[block$data]] %>% + dplyr::filter(stringr::str_detect(toupper(AVISIT), "UNSCHEDULED", negate = TRUE)) %>% + dplyr::distinct(AVISIT, AVISITN) %>% + varN_fctr_reorder() %>% + dplyr::pull(AVISIT) %>% + get_levels() %>% + as.list() + + # This assigns those values to `stat_options` in the codebase + block$stat_options <- avisits + + block +} + +# Alternatively, if we have AVISITS we know we want +# In the JSON file {..."stat_options":["BASELINE", "WEEK 2", "WEEK 4"]...} +``` + +Similarly, the element `stat_selection` is used to determine the input for a statistic with a drop down. Paired with `stat_options_fn`, these two elements together can allow the user to create multiple generated blocks with only one `block` object. For example, the standard lab tables have `stat_selection = "ALL"` and `stat_options_fn = avisit_lab`. This will generate a block for each week. + +The `var_selection` and `var_options` combination is processed in a slightly different way. The application tries to create a filter. In order to accomplish this, the field must also be included as a group. For instance, one could have the following variable options: `"var_options": {"ATPT": ["AFTER LYING DOWN FOR 5 MINUTES", "AFTER STANDING FOR 1 MINUTE", "AFTER STANDING FOR 3 MINUTES"]`. The variable selection of `"var_selection":"AFTER STANDING FOR 3 MINUTES"` would result in creating the filter `ATPT == "AFTER STANDING FOR 3 MINUTES"`. There are two exceptions: (1) `"var_selection":"ALL"` will make multiple blocks, one for each options and (2) `"var_selection":"N/A"` will create the filter `is.na(ATPT)` if "N/A" was included as one of the options. Note that if using `var_options_fn`, a named list must be output. + +## `ATPT` Example + +### The JSON file + +This JSON object when included in `recipes.json` will create a table for mean Diastolic Blood Pressure at all Time Points and all Visits: +```{r, eval=FALSE} +"tbl_1": { + "title": "Custom Table 1: Diastolic Blood Pressure by Visit", + "blocks": [{ + "data":"ADVS", + "variable":"DIABP", + "var_options_fn":"atpt", + "var_selection":"ALL", + "statistic":"MEAN", + "stat_options_fn":"avisit", + "stat_selection":"ALL"}] +} +``` + +### The S3 Methods + +Here are the functions to create the variable options and the statistic options (note that these functions are already included in the package): +```{r, eval=FALSE} +# Example for `atpt` class +var_options.atpt <- function(block, datalist, ...) { + atpts <- + datalist[[block$data]] %>% + dplyr::filter(PARAMCD == block$variable) %>% + dplyr::distinct(ATPT, ATPTN) %>% + varN_fctr_reorder() %>% + dplyr::pull(ATPT) %>% + get_levels() %>% + {list(ATPT = as.list(.))} # Note that this is a named list + + block$var_options <- atpts + + block +} + +# Example for `avist` class +stat_options.avisit <- function(block, datalist, ...) { + avisits <- + datalist[[block$data]] %>% + dplyr::filter(stringr::str_detect(toupper(AVISIT), "UNSCHEDULED", negate = TRUE), + AVISIT != "") %>% + dplyr::distinct(AVISIT, AVISITN) %>% + varN_fctr_reorder() %>% + dplyr::pull(AVISIT) %>% + get_levels() %>% + as.list() + + block$stat_options <- avisits + + block +} +``` + +### The Table Output +```{r, echo=FALSE} +htmltools::includeHTML("figures/recipes/ATPT_tbl.html") +``` \ No newline at end of file diff --git a/vignettes/figures/recipes/.gitignore b/vignettes/figures/recipes/.gitignore new file mode 100644 index 00000000..7e0caf8f --- /dev/null +++ b/vignettes/figures/recipes/.gitignore @@ -0,0 +1 @@ +!*.html diff --git a/vignettes/figures/recipes/ATPT_tbl.html b/vignettes/figures/recipes/ATPT_tbl.html new file mode 100644 index 00000000..4f404bb4 --- /dev/null +++ b/vignettes/figures/recipes/ATPT_tbl.html @@ -0,0 +1,952 @@ + + + + + + + + + +
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
Custom Table 1: Diastolic Blood Pressure by Visit
Filters Applied:

Total
N=254
Descriptive Statistics of DIABP at Baseline/ AFTER LYING DOWN FOR 5 MINUTES
n253
Mean (SD)76.4 (10.22)
Median76.0
Q1 | Q370.0 | 84.0
Min | Max40 | 100
Descriptive Statistics of DIABP at Baseline/ AFTER STANDING FOR 1 MINUTE
n253
Mean (SD)77.4 (10.51)
Median78.0
Q1 | Q370.0 | 84.0
Min | Max51 | 108
Descriptive Statistics of DIABP at Baseline/ AFTER STANDING FOR 3 MINUTES
n253
Mean (SD)77.9 (10.74)
Median78.0
Q1 | Q370.0 | 84.0
Min | Max46 | 110
Descriptive Statistics of DIABP at Week 2/ AFTER LYING DOWN FOR 5 MINUTES
n250
Mean (SD)75.1 (9.75)
Median74.0
Q1 | Q370.0 | 82.0
Min | Max45 | 100
Descriptive Statistics of DIABP at Week 2/ AFTER STANDING FOR 1 MINUTE
n249
Mean (SD)75.8 (10.85)
Median75.0
Q1 | Q370.0 | 82.0
Min | Max43 | 112
Descriptive Statistics of DIABP at Week 2/ AFTER STANDING FOR 3 MINUTES
n248
Mean (SD)76.1 (10.56)
Median76.0
Q1 | Q370.0 | 82.0
Min | Max45 | 118
Descriptive Statistics of DIABP at Week 4/ AFTER LYING DOWN FOR 5 MINUTES
n227
Mean (SD)75.5 (9.72)
Median76.0
Q1 | Q370.0 | 82.0
Min | Max41 | 100
Descriptive Statistics of DIABP at Week 4/ AFTER STANDING FOR 1 MINUTE
n227
Mean (SD)76.0 (10.60)
Median78.0
Q1 | Q370.0 | 82.0
Min | Max39 | 98
Descriptive Statistics of DIABP at Week 4/ AFTER STANDING FOR 3 MINUTES
n227
Mean (SD)76.6 (10.37)
Median76.0
Q1 | Q370.0 | 84.0
Min | Max46 | 102
Descriptive Statistics of DIABP at Week 6/ AFTER LYING DOWN FOR 5 MINUTES
n208
Mean (SD)74.5 (10.27)
Median76.0
Q1 | Q369.0 | 80.0
Min | Max48 | 100
Descriptive Statistics of DIABP at Week 6/ AFTER STANDING FOR 1 MINUTE
n209
Mean (SD)74.9 (9.82)
Median75.0
Q1 | Q370.0 | 80.0
Min | Max49 | 110
Descriptive Statistics of DIABP at Week 6/ AFTER STANDING FOR 3 MINUTES
n209
Mean (SD)75.2 (9.27)
Median76.0
Q1 | Q370.0 | 80.0
Min | Max49 | 100
Descriptive Statistics of DIABP at Week 8/ AFTER LYING DOWN FOR 5 MINUTES
n189
Mean (SD)75.5 (9.10)
Median76.0
Q1 | Q370.0 | 80.0
Min | Max49 | 98
Descriptive Statistics of DIABP at Week 8/ AFTER STANDING FOR 1 MINUTE
n189
Mean (SD)76.1 (10.44)
Median76.0
Q1 | Q370.0 | 84.0
Min | Max50 | 101
Descriptive Statistics of DIABP at Week 8/ AFTER STANDING FOR 3 MINUTES
n189
Mean (SD)76.2 (9.86)
Median78.0
Q1 | Q370.0 | 82.0
Min | Max56 | 101
Descriptive Statistics of DIABP at Week 12/ AFTER LYING DOWN FOR 5 MINUTES
n171
Mean (SD)73.9 (10.05)
Median74.0
Q1 | Q368.0 | 80.0
Min | Max50 | 100
Descriptive Statistics of DIABP at Week 12/ AFTER STANDING FOR 1 MINUTE
n171
Mean (SD)74.7 (10.56)
Median74.0
Q1 | Q368.0 | 82.0
Min | Max49 | 100
Descriptive Statistics of DIABP at Week 12/ AFTER STANDING FOR 3 MINUTES
n171
Mean (SD)75.9 (10.60)
Median76.0
Q1 | Q368.0 | 84.0
Min | Max50 | 104
Descriptive Statistics of DIABP at Week 16/ AFTER LYING DOWN FOR 5 MINUTES
n147
Mean (SD)74.5 (10.03)
Median75.0
Q1 | Q368.0 | 82.0
Min | Max50 | 98
Descriptive Statistics of DIABP at Week 16/ AFTER STANDING FOR 1 MINUTE
n147
Mean (SD)75.7 (10.49)
Median76.0
Q1 | Q370.0 | 82.0
Min | Max49 | 98
Descriptive Statistics of DIABP at Week 16/ AFTER STANDING FOR 3 MINUTES
n147
Mean (SD)75.9 (10.51)
Median76.0
Q1 | Q370.0 | 84.0
Min | Max49 | 98
Descriptive Statistics of DIABP at Week 20/ AFTER LYING DOWN FOR 5 MINUTES
n128
Mean (SD)73.0 (9.55)
Median72.0
Q1 | Q368.0 | 80.0
Min | Max54 | 100
Descriptive Statistics of DIABP at Week 20/ AFTER STANDING FOR 1 MINUTE
n128
Mean (SD)73.4 (11.00)
Median72.0
Q1 | Q366.0 | 80.0
Min | Max48 | 100
Descriptive Statistics of DIABP at Week 20/ AFTER STANDING FOR 3 MINUTES
n128
Mean (SD)74.4 (10.35)
Median74.0
Q1 | Q368.0 | 80.0
Min | Max49 | 98
Descriptive Statistics of DIABP at Week 24/ AFTER LYING DOWN FOR 5 MINUTES
n116
Mean (SD)73.9 (10.33)
Median75.0
Q1 | Q368.0 | 80.0
Min | Max44 | 109
Descriptive Statistics of DIABP at Week 24/ AFTER STANDING FOR 1 MINUTE
n116
Mean (SD)74.9 (11.79)
Median76.0
Q1 | Q365.0 | 80.0
Min | Max45 | 117
Descriptive Statistics of DIABP at Week 24/ AFTER STANDING FOR 3 MINUTES
n116
Mean (SD)75.2 (10.87)
Median75.0
Q1 | Q368.0 | 82.0
Min | Max50 | 110
Descriptive Statistics of DIABP at Week 26/ AFTER LYING DOWN FOR 5 MINUTES
n111
Mean (SD)72.5 (9.76)
Median71.0
Q1 | Q367.0 | 80.0
Min | Max46 | 93
Descriptive Statistics of DIABP at Week 26/ AFTER STANDING FOR 1 MINUTE
n111
Mean (SD)74.0 (11.44)
Median74.0
Q1 | Q368.0 | 80.0
Min | Max39 | 98
Descriptive Statistics of DIABP at Week 26/ AFTER STANDING FOR 3 MINUTES
n111
Mean (SD)73.2 (10.60)
Median72.0
Q1 | Q366.0 | 80.0
Min | Max49 | 98
Descriptive Statistics of DIABP at End of Treatment/ AFTER LYING DOWN FOR 5 MINUTES
n227
Mean (SD)73.7 (9.47)
Median72.0
Q1 | Q368.0 | 80.0
Min | Max46 | 100
Descriptive Statistics of DIABP at End of Treatment/ AFTER STANDING FOR 1 MINUTE
n227
Mean (SD)74.8 (10.65)
Median74.0
Q1 | Q368.0 | 81.0
Min | Max39 | 100
Descriptive Statistics of DIABP at End of Treatment/ AFTER STANDING FOR 3 MINUTES
n227
Mean (SD)74.5 (10.61)
Median76.0
Q1 | Q368.0 | 81.0
Min | Max49 | 102
+ Source: tidyCDISC app + Run Date: 19APR2023 +
+
+ +