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: