Merge pull request #161 from Merck/extend-subgroup

Extend subgroup #160

R/extend_ae_specific.R

@@ -88,7 +88,7 @@ extend_ae_specific_inference <- function(outdata, ci = 0.95) {
   res$ci_upper <- ci_upper
   res$ci_level <- ci
   res$p <- p
-
+  res$extend_call <- c(res$call, match.call())
   res
 }
 
@@ -219,6 +219,7 @@ extend_ae_specific_duration <- function(outdata,
 
   outdata$dur <- avg
   outdata$dur_se <- se
+  outdata$extend_call <- c(outdata$extend_call, match.call())
 
   outdata
 }
@@ -333,6 +334,18 @@ extend_ae_specific_events <- function(outdata) {
 
   outdata$events <- avg
   outdata$events_se <- se
+  outdata$extend_call <- c(outdata$extend_call, match.call())
+
+  outdata
+}
+
+#' Add Subgroup analysis in AE specific analysis
+#'
+#' @param subgroup a character string for subgroup variable name
+#'
+#' @export
+extend_ae_specific_subgroup <- function(outdata, subgroup) {
+  outdata$subgroup <- subgroup
 
   outdata
 }

R/format_ae_specific.R

@@ -228,5 +228,7 @@ format_ae_specific <- function(outdata,
   }
 
   outdata$tbl <- res
+  outdata$extend_call <- c(outdata$extend_call, match.call())
+
   outdata
 }

R/outdata.R

@@ -0,0 +1,78 @@
+#' Evaluate a call using outdata
+#'
+#' @param outdata a outdata object.
+#' @param call a function call that require `outdata` object as an input.
+#'
+#' @noRd
+outdata_eval_extend_call <- function(outdata, call) {
+  call$outdata <- str2lang("outdata")
+  eval(call)
+}
+
+#' Evaluate a call using outdata
+#'
+#' @param outdata a outdata object.
+#' @param call a function call that require `outdata` object as an input.
+#'
+#' @noRd
+outdata_eval_prepare_call <- function(outdata) {
+  call <- outdata$prepare_call
+  call$meta <- str2lang("outdata$meta")
+
+  population <- names(outdata$meta$population)
+
+  res <- list()
+  for (i in seq_along(population)) {
+    call$population <- population[i]
+
+    outdata_subgroup <- eval(call)
+
+    extend_call <- outdata$extend_call
+    for (j in seq_along(extend_call)) {
+      outdata_subgroup <- outdata_eval_extend_call(outdata_subgroup, extend_call[[j]])
+    }
+
+    res[[i]] <- outdata_subgroup
+  }
+
+  res
+}
+
+#' Update outdata subgroup population
+#'
+#' @inheritParams extend_ae_specific_subgroup
+#'
+#' @noRd
+outdata_population_subgroup <- function(
+    outdata,
+    subgroup) {
+  meta <- outdata$meta
+
+  # define subgroup
+  subgroup <- outdata$subgroup
+  u_subgroup <- unique(meta$data_population[[subgroup]])
+
+  pop_name <- names(meta$population)
+  pop_subset <- unlist(lapply(pop_name, function(x) deparse(meta$population[[x]]$subset)))
+  pop_subset <- ifelse(nchar(trimws(pop_subset)) == 0, "TRUE", pop_subset)
+
+  subgroup_subset <- paste0(subgroup, '== "', u_subgroup, '"')
+
+
+  new_subset <- outer(pop_subset, subgroup_subset, paste, sep = " & ")
+  new_name <- outer(pop_name, u_subgroup, paste, sep = "-")
+
+  for (i in 1:nrow(new_name)) {
+    for (j in 1:ncol(new_name)) {
+      x <- meta$population[[pop_name[i]]]
+      x$name <- new_name[i, j]
+      x$subset <- str2lang(new_subset[i, j])
+      meta$population[[new_name[i, j]]] <- x
+    }
+  }
+
+  meta$population <- meta$population[as.vector(new_name)]
+  outdata$meta <- meta
+
+  outdata
+}

R/prepare_ae_listing.R

@@ -65,6 +65,7 @@ prepare_ae_listing <- function(meta,
   # Return value
   outdata(meta, population, observation, parameter,
     n = NULL, order = NULL, group = NULL, reference_group = NULL,
-    col_name = col_name, tbl = res
+    col_name = col_name, tbl = res,
+    prepare_call = match.call()
   )
 }

R/prepare_ae_specific.R

@@ -199,6 +199,7 @@ prepare_ae_specific <- function(meta,
     prop = tbl_rate, diff = tbl_diff,
     n_pop = tbl_num[1, ],
     name = tbl$name,
-    components = components
+    components = components,
+    prepare_call = match.call()
   )
 }

R/prepare_ae_summary.R

@@ -103,7 +103,8 @@ prepare_ae_summary <- function(meta,
     prop = rbind(pop_prop, tbl_prop),
     diff = rbind(pop_diff, tbl_diff),
     n_pop = n_pop,
-    name = c(pop_name, name)
+    name = c(pop_name, name),
+    prepare_call = match.call()
   )
 }
 

tests/testthat/_snaps/independent-testing-tlf-ae-listing.md

@@ -3,7 +3,7 @@
     Code
       tbl
     Output
-      List of 11
+      List of 12
        $ meta           :List of 7
        $ population     : chr "apat"
        $ observation    : chr "wk12"
@@ -14,5 +14,6 @@
        $ reference_group: NULL
        $ col_name       : Named chr [1:11] "Unique Subject Identifier" "Analysis Start Relative Day" "Adverse Event" "Duration" ...
        $ tbl            :'data.frame':	704 obs. of  11 variables:
+       $ prepare_call   : language prepare_ae_listing(meta = x, analysis = "ae_listing", population = "apat",      observation = "wk12", parameter = "rel")
        $ rtf            :Classes 'rtf_text', 'rtf_border' and 'data.frame':	704 obs. of  11 variables:
 

tests/testthat/_snaps/independent-testing-tlf_ae_summary.md

@@ -3,7 +3,7 @@
     Code
       tbl
     Output
-      List of 14
+      List of 16
        $ meta           :List of 7
        $ population     : chr "apat"
        $ observation    : chr "wk12"
@@ -16,6 +16,8 @@
        $ diff           :'data.frame':	5 obs. of  2 variables:
        $ n_pop          :'data.frame':	1 obs. of  4 variables:
        $ name           : chr [1:5] "Participants in population" "with one or more adverse events" "with no adverse events" "with drug-related{^a} adverse events" ...
+       $ prepare_call   : language prepare_ae_summary(meta = meta, population = "apat", observation = "wk12",      parameter = "any;rel;ser")
        $ tbl            :'data.frame':	5 obs. of  9 variables:
+       $ extend_call    :List of 1
        $ rtf            :Classes 'rtf_text', 'rtf_border' and 'data.frame':	5 obs. of  9 variables:
 

tests/testthat/test-independent-testing-prepare_ae_listing.R

@@ -78,8 +78,6 @@ listing_ae <- full_join(
 test_that("Its class is 'outdata'", {
   output <- prepare_ae_listing(meta_ae_listing_example(), "ae_listing", "apat", "wk12", "ser")
   expect_equal(class(output), "outdata")
-  expect_equal(length(output), 10)
-  expect_equal(names(output), c("meta", "population", "observation", "parameter", "n", "order", "group", "reference_group", "col_name", "tbl"))
   expect_equal(output$population, "apat")
   expect_equal(output$parameter, "ser")
   expect_equal(output$n, NULL)