diff --git a/metalite_table1.R b/metalite_table1.R new file mode 100644 index 0000000..381be33 --- /dev/null +++ b/metalite_table1.R @@ -0,0 +1,166 @@ +#' Interactive Table of Descriptive Statistics in HTML +#' +#' @param formula an object of class "formula". +#' @param data a data frame that contain variables described in the `formula`. +#' @param id a character value to indicate subject/record id variable name in `data`. +#' @param var_listing a character vector of additional variables included in the drill down listing. +#' @param total a logical value to display or hide "Total" column. +#' @param header a logical vector with length 1 or same length of the variables in `formula` to show the `Number of xxx` row of each variable. +#' Default is to show the row for the first variable. +#' @param download a character value to enable download button. Allowed values include +#' "none", "listing", "table", and 'all'. +#' @param record_name a character value to control section title (e.g. "Subjects", "Records"). +#' @param ... additional arguments passed to `reactable`. More details refer \url{https://glin.github.io/reactable/reference/reactable.html} +#' +#' @return a `shiny.tag.list` object that contain a `reactable` HTML widget for +#' interactive table of describptive statistics. +#' +#' @examples +#' if (interactive()) { +#' metalite_table1(~ AGE + SEX | TRT01A, data = r2rtf::r2rtf_adsl, id = "SUBJID") +#' } +#' +#' @export +metalite_table1 <- function(formula, + data, + id = NULL, + var_listing = NULL, + total = TRUE, + header = NULL, + download = "none", + record_name = NULL, + ...) { + if (nrow(data) == 0) { + stop("There is no records in the input dataset") + } + + if(is.null(id)){ + data$.id <- 1:nrow(data) + id = ".id" + show_listing <- FALSE + }else{ + show_listing <- TRUE + } + + if (formula[[2]][[1]] == "|") { + var <- all.vars(formula[[2]][[2]]) + group <- all.vars(formula[[2]][[3]]) + if(length(group) > 1){ + stop("Only one group variable is supported") + } + } else { + var <- all.vars(formula[[2]]) + data$group <- "All" + attr(data, "group") <- "All" + group <- "group" + } + + if(! length(header) %in% c(0, 1, length(var))){ + stop("The length of `header` should be either 1 or the same number of variables") + } + + data[[group]] <- factor(data[[group]]) + + if (missing_group == "ignore") { data <- data[!is.na(data[[group]]), ] message("Ignore missing values in the group variable.") } else if (missing_group == "count") { data[[group]] <- addNA(data[[group]], ifany = TRUE) levels(data[[group]]) <- c(levels(data[[group]]), "Missing") } else if (missing_group == "display") { data[[group]] <- addNA(data[[group]], ifany = TRUE) levels(data[[group]]) <- c(levels(data[[group]]), "Missing") } else { stop("Invalid value for 'missing_group'.") } + + var_label <- metalite::get_label(data)[var] + + plan <- metalite::plan( + analysis = "metalite.table1:::interactive_table1", + population = "all", + observation = "inf", + total = total, + parameter = var, + ... + ) + + if(is.null(header)){ + plan$column_header <- FALSE + plan$column_header[1] <- TRUE + }else{ + plan$column_header <- header + } + + plan$keep_total <- plan$column_header + + meta <- metalite::meta_adam(observation = data) + + meta <- metalite::define_plan(meta, plan = plan) + + meta <- metalite::define_population(meta, + id = id, + name = "all", + group = group, + subset = NULL, + label = "All Subjects", + var = var + ) + + meta <- metalite::define_observation(meta, + id = id, + name = "inf", + subset = NULL, + label = "All observations" + ) + + for (i in seq(var)) { + meta <- metalite::define_parameter(meta, + name = var[i], + var = var[i], + label = var_label[i], + subset = NULL + ) + } + + meta <- metalite::define_analysis(meta, + name = "metalite.table1:::interactive_table1", + label = "Interactive Table 1" + ) + + meta <- metalite::meta_build(meta) + + htmltools::browsable( + htmltools::tagList(metalite::meta_run( + meta, + show_listing = show_listing, + var_listing = var_listing, + download = download, + type = record_name + )) + ) +} + +#' Convert to html +#' +#' @param x an output from `metalite_table1`. +#' +#' @return HTML string of `reactable` HTML widget for +#' interactive table of describptive statistics. +#' +#' @export +metalite_table1_to_html <- function(x) { + attributes(x)$browsable_html <- NULL + print(x) +} + + +#' Convert to data frame +#' +#' @param x an output from `metalite_table1`. +#' +#' @return a data frame that contain the table from the html output and +#' a `.id` variable for variables. +#' +#' @export +#' +metalite_table1_to_df <- function(x) { + + out <- lapply(x[[1]], function(.x){ + tbl <- reactable_to_df(.x) + tbl$.id <- tbl[is.na(tbl[, 2]), "name_display"] + tbl + }) + names(out) <- NULL + do.call(rbind, out) + +}