Add files via upload

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)
+
+}