Closes #84 xportr deep dive vignette

.Rbuildignore

@@ -22,3 +22,5 @@
 ^advs\.xpt$
 ^advs_Define-Excel-Spec_match_admiral\.xlsx
 ^cran-comments\.md$
+^example_data_specs$
+^deepdive.Rmd$

NAMESPACE

@@ -10,6 +10,7 @@ export(xportr_format)
 export(xportr_label)
 export(xportr_length)
 export(xportr_logger)
+export(xportr_metadata)
 export(xportr_order)
 export(xportr_type)
 export(xportr_write)

NEWS.md

@@ -2,15 +2,18 @@
 
 ## New Features and Bug Fixes
 
-* Fixed an issue where `xportr_type` would overwrite column labels, widths, and "sas.formats"
-* Fixed messaging of `xportr_order`to give better visability of the number of variables being reordered.
-* Add new argument to `xportr_write` to allow users to specify how xpt validation checks are handled.
+* Fixed an issue where `xportr_type()` would overwrite column labels, widths, and "sas.formats"
+* Fixed messaging of `xportr_order()`to give better visability of the number of variables being reordered.
+* Add new argument to `xportr_write()` to allow users to specify how xpt validation checks are handled.
 * Fixed bug where character_types were case sensitive. They are now case insensitive.
-* Updated `xportr_type` to make type coercion more explicit. 
+* Updated `xportr_type()` to make type coercion more explicit. 
+* Added function `xportr_metadata()` to explicitly set metadata at the start of a pipeline (#44)
 
 ## Documentation
 
 * Moved `{pkgdown}` site to bootswatch. Enabled search and linked slack icon (#122).
+* Additional vignette showcasing functions and quality of life utilities for processing `xpts` created (#84)
+
 
 # xportr 0.2.0
 * Added a new validation test that errors when users pass invalid formats (#60 #64). Thanks to @zdz2101!

R/df_label.R

@@ -20,13 +20,13 @@
 #'   SEX = c("M", "F", "M")
 #' )
 #'
-#' metacore <- data.frame(
+#' metadata <- data.frame(
 #'   dataset = c("adsl", "adae"),
 #'   label = c("Subject-Level Analysis", "Adverse Events Analysis")
 #' )
 #'
-#' adsl <- xportr_df_label(adsl, metacore)
-xportr_df_label <- function(.df, metacore, domain = NULL) {
+#' adsl <- xportr_df_label(adsl, metadata)
+xportr_df_label <- function(.df, metacore = NULL, domain = NULL) {
   domain_name <- getOption("xportr.df_domain_name")
   label_name <- getOption("xportr.df_label")
 
@@ -38,6 +38,15 @@ xportr_df_label <- function(.df, metacore, domain = NULL) {
 
   ## End of common section
 
+  ## Pull out correct metadata
+  if (is.null(metacore)) {
+    if (is.null(attr(.df, "metadata"))) {
+      stop("Metadata must be set with `metacore` or `xportr_metadata()`")
+    } else {
+      metacore <- attr(.df, "metadata")
+    }
+  }
+
   if (inherits(metacore, "Metacore")) {
     metacore <- metacore$ds_spec
   }

R/format.R

@@ -20,14 +20,14 @@
 #'   BRTHDT = c(1, 1, 2)
 #' )
 #'
-#' metacore <- data.frame(
+#' metadata <- data.frame(
 #'   dataset = c("adsl", "adsl"),
 #'   variable = c("USUBJID", "BRTHDT"),
 #'   format = c(NA, "DATE9.")
 #' )
 #'
-#' adsl <- xportr_format(adsl, metacore)
-xportr_format <- function(.df, metacore, domain = NULL, verbose = getOption("xportr.format_verbose", "none")) {
+#' adsl <- xportr_format(adsl, metadata)
+xportr_format <- function(.df, metacore = NULL, domain = NULL, verbose = getOption("xportr.format_verbose", "none")) {
   domain_name <- getOption("xportr.domain_name")
   format_name <- getOption("xportr.format_name")
   variable_name <- getOption("xportr.variable_name")
@@ -40,6 +40,14 @@ xportr_format <- function(.df, metacore, domain = NULL, verbose = getOption("xpo
 
   ## End of common section
 
+  if (is.null(metacore)) {
+    if (is.null(attr(.df, "metadata"))) {
+      stop("Metadata must be set with `metacore` or `xportr_metadata()`")
+    } else {
+      metacore <- attr(.df, "metadata")
+    }
+  }
+
   if (inherits(metacore, "Metacore")) {
     metacore <- metacore$var_spec
   }

R/label.R

@@ -22,14 +22,14 @@
 #'   SEX = c("M", "F", "M")
 #' )
 #'
-#' metacore <- data.frame(
+#' metadata <- data.frame(
 #'   dataset = "adsl",
 #'   variable = c("USUBJID", "SITEID", "AGE", "SEX"),
 #'   label = c("Unique Subject Identifier", "Study Site Identifier", "Age", "Sex")
 #' )
 #'
-#' adsl <- xportr_label(adsl, metacore)
-xportr_label <- function(.df, metacore, domain = NULL,
+#' adsl <- xportr_label(adsl, metadata)
+xportr_label <- function(.df, metacore = NULL, domain = NULL,
                          verbose = getOption("xportr.label_verbose", "none")) {
   domain_name <- getOption("xportr.domain_name")
   variable_name <- getOption("xportr.variable_name")
@@ -43,6 +43,14 @@ xportr_label <- function(.df, metacore, domain = NULL,
 
   ## End of common section
 
+  if (is.null(metacore)) {
+    if (is.null(attr(.df, "metadata"))) {
+      stop("Metadata must be set with `metacore` or `xportr_metadata()`")
+    } else {
+      metacore <- attr(.df, "metadata")
+    }
+  }
+
   if (inherits(metacore, "Metacore")) {
     metacore <- metacore$var_spec
   }

R/length.R

@@ -20,14 +20,14 @@
 #'   BRTHDT = c(1, 1, 2)
 #' )
 #'
-#' metacore <- data.frame(
+#' metadata <- data.frame(
 #'   dataset = c("adsl", "adsl"),
 #'   variable = c("USUBJID", "BRTHDT"),
 #'   length = c(10, 8)
 #' )
 #'
-#' adsl <- xportr_length(adsl, metacore)
-xportr_length <- function(.df, metacore, domain = NULL,
+#' adsl <- xportr_length(adsl, metadata)
+xportr_length <- function(.df, metacore = NULL, domain = NULL,
                           verbose = getOption("xportr.length_verbose", "none")) {
   domain_name <- getOption("xportr.domain_name")
   variable_length <- getOption("xportr.length")
@@ -41,6 +41,14 @@ xportr_length <- function(.df, metacore, domain = NULL,
 
   ## End of common section
 
+  if (is.null(metacore)) {
+    if (is.null(attr(.df, "metadata"))) {
+      stop("Metadata must be set with `metacore` or `xportr_metadata()`")
+    } else {
+      metacore <- attr(.df, "metadata")
+    }
+  }
+
   if (inherits(metacore, "Metacore")) {
     metacore <- metacore$var_spec
   }

R/messages.R

@@ -49,14 +49,14 @@ var_names_log <- function(tidy_names_df, verbose) {
 
   # Message stating any renamed variables each original variable and it's new name
   if (nrow(only_renames) > 0) {
-    walk(only_renames$renamed_msg, ~ xportr_logger(.x, verbose))
+    purrr::walk(only_renames$renamed_msg, ~ xportr_logger(.x, verbose))
   }
 
   # Message checking for duplicate variable names after renamed (Pretty sure
   # this is impossible) but good to have a check none-the-less.
   dups <- tidy_names_df %>% filter(renamed_n > 1)
   if (nrow(dups) != 0) {
-    cli_alert_danger(
+    cli::cli_alert_danger(
       glue(
         .sep = " ",
         "Duplicate renamed term(s) were created.",

R/order.R

@@ -17,14 +17,14 @@
 #'   USUBJID = c(1001, 1002, 1003)
 #' )
 #'
-#' metacore <- data.frame(
+#' metadata <- data.frame(
 #'   dataset = c("adsl", "adsl", "adsl", "adsl"),
 #'   variable = c("STUDYID", "USUBJID", "TRT01A", "BRTHDT"),
 #'   order = 1:4
 #' )
 #'
-#' adsl <- xportr_order(adsl, metacore)
-xportr_order <- function(.df, metacore, domain = NULL, verbose = getOption("xportr.order_verbose", "none")) {
+#' adsl <- xportr_order(adsl, metadata)
+xportr_order <- function(.df, metacore = NULL, domain = NULL, verbose = getOption("xportr.order_verbose", "none")) {
   domain_name <- getOption("xportr.domain_name")
   order_name <- getOption("xportr.order_name")
   variable_name <- getOption("xportr.variable_name")
@@ -37,6 +37,14 @@ xportr_order <- function(.df, metacore, domain = NULL, verbose = getOption("xpor
 
   ## End of common section
 
+  if (is.null(metacore)) {
+    if (is.null(attr(.df, "metadata"))) {
+      stop("Metadata must be set with `metacore` or `xportr_metadata()`")
+    } else {
+      metacore <- attr(.df, "metadata")
+    }
+  }
+
   if (inherits(metacore, "Metacore")) {
     metacore <- metacore$ds_vars
   }

R/type.R

@@ -17,7 +17,7 @@
 #' @export
 #'
 #' @examples
-#' metacore <- data.frame(
+#' metadata <- data.frame(
 #'   dataset = "test",
 #'   variable = c("Subj", "Param", "Val", "NotUsed"),
 #'   type = c("numeric", "character", "numeric", "character")
@@ -30,8 +30,8 @@
 #'   Param = c("param1", "param2", "param3")
 #' )
 #'
-#' df2 <- xportr_type(.df, metacore, "test")
-xportr_type <- function(.df, metacore, domain = NULL,
+#' df2 <- xportr_type(.df, metadata, "test")
+xportr_type <- function(.df, metacore = NULL, domain = NULL,
                         verbose = getOption("xportr.type_verbose", "none")) {
   # Name of the columns for working with metadata
   domain_name <- getOption("xportr.domain_name")
@@ -50,7 +50,17 @@ xportr_type <- function(.df, metacore, domain = NULL,
   ## End of common section
 
   ## Pull out correct metadata
-  if ("Metacore" %in% class(metacore)) metacore <- metacore$var_spec
+  if (is.null(metacore)) {
+    if (is.null(attr(.df, "metadata"))) {
+      stop("Metadata must be set with `metacore` or `xportr_metadata()`")
+    } else {
+      metacore <- attr(.df, "metadata")
+    }
+  }
+
+  if (inherits(metacore, "Metacore")) {
+    metacore <- metacore$var_spec
+  }
 
   if (domain_name %in% names(metacore)) {
     metacore <- metacore %>%

R/utils-xportr.R

@@ -212,6 +212,7 @@ xpt_validate <- function(data) {
 
   # 3.0 VARIABLE TYPES ----
   types <- tolower(extract_attr(data, attr = "SAStype"))
+
   expected_types <- c(
     "", "text", "integer", "float", "datetime", "date", "time",
     "partialdate", "partialtime", "partialdatetime",

R/xportr_metadata.R

@@ -0,0 +1,39 @@
+#' Set variable specifications and domain
+#'
+#' @param .df An R object with columns that can be coerced
+#' @param metacore Either a data.frame that has the names of all possible columns
+#'   and their types, or a `Metacore` object from the `Metacore` package. Required
+#'   column names are dataset, variables, type
+#' @param domain Name of the dataset. Ex ADAE/DM. This will be used to subset
+#'   the metacore object. If none is passed it is assumed to be the name of the
+#'   dataset passed in `.df`.
+#'
+#' @return `.df` dataset with metadata and domain attributes set
+#' @export
+#'
+#' @examples
+#' metadata <- data.frame(
+#'   dataset = "test",
+#'   variable = c("Subj", "Param", "Val", "NotUsed"),
+#'   type = c("numeric", "character", "numeric", "character")
+#' )
+#'
+#' .df <- data.frame(
+#'   Subj = as.character(123, 456, 789),
+#'   Different = c("a", "b", "c"),
+#'   Val = c("1", "2", "3"),
+#'   Param = c("param1", "param2", "param3")
+#' )
+#'
+#' df2 <- xportr_metadata(.df, metadata, "test")
+xportr_metadata <- function(.df, metacore, domain = NULL) {
+  ## Common section to detect domain from argument or pipes
+
+  df_arg <- tryCatch(as_name(enexpr(.df)), error = function(err) NULL)
+  domain <- get_domain(.df, df_arg, domain)
+  if (!is.null(domain)) attr(.df, "_xportr.df_arg_") <- domain
+
+  ## End of common section
+
+  structure(.df, metadata = metacore)
+}

README.Rmd

@@ -137,6 +137,19 @@ adsl %>%
   xportr_write("adsl.xpt", label = "Subject-Level Analysis Dataset")
 ```
 
+The `xportr_metadata()` function can reduce duplication by setting the variable specification and domain explicitly at the top of a pipeline.
+
+```{r, message=FALSE, eval=FALSE}
+adsl %>%
+  xportr_metadata(var_spec, "ADSL") %>%
+  xportr_type() %>%
+  xportr_length() %>%
+  xportr_label() %>%
+  xportr_order() %>%
+  xportr_format() %>%
+  xportr_write("adsl.xpt", label = "Subject-Level Analysis Dataset")
+```
+
 That's it!  We now have a xpt file created in R with all appropriate types, lengths, labels, ordering and formats.  Please check out the [Get Started](https://atorus-research.github.io/xportr/articles/xportr.html) for more information and detailed walk through of each `xportr_` function.
 
 We are in talks with other Pharma companies involved with the [`{pharmaverse}`](https://pharmaverse.org/) to enhance this package to play well with other downstream and upstream packages.  

README.md

@@ -67,19 +67,19 @@ to any validators or data reviewers.
 
 <br>
 
--   Variable names must start with a letter (not an underscore), be
-    comprised of only uppercase letters (A-Z), numerals (0-9) and be
-    free of non-ASCII characters, symbols, and underscores.
--   Allotted length for each column containing character (text) data
-    should be set to the maximum length of the variable used across all
-    data sets (≤ 200)
--   Coerces variables to only numeric or character types
--   Display format support for numeric float and date/time values
--   Variables names are ≤ 8 characters.
--   Variable labels are ≤ 200 characters.
--   Data set labels are ≤ 40 characters.
--   Presence of non-ASCII characters in Variable Names, Labels or data
-    set labels.
+- Variable names must start with a letter (not an underscore), be
+  comprised of only uppercase letters (A-Z), numerals (0-9) and be free
+  of non-ASCII characters, symbols, and underscores.
+- Allotted length for each column containing character (text) data
+  should be set to the maximum length of the variable used across all
+  data sets (≤ 200)
+- Coerces variables to only numeric or character types
+- Display format support for numeric float and date/time values
+- Variables names are ≤ 8 characters.
+- Variable labels are ≤ 200 characters.
+- Data set labels are ≤ 40 characters.
+- Presence of non-ASCII characters in Variable Names, Labels or data set
+  labels.
 
 **NOTE:** Each check has associated messages and warning.
 
@@ -90,13 +90,13 @@ developed using R.
 
 To do this we will need to do the following:
 
--   Apply types
--   Apply lengths  
--   Apply variable labels
--   Apply formats
--   Re-order the variables
--   Apply a dataset label
--   Write out a version 5 xpt file
+- Apply types
+- Apply lengths  
+- Apply variable labels
+- Apply formats
+- Re-order the variables
+- Apply a dataset label
+- Write out a version 5 xpt file
 
 All of which can be done using a well-defined specification file and the
 `xportr` package!
@@ -134,12 +134,12 @@ Each `xportr_` function has been written in a way to take in a part of
 the specification file and apply that piece to the dataset.
 
 ``` r
-adsl %>% 
+adsl %>%
   xportr_type(var_spec, "ADSL") %>%
   xportr_length(var_spec, "ADSL") %>%
   xportr_label(var_spec, "ADSL") %>%
-  xportr_order(var_spec, "ADSL") %>% 
-  xportr_format(var_spec, "ADSL") %>% 
+  xportr_order(var_spec, "ADSL") %>%
+  xportr_format(var_spec, "ADSL") %>%
   xportr_write("adsl.xpt", label = "Subject-Level Analysis Dataset")
 ```