extend subgroup analysis based on AE specification R code (#160)

R/extend_ae_specific.R

@@ -36,6 +36,7 @@
 #'   format_ae_specific(display = c("n", "prop", "diff", "diff_ci"))
 #' head(tbl$tbl)
 extend_ae_specific_inference <- function(outdata, ci = 0.95) {
+
   res <- outdata
 
   if (!(is.numeric(ci) && length(ci) == 1 && (0 <= ci && ci <= 1))) {
@@ -88,7 +89,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 +220,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 +335,19 @@ 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,87 @@
+#' 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()
   )
 }