Merge pull request #24 from Merck/baseline-characteristic-table-by-su…

…bgroup

metalite.sl: baseline characteristic table by subgroup

NAMESPACE

@@ -3,15 +3,18 @@
 export(collect_baseline)
 export(defmt_pct)
 export(format_base_char)
+export(format_base_char_subgroup)
 export(format_disposition)
 export(format_trt_compliance)
 export(meta_sl)
 export(meta_sl_example)
 export(prepare_base_char)
+export(prepare_base_char_subgroup)
 export(prepare_disposition)
 export(prepare_sl_summary)
 export(prepare_trt_compliance)
 export(react_base_char)
 export(rtf_base_char)
+export(rtf_base_char_subgroup)
 export(rtf_disposition)
 export(rtf_trt_compliance)

R/format_base_char_subgroup.R

@@ -0,0 +1,98 @@
+# Copyright (c) 2024 Merck & Co., Inc., Rahway, NJ, USA and its affiliates.
+# All rights reserved.
+#
+# This file is part of the metalite.sl program.
+#
+# metalite.sl is free software: you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation, either version 3 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+#' Prepare data for Subgroup Analysis for Baseline Characteristic
+#'
+#' @param outdata A metadata object created by [prepare_base_char_subgroup()]. 
+#' @param display Column wants to display on the table.
+#'   The term could be selected from `c("n", "prop", "total")`.
+#' @param display_stat A vector of statistics term name.
+#'   The term name could be selected from
+#'   `c("mean", "sd", "se", "median", "q1 to q3", "range", "q1", "q3", "min", "max")`.
+#'
+#' @return A list of analysis raw datasets.
+#' @export
+#'
+#' @examples
+#' meta <- meta_sl_example()
+#' 
+#' outdata <- prepare_base_char_subgroup(
+#'           meta,
+#'           population = "apat",
+#'           parameter = "age",
+#'           subgroup_var = "TRTA",
+#'           subgroup_header = c("SEX","TRTA"),
+#'           display_subgroup_total = TRUE
+#' )
+#' 
+#' outdata |> format_base_char_subgroup()
+
+format_base_char_subgroup <- function(
+    outdata,
+    display = c("n","prop","total"),
+    display_stat = c("mean", "sd", "median", "range")) {
+
+  out_all <- outdata$out_all
+
+  outlst <- list()
+  for (i in seq_along(out_all)) {
+    tbl <- out_all[[i]] |>
+      format_base_char(
+        display_col = display,
+        digits_prop = 1,
+        display_stat = display_stat
+      )
+
+    #names(tbl$tbl)[-1] <- paste0(names(out_all[i]), names(tbl$tbl)[-1])
+    names(tbl$tbl)[-1] <- ifelse(grepl("_label",names(tbl$tbl)[-1]) %in% "FALSE", paste0(names(out_all[i]), names(tbl$tbl)[-1]),names(tbl$tbl)[-1])
+
+    tbl$tbl$order <- as.numeric(rownames(tbl$tbl))
+
+    outlst[[i]] <- tbl$tbl
+  }
+
+  names(outlst) <- names(out_all)
+  outlst <- outlst[-length(outlst)]
+
+  i <- 1
+  while (i < length(outlst)) {
+    if (i == 1) {
+      tbl <- merge(outlst[[i]], outlst[[i + 1]], by = c("name","var_label","order"), all = TRUE)
+    }
+
+    i <- i + 1
+
+    if (i > 1 && i < length(outlst)) {
+      tbl <- merge(tbl, outlst[[i + 1]], by = c("name","var_label","order"), all = TRUE)
+    }
+  }
+
+
+  # If outdata$display_subgroup_total = FALSE, remove that part
+  #if (!outdata$display_subgroup_total) {
+  #  rm_tot <- names(outlst$Total) # Columns from Total Section
+  #  rm_tot <- rm_tot[!rm_tot %in% c("name", "order")]
+
+  #  tbl <- tbl[, -which(names(tbl) %in% rm_tot)]
+  #}
+
+  outdata$tbl <- tbl |> dplyr::arrange(order)
+  outdata$display <- display
+  outdata$display_stat <- display_stat
+  outdata
+}

R/meta_sl_example.R

@@ -34,6 +34,10 @@ meta_sl_example <- function() {
     levels = c("Placebo", "Xanomeline Low Dose", "Xanomeline High Dose"),
     labels = c("Placebo", "Low Dose", "High Dose")
   )
