Merge pull request #179 from atorus-research/gh_issue_178

1.2.1 Release Fixes

.Rbuildignore

@@ -24,3 +24,4 @@
 ^rsconnect$
 ^data-raw$
 ^scratch.R$
+^CRAN-SUBMISSION$

CRAN-SUBMISSION

@@ -0,0 +1,3 @@
+Version: 1.2.0
+Date: 2024-02-14 17:07:48 UTC
+SHA: 806f9a0a103059542437632f5977cc1e8ded2652

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: Tplyr
 Title: A Traceability Focused Grammar of Clinical Data Summary
-Version: 1.2.0
+Version: 1.2.1
 Authors@R: 
     c(
     person(given = "Eli",

NAMESPACE

@@ -44,6 +44,7 @@ S3method(str,tplyr_table)
 export("%>%")
 export("header_n<-")
 export("pop_data<-")
+export(add_anti_join)
 export(add_column_headers)
 export(add_filters)
 export(add_layer)

R/count_bindings.R

@@ -745,6 +745,13 @@ add_missing_subjects_row <- function(e, fmt = NULL, sort_value = NULL) {
   }
   assert_inherits_class(e, "count_layer")
 
+  if (identical(env_get(env_parent(e), 'target'), env_get(env_parent(e), 'pop_data'))) {
+    warning(paste("\tPopulation data was not set separately from the target data.",
+                  "\tMissing subject counts may be misleading in this scenario.",
+                  "\tDid you mean to use `set_missing_count() instead?",
+                  sep="\n"))
+  }
+
   env_bind(e, include_missing_subjects_row = TRUE)
   env_bind(e, missing_subjects_count_format = fmt)
   env_bind(e, missing_subjects_sort_value = sort_value)

R/meta-builders.R

@@ -94,13 +94,17 @@ build_count_meta <- function(layer, table_where, layer_where, treat_grps, summar
 
   # The total row label may not pass through, so set it
   total_row_label <- ifelse(is.null(layer$total_row_label), 'Total', layer$total_row_label)
+  missing_subjects_row_label <- ifelse(is.null(layer$total_row_label), 'Missing', layer$missing_subjects_row_label)
   count_missings <- ifelse(is.null(layer$count_missings), FALSE, layer$count_missings)
   mlist <- layer$missing_count_list
 
   # If the outer layer was provided as a text variable, get value
   character_outer <- get_character_outer(layer)
   unnested_character <- is_unnested_character(layer)
 
+  # Pull out table object to use later
+  tbl <- env_parent(layer)
+
   meta <- vector('list', length(values[[1]]))
 
   # Vectorize across the input data
@@ -113,6 +117,7 @@ build_count_meta <- function(layer, table_where, layer_where, treat_grps, summar
     }
 
     row_filter <- list()
+    aj <- NULL
 
     # Pull out the current row's values
     cur_values <- map(values, ~ .x[i])
@@ -130,21 +135,26 @@ build_count_meta <- function(layer, table_where, layer_where, treat_grps, summar
       if (summary_var[i] == total_row_label && !count_missings) {
         # Filter out the missing counts if the total row should exclude missings
         row_filter <- make_parsed_strings(layer$target_var, list(mlist), negate=TRUE)
-      }
-      else if (summary_var[i] %in% names(mlist)) {
+      } else if (summary_var[i] == missing_subjects_row_label) {
+        # Special handling for missing subject rows
+        # Make a meta object for the pop data
+        pop_filt_inds <- which(filter_variables %in% unlist(list(tbl$treat_var, tbl$cols)))
+        pop_filt_vars <- filter_variables[pop_filt_inds]
+        pop_filt_vals <- filter_values[pop_filt_inds]
+        pop_meta <- build_meta(tbl$pop_where, quo(TRUE), treat_grps, pop_filt_vars, pop_filt_vals)
+        aj <- new_anti_join(join_meta=pop_meta, on=layer$distinct_by)
+      } else if (summary_var[i] %in% names(mlist)) {
         # Get the values for the missing row
         miss_val <- mlist[which(names(mlist) == summary_var[i])]
         row_filter <- make_parsed_strings(layer$target_var, list(miss_val))
-      }
-      else if (summary_var[i] != total_row_label) {
+      } else if (summary_var[i] != total_row_label) {
         # Subset to outer layer value
         row_filter <- make_parsed_strings(na_var, summary_var[i])
       }
 
       add_vars <- append(add_vars, na_var)
 
-    }
-    else {
+    } else {
       # Inside the nested layer
       filter_variables <- variables
       filter_values <- cur_values
@@ -162,6 +172,18 @@ build_count_meta <- function(layer, table_where, layer_where, treat_grps, summar
       else if (summary_var[i] == total_row_label && !count_missings) {
         # Filter out the missing counts if the total row should exclude missings
         row_filter <- make_parsed_strings(layer$target_var, list(mlist), negate=TRUE)
+      } else if (summary_var[i] == missing_subjects_row_label) {
+        # Special handling for missing subject rows
+        # Make a meta object for the pop data
+        pop_filt_inds <- which(filter_variables %in% unlist(list(tbl$treat_var, tbl$cols)))
+        pop_filt_vars <- filter_variables[pop_filt_inds]
+        pop_filt_vals <- filter_values[pop_filt_inds]
+        # Reset to the pop treat value
+        pop_filt_vars[[
+          which(map_chr(pop_filt_vars, as_label) == as_label(tbl$treat_var))
+          ]] <- tbl$pop_treat_var
+        pop_meta <- build_meta(tbl$pop_where, quo(TRUE), treat_grps, pop_filt_vars, pop_filt_vals)
+        aj <- new_anti_join(join_meta=pop_meta, on=layer$distinct_by)
       }
       else if (!is.na(character_outer) && summary_var[i] == character_outer) {
         # If the outer layer is a character string then don't provide a filter
@@ -176,8 +198,8 @@ build_count_meta <- function(layer, table_where, layer_where, treat_grps, summar
     # Make the meta object
     meta[[i]] <- build_meta(table_where, layer_where, treat_grps, filter_variables, filter_values) %>%
       add_filters_(row_filter) %>%
-      add_variables_(add_vars)
-
+      add_variables_(add_vars) %>%
+      add_anti_join_(aj)
   }
 
   meta

R/meta.R

@@ -221,8 +221,93 @@ print.tplyr_meta <- function(x, ...) {
   cat("Names:\n")
   names <- map_chr(x$names, as_label)
   filters <- map_chr(x$filters, as_label)
-  cat("   ", paste(names, collapse = ", "), "\n")
+  cat("    ", paste0(names, collapse = ", "), "\n")
   cat("Filters:\n")
-  cat("   ", paste(filters, collapse = ", "), "\n")
+  cat("    ", paste0(filters, collapse = ", "), "\n")
+  if (!is.null(x$anti_join)) {
+    cat("Anti-join:\n")
+    cat("    Join Meta:\n")
+    cat(paste0("        ", capture.output(x$anti_join$join_meta), "\n"), sep="")
+    cat("    On:\n")
+    aj_on <- map_chr(x$anti_join$on, as_label)
+    cat("       ", paste0(aj_on, collapse = ", "), "\n")
+  }
   invisible()
 }
+
+#' Create an tplyr_meta_anti_join object
+#'
+#' @return tplyr_meta_anti_join object
+#' @noRd
+new_anti_join <- function(join_meta, on) {
+  structure(
+    list(
+      join_meta = join_meta,
+      on = on
+    ),
+    class="tplyr_meta_anti_join"
+  )
+}
+
+#' Internal application of anti_join onto tplyr_meta object
+#' @noRd
+add_anti_join_ <- function(meta, aj) {
+  meta$anti_join <- aj
+  meta
+}
+
+#' Add an anti-join onto a tplyr_meta object
+#'
+#' An anti-join allows a tplyr_meta object to refer to data that should be
+#' extracted from a separate dataset, like the population data of a Tplyr table,
+#' that is unavailable in the target dataset. The primary use case for this is
+#' the presentation of missing subjects, which in a Tplyr table is presented
+#' using the function `add_missing_subjects_row()`. The missing subjects
+#' themselves are not present in the target data, and are thus only available in
+#' the population data. The `add_anti_join()` function allows you to provide the
+#' meta information relevant to the population data, and then specify the `on`
+#' variable that should be used to join with the target dataset and find the
+#' values present in the population data that are missing from the target data.
+#'
+#' @param meta A tplyr_meta object referring to the target data
+#' @param join_meta A tplyr_meta object referring to the population data
+#' @param on A list of quosures containing symbols - most likely set to USUBJID.
+#'
+#' @return A tplyr_meta object
+#' @md
+#' @export
+#'
+#' @examples
+#'
+#' tm <- tplyr_meta(
+#'   rlang::quos(TRT01A, SEX, ETHNIC, RACE),
+#'   rlang::quos(TRT01A == "Placebo", TRT01A == "SEX", ETHNIC == "HISPANIC OR LATINO")
+#' )
+#'
+#' tm %>%
+#'   add_anti_join(
+#'     tplyr_meta(
+#'       rlang::quos(TRT01A, ETHNIC),
+#'       rlang::quos(TRT01A == "Placebo", ETHNIC == "HISPANIC OR LATINO")
+#'     ),
+#'     on = rlang::quos(USUBJID)
+#'   )
+add_anti_join <- function(meta, join_meta, on){
+
+  if (!inherits(meta, 'tplyr_meta')) {
+    stop("meta must be a tplyr_meta object", call.=FALSE)
+  }
+
+  if (!inherits(join_meta, 'tplyr_meta')) {
+    stop("join_meta must be a tplyr_meta object", call.=FALSE)
+  }
+
+  if (!all(map_lgl(on, ~ is_quosure(.) && quo_is_symbol(.)))) {
+    stop("on must be provided as a list of names", call.=FALSE)
+  }
+
+
+  aj <- new_anti_join(join_meta, on)
+
+  add_anti_join_(meta, aj)
+}

R/meta_utils.R

@@ -54,7 +54,7 @@ get_meta_result <- function(x, row_id, column, ...) {
 get_meta_result.tplyr_table <- function(x, row_id, column, ...) {
   m <- x$metadata
 
-  get_meta_result.data.frame(m, row_id, column)
+  get_meta_result.data.frame(m, row_id, column, ...)
 }
 
 #' @export
@@ -69,6 +69,10 @@ get_meta_result.data.frame <- function(x, row_id, column, ...) {
                 'column present in the built Tplyr dataframe'), call.=FALSE)
   }
 
+  if (length(list(...)) > 0) {
+    warning("Extra arguments were provided to get_meta_result() that will not be used.", immediate.=TRUE)
+  }
+
   # Pull out the cell of interest
   res <- x[[which(x$row_id == row_id), column]][[1]]
 
@@ -109,6 +113,8 @@ get_meta_result.data.frame <- function(x, row_id, column, ...) {
 #' @param column The result column of interest, provided as a character string
 #' @param add_cols  Additional columns to include in subset data.frame output
 #' @param target A data frame to be subset (if not pulled from a Tplyr table)
+#' @param pop_data A data frame to be subset through an anti-join (if not pulled
+#'   from a Tplyr table)
 #' @param ... additional arguments
 #'
 #' @return A data.frame
@@ -139,7 +145,8 @@ get_meta_subset <- function(x, row_id, column, add_cols = vars(USUBJID), ...) {
 #' @export
 #' @rdname get_meta_subset
 get_meta_subset.data.frame <- function(x, row_id, column,
-                                       add_cols = vars(USUBJID), target = NULL, ...) {
+                                       add_cols = vars(USUBJID),
+                                       target = NULL, pop_data = NULL, ...) {
   # Get the metadata object ready
   m <- get_meta_result(x, row_id, column)
 
@@ -152,9 +159,33 @@ get_meta_subset.data.frame <- function(x, row_id, column,
     stop("If querying metadata without a tplyr_table, a target must be provided", call.=FALSE)
   }
 
-  target %>%
+  if (length(list(...)) > 0) {
+    warning("Extra arguments were provided to get_meta_subset() that will not be used.", immediate.=TRUE)
+  }
+
+  out <- target %>%
     filter(!!!m$filters) %>%
     select(!!!add_cols, !!!m$names)
+
+  if (!is.null(m$anti_join)) {
+    aj <- m$anti_join
+    pd <- pop_data %>%
+      filter(!!!aj$join_meta$filters) %>%
+      select(!!!aj$on, !!!add_cols, !!!aj$join_meta$names)
+
+    mrg_var <- map_chr(aj$on, as_name)
+    names(mrg_var) <- mrg_var
+
+    if (!(mrg_var %in% names(pd)) | !(mrg_var %in% names(out))) {
+      stop(paste0(
+        "The `on` variable specified is missing from either the target data or the population data subsets.\n  ",
+        "Try adding the `on` variables to the `add_cols` parameter")
+      )
+    }
+    out <- anti_join(pd, out, by=mrg_var)
+  }
+
+  out
 }
 
 #' @export
@@ -164,13 +195,7 @@ get_meta_subset.tplyr_table <- function(x, row_id, column, add_cols = vars(USUBJ
   # Get the metadata object ready
   m <- get_meta_result(x, row_id, column)
 
-  if (!inherits(add_cols, 'quosures')) {
-    stop("add_cols must be provided using `dplyr::vars()`", call.=FALSE)
-  }
-
-  # Subset and return the data
-  x$target %>%
-    filter(!!!m$filters) %>%
-    select(!!!add_cols, !!!m$names)
+  get_meta_subset(x$metadata, row_id, column, add_cols = add_cols,
+                  target = x$target, pop_data = x$pop_data)
 }
 

_pkgdown.yml

@@ -62,7 +62,9 @@ reference:
   - add_total_row
   - add_total_group
   - add_risk_diff
+  - add_missing_subjects_row
   - set_total_row_label
+  - set_missing_subjects_row_label
 - title: Descriptive Statistics Layer Functions
   desc: Descriptive statistics layer helper functions
 - contents:
@@ -84,6 +86,7 @@ reference:
   - set_denom_ignore
   - set_indentation
   - set_numeric_threshold
+  - set_limit_data_by
 - title: Column Headers
   desc: Column header helpers
 - contents:
@@ -95,6 +98,7 @@ reference:
   - tplyr_meta
   - add_variables
   - add_filters
+  - add_anti_join
   - get_metadata
   - append_metadata
   - starts_with('get_meta')
@@ -109,6 +113,7 @@ reference:
   - apply_formats
   - apply_row_masks
   - collapse_row_labels
+  - replace_leading_whitespace
   - str_extract_fmt_group
   - str_extract_num
   - str_indent_wrap
@@ -130,6 +135,7 @@ reference:
   - tplyr_adas
   - tplyr_adlb
   - tplyr_adsl
+  - tplyr_adpe
   - get_data_labels
 
 articles: