Allow different variable names

closes #3
OuhscBbmc · Sep 6, 2018 · 61aba68 · 61aba68
1 parent c0ec0f6
commit 61aba68
Show file tree

Hide file tree

Showing 3 changed files with 51 additions and 13 deletions.
diff --git a/R/table-nih-enrollment.R b/R/table-nih-enrollment.R
@@ -9,7 +9,9 @@
 #' @param d_lu_gender [data.frame] that maps the observed levels of gender to the NIH-recommended levels of gender. Required only if the levels are not the same.
 #' @param d_lu_race [data.frame] that maps the observed levels of gender to the NIH-recommended levels of gender. Required only if the levels are not the same.
 #' @param d_lu_ethnicity [data.frame] that maps the observed levels of gender to the NIH-recommended levels of gender. Required only if the levels are not the same.
-#'
+#' @param variable_gender    name of the gender variable in the `d` [data.frame].  Defaults to gender.
+#' @param variable_race      name of the race variable in the `d` [data.frame].  Defaults to race.
+#' @param variable_ethnicity name of the ethnicity variable in the `d` [data.frame].  Defaults to ethnicity.
 #' @return Table for publication
 #'
 #' @details
@@ -116,11 +118,18 @@
 
 
 #' @export
-table_nih_enrollment <- function( d, d_lu_gender=NULL, d_lu_race=NULL, d_lu_ethnicity=NULL ) {
+table_nih_enrollment <- function(
+  d,
+  d_lu_gender=NULL, d_lu_race=NULL, d_lu_ethnicity=NULL,
+  variable_gender="gender", variable_race="race", variable_ethnicity="ethnicity"
+) {
   checkmate::assert_data_frame(d                  , any.missing=F)
   checkmate::assert_data_frame(d_lu_gender        , any.missing=F, null.ok=T)
   checkmate::assert_data_frame(d_lu_race          , any.missing=F, null.ok=T)
   checkmate::assert_data_frame(d_lu_ethnicity     , any.missing=F, null.ok=T)
+  checkmate::assert_character( variable_gender    , any.missing=F, min.chars=1, len=1)
+  checkmate::assert_character( variable_race      , any.missing=F, min.chars=1, len=1)
+  checkmate::assert_character( variable_ethnicity , any.missing=F, min.chars=1, len=1)
 
   levels_gender <- c(
     "Female",
@@ -149,6 +158,12 @@ table_nih_enrollment <- function( d, d_lu_gender=NULL, d_lu_race=NULL, d_lu_ethn
     ethnicity = levels_ethnicity
   )
 
+  d <- d %>%
+    dplyr::select_(
+      "gender"      = variable_gender   ,
+      "race"        = variable_race     ,
+      "ethnicity"   = variable_ethnicity
+    )
   if( !is.null(d_lu_gender) ) {
     d <- d %>%
       dplyr::left_join(d_lu_gender, by=c("gender" = "input")) %>%
@@ -184,7 +199,11 @@ table_nih_enrollment <- function( d, d_lu_gender=NULL, d_lu_race=NULL, d_lu_ethn
 }
 
 #' @export
-table_nih_enrollment_pretty <- function(d, d_lu_gender=NULL, d_lu_race=NULL, d_lu_ethnicity=NULL ) {
+table_nih_enrollment_pretty <- function(
+  d,
+  d_lu_gender=NULL, d_lu_race=NULL, d_lu_ethnicity=NULL,
+  variable_gender="gender", variable_race="race", variable_ethnicity="ethnicity"
+) {
   column_order <- c(
     "race",
 
@@ -201,7 +220,7 @@ table_nih_enrollment_pretty <- function(d, d_lu_gender=NULL, d_lu_race=NULL, d_l
     "Unknown/Not Reported by Unknown/Not Reported Ethnicity"
   )
 
-  table_nih_enrollment(d, d_lu_gender, d_lu_race, d_lu_ethnicity) %>%
+  table_nih_enrollment(d, d_lu_gender, d_lu_race, d_lu_ethnicity, variable_gender, variable_race, variable_ethnicity) %>%
     dplyr::mutate(
       gender_ethnicity  = paste0(.data$gender, " by ", .data$ethnicity)
     ) %>%

diff --git a/man/table_nih_enrollment.Rd b/man/table_nih_enrollment.Rd
diff --git a/tests/testthat/test-table-nih-enrollment.R b/tests/testthat/test-table-nih-enrollment.R
@@ -79,14 +79,14 @@ test_that("ds_1b --ethnicity metadata required", {
 test_that("ds_1c --all metadata required", {
   d_1c <- tibble::tribble(
     ~subject_id,  ~gender , ~race , ~ethnicity    ,
-             1L,  "M"     , "B"   , "Not Latino"  ,
-             2L,  "M"     , "B"   , "Not Latino"  ,
-             3L,  "F"     , "B"   , "Unknown"     ,
-             4L,  "M"     , "W"   , "Not Latino"  ,
-             5L,  "M"     , "W"   , "Not Latino"  ,
-             6L,  "F"     , "W"   , "Not Latino"  ,
-             7L,  "M"     , "W"   , "Latino"      ,
-             8L,  "M"     , "W"   , "Latino"
+    1L,  "M"     , "B"   , "Not Latino"  ,
+    2L,  "M"     , "B"   , "Not Latino"  ,
+    3L,  "F"     , "B"   , "Unknown"     ,
+    4L,  "M"     , "W"   , "Not Latino"  ,
+    5L,  "M"     , "W"   , "Not Latino"  ,
+    6L,  "F"     , "W"   , "Not Latino"  ,
+    7L,  "M"     , "W"   , "Latino"      ,
+    8L,  "M"     , "W"   , "Latino"
   )
 
   d_lu_gender <- tibble::tribble(
@@ -116,6 +116,18 @@ test_that("ds_1c --all metadata required", {
   expect_equal(observed, expected_1)
 })
 
+test_that("ds_1d --different variable names", {
+  ds_1d <- ds_1a %>%
+    dplyr::rename(
+      vg  = gender,
+      vr  = race,
+      ve  = ethnicity
+    )
+
+  observed <- table_nih_enrollment(ds_1d, variable_gender="vg", variable_race="vr", variable_ethnicity="ve")
+  expect_equal(observed, expected_1)
+})
+
 test_that("ds_2 --500 patients w/ numeric codes", {
 
   # library(magrittr)