+  adsl$SEX <- factor(adsl$SEX,
+                      levels = c("F", "M"),
+                      labels = c("Female", "Male")
+  )
 
   # Create a variable EOSSTT indicating the end of end of study status
   adsl$EOSSTT <- sample(x = c("Participants Ongoing", "Discontinued"),
@@ -61,6 +65,10 @@ meta_sl_example <- function() {
     metalite::add_plan(
       analysis = "disp", population = "apat",
       observation = "apat", parameter = "disposition;medical-disposition"    
+    )  |>
+    metalite::add_plan(
+      analysis = "base_char_subgroup", population = "apat",
+      observation = "apat", parameter = "age"
     )
 
   meta <- metalite::meta_adam(
@@ -131,6 +139,11 @@ meta_sl_example <- function() {
       title = "Disposition of Participant",
       label = "disposition table"
     ) |>
+    metalite::define_analysis(
+      name = "base_char_subgroup",
+      title = "Participant by Age Category and Sex",
+      label = "baseline characteristic sub group table"
+    ) |>
     metalite::meta_build()
 }
 

R/prepare_base_char_subgroup.R

@@ -0,0 +1,123 @@
+# Copyright (c) 2024 Merck & Co., Inc., Rahway, NJ, USA and its affiliates.
+# All rights reserved.
+#
+# This file is part of the metalite.sl program.
+#
+# metalite.sl is free software: you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation, either version 3 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+#' Prepare data for treatment compliance table
+#'
+#' @param meta A metadata object created by metalite.
+#' @param population A character value of population term name.
+#'   The term name is used as key to link information.
+#' @param analysis  A character value of analysis term name.
+#'   The term name is used as key to link information.
+#' @param parameter A character value of parameter term name.
+#'   The term name is used as key to link information.
+#' @param subgroup_var A character value of subgroup variable name in
+#'   observation data saved in `meta$data_observation`.
+#' @param subgroup_header A character vector for column header hierarchy.
+#'   The first element will be the first level header and the second element
+#'   will be second level header.
+#' @param display_subgroup_total A logic value of displaying the total group.
+#'
+#' @return A list of analysis raw datasets.
+#' @export
+#'
+#' @examples
+#' meta <- meta_sl_example()
+#' outdata <- prepare_base_char_subgroup(
+#'           meta,
+#'           population = "apat",
+#'           parameter = "age",
+#'           subgroup_var = "TRTA",
+#'           subgroup_header = c("SEX","TRTA"),
+#'           display_subgroup_total = TRUE)
+
+
+prepare_base_char_subgroup <- function(
+    meta,
+    population,
+    analysis = "base_char_subgroup",
+    parameter,
+    subgroup_var,
+    subgroup_header = c(meta$population[[population]]$group, subgroup_var),
+    display_subgroup_total = TRUE) {
+
+  meta_original <- meta
+
+  observation <- meta$plan[meta$plan$analysis==analysis,]$observation
+
+  #Factor Level 1 Subgroup
+  meta$data_population[[subgroup_header[1]]] <- factor(
+    as.character(meta$data_population[[subgroup_header[1]]]),
+    levels = sort(unique(meta$data_population[[subgroup_header[1]]]))
+  )
+  meta$data_observation[[subgroup_header[1]]] <- factor(
+    as.character(meta$data_observation[[subgroup_header[1]]]),
+    levels = sort(unique(meta$data_observation[[subgroup_header[1]]]))
+  )
+
+  #Factor Level 2 Subgroup
+  meta$data_population[[subgroup_var]] <- factor(
+    as.character(meta$data_population[[subgroup_var]]),
+    levels = sort(unique(meta$data_population[[subgroup_var]]))
+  )
+  meta$data_observation[[subgroup_var]] <- factor(
+    as.character(meta$data_observation[[subgroup_var]]),
+    levels = sort(unique(meta$data_observation[[subgroup_var]]))
+  )
+
+  meta$observation[[observation]]$group <- subgroup_header[1]
+  meta$population[[population]]$group <- subgroup_header[1]
+
+  # Obtain variables
+  par_var <- metalite::collect_adam_mapping(meta, parameter)$var
+
+  meta_subgroup <- metalite::meta_split(meta, subgroup_header[2])
+
+  outdata_all <- prepare_sl_summary(
+    meta,
+    analysis = analysis,
+    population = meta$plan[meta$plan$analysis==analysis,]$population,
+    parameter = parameter
+  )
+
+  outdata_subgroup <- lapply(
+    meta_subgroup,
+    prepare_sl_summary,
+    analysis = analysis,
+    population = meta$plan[meta$plan$analysis==analysis,]$population,
+    parameter = parameter
+  )
+
+  out_all <- outdata_subgroup
+  out_all$Total <- outdata_all
+
+  group <- as.character(outdata_subgroup[[1]]$group_label)
+  group <- group[!group %in% "Total"]
+
+  outdata <- list(
+    group = group,
+    subgroup = tools::toTitleCase(tolower(names(outdata_subgroup))),
+    display_subgroup_total = display_subgroup_total,
+    meta = meta_original,
+    population = population,
+    observation = observation,
+    parameter = parameter,
+    out_all = out_all
+  )
+
+}
+