Merge branch '84_xportr_deep_dive_vignette' of https://github.com/ato…

…rus-research/xportr into 84_xportr_deep_dive_vignette

.github/ISSUE_TEMPLATE/01_bug_report.yml

@@ -0,0 +1,33 @@
+name: Bug Report
+description: Something is not working correctly or is not working at all!
+title: "Bug: <Insert Issue Title Here>"
+labels: ["bug", "programming"]
+body:
+ - type: markdown
+ attributes:
+ value: |
+ **Example:** Bug: xportr_format() does not assign SAS format for `DATE9.` metadata
+ - type: textarea
+ id: what-happened
+ attributes:
+ label: What happened?
+ description: Also tell us what were you expecting to happen before the bug?
+ placeholder: "A bug happened!"
+ validations:
+ required: true
+ - type: textarea
+ id: session-info
+ attributes:
+ label: Session Information
+ description: Use `sessionInfo()` in the R console to gather all the details of your environment when the bug happened.
+ placeholder: "Place the console output here"
+ validations:
+ required: false
+ - type: textarea
+ id: logs
+ attributes:
+ label: Reproducible Example
+ description: We love code that can reproduce the bug. Check out [reprex](https://reprex.tidyverse.org/articles/reprex-dos-and-donts.html)
+ placeholder: "Please give us as many details as you can! The faster we can recreate the bug, the faster we can get a fix in the works. Warning, Error Messages and Screenshots are also great."
+ validations:
+ required: false

.github/ISSUE_TEMPLATE/02_feature_request.yml

@@ -0,0 +1,41 @@
+name: Feature Request
+description: Enchancement to xportr functionality
+title: "Feature Request: <Insert Issue Title Here>"
+labels: ["enhancement", "programming"]
+body:
+ - type: markdown
+ attributes:
+ value: |
+ Thanks for taking the time to fill out this feature request! We love keeping xportr fresh!
+ - type: textarea
+ id: feature
+ attributes:
+ label: Feature Idea
+ description: Tell us your idea in as few words as possible
+ placeholder: "`xportr_validate` should do x, y and z"
+ validations:
+ required: true
+ - type: textarea
+ id: input
+ attributes:
+ label: Relevant Input
+ description: Can you provide what the inputs should look like?
+ placeholder: "What should the input look like? REMINDER: No patient level data or company sensitive information should be shared via this open public issue"
+ validations:
+ required: false
+ - type: textarea
+ id: output
+ attributes:
+ label: Relevant Output
+ description: Can you provide what the final output should look like?
+ placeholder: "What should the output look like? REMINDER: No patient level data or company sensitive information should be shared via this open public issue"
+ validations:
+ required: false
+ - type: textarea
+ id: code
+ attributes:
+ label: Reproducible Example/Pseudo Code
+ description: Can you provide a working example or a sketch of how the code should work?
+ placeholder: "We love example code and it will speed up the process! REMINDER: No patient level data or company sensitive information should be shared via this open public issue"
+ validations:
+ required: false

.github/PULL_REQUEST_TEMPLATE/release.md

@@ -0,0 +1,22 @@
+# Release Description
+<!--- Summarize what is being released. -->
+
+## Milestone
+<!--- Link to the milestone for the release. ---> 
+<!--- Make sure all relevant issues are included on the linked pages. --->
+Milestone: 
+
+# Release Checklist
+<!--- Fill out the following Release checklist -->
+
+- [ ] DESCRIPTION File version number has been updated
+- [ ] DESCRIPTION file updated with New Developers (if applicable)
+- [ ] NEWS.md has been updated and issues numbers linked
+- [ ] README.md has been updated (if applicable)
+- [ ] Vignettes have been updated (if applicable)
+- [ ] Ensure all unit tests are passing
+- [ ] Review https://r-pkgs.org/release.html for additional checks and guidance
+- [ ] Use `rhub::check_for_cran()` for checking CRAN flavors before submission
+- [ ] Use `usethis::use_revdep()` to check for any reverse dependencies
+- [ ] GitHub actions on this PR are all passing
+- [ ] Draft GitHub release created using automatic template and updated with additional details. Remember to click "release" after PR is merged.

.github/pull_request_template.md

@@ -0,0 +1,30 @@
+### Thank you for your Pull Request! 
+
+We have developed a Pull Request template to aid you and our reviewers. Completing the below tasks helps to ensure our reviewers can maximize their time on your code as well as making sure the xportr codebase remains robust and consistent. 
+
+### The scope of `{xportr}`
+
+`{xportr}`'s scope is to enable R users to write out submission compliant `xpt` files that can be delivered to a Health Authority or to downstream validation software programs. We see labels, lengths, types, ordering and formats from a dataset specification object (SDTM and ADaM) as being our primary focus. We also see messaging and warnings to users around applying information from the specification file as a primary focus. Please make sure your Pull Request meets this **scope of {xportr}**. If your Pull Request moves beyond this scope, please get in touch with the `{xportr}` team on [slack](https://pharmaverse.slack.com/archives/C030EB2M4GM) or create an issue to discuss.
+
+Please check off each task box as an acknowledgment that you completed the task. This checklist is part of the Github Action workflows and the Pull Request will not be merged into the `devel` branch until you have checked off each task.
+
+### Changes Description
+
+_(descriptions of changes)_ 
+
+### Task List
+
+- [ ] The spirit of xportr is met in your Pull Request
+- [ ] Place Closes #<insert_issue_number> into the beginning of your Pull Request Title (Use Edit button in top-right if you need to update)
+- [ ] Summary of changes filled out in the above Changes Description. Can be removed or left blank if changes are minor/self-explanatory.
+- [ ] Check that your Pull Request is targeting the `devel` branch, Pull Requests to `main` should use the [Release Pull Request Template](https://github.com/atorus-research/xportr/tree/94_pr_template/.github/PULL_REQUEST_TEMPLATE)
+- [ ] Code is formatted according to the [tidyverse style guide](https://style.tidyverse.org/). Use `styler` package and functions to style files accordingly.
+- [ ] Updated relevant unit tests or have written new unit tests. See our [Wiki](https://github.com/atorus-research/xportr/wiki/Style-Guide-for-Unit-Tests) for conventions used in this package.
+- [ ] Creation/updated relevant roxygen headers and examples. See our [Wiki](https://github.com/atorus-research/xportr/wiki/Style-Guide-for-Roxygen-Headers) for conventions used in this package.
+- [ ] Run `devtools::document()` so all `.Rd` files in the `man` folder and the `NAMESPACE` file in the project root are updated appropriately
+- [ ] Run `pkgdown::build_site()` and check that all affected examples are displayed correctly and that all new/updated functions occur on the "Reference" page.
+- [ ] Update NEWS.md if the changes pertain to a user-facing function (i.e. it has an @export tag) or documentation aimed at users (rather than developers)
+- [ ] Address any updates needed for vignettes and/or templates
+- [ ] Link the issue Development Panel so that it closes after successful merging.
+- [ ] Fix merge conflicts 
+- [ ] Pat yourself on the back for a job well done! Much love to your accomplishment!

.github/workflows/pkgdown.yaml

@@ -14,7 +14,7 @@ jobs:
  steps:
  - uses: actions/checkout@v3
 
- - uses: r-lib/actions/setup-r@v1
+ - uses: r-lib/actions/setup-r@v2
 
  - uses: r-lib/actions/setup-pandoc@v1
 

.github/workflows/spellcheck.yml

@@ -32,7 +32,7 @@ jobs:
  fetch-depth: 0
 
  - name: Setup R 📊
- uses: r-lib/actions/setup-r@v1
+ uses: r-lib/actions/setup-r@v2
  with:
  r-version: 4.1.3
 

.github/workflows/test-coverage.yaml

@@ -18,7 +18,7 @@ jobs:
  steps:
  - uses: actions/checkout@v3
 
- - uses: r-lib/actions/setup-r@v1
+ - uses: r-lib/actions/setup-r@v2
 
  - uses: r-lib/actions/setup-pandoc@v1
 

NEWS.md

@@ -11,6 +11,7 @@
 * Added function `xportr_metadata()` to explicitly set metadata at the start of a pipeline (#44)
 * Metadata order columns are now coerced to numeric by default in `xportr_order()` to prevent character sorting (#149)
 * Message is shown on `xportr_*` functions when the metadata being used has multiple variables with the same name in the same domain (#128)
+* Fixed an issue with `xport_type()` where `DT`, `DTM` variables with a format specified in the metadata (e.g. date9., datetime20.) were being converted to numeric, which will cause a 10 year difference when reading it back by `read_xpt()`. SAS's uniform start date is 1960 whereas Linux's uniform start date is 1970.
 
 ## Documentation
 

R/metadata.R

@@ -21,6 +21,7 @@
 #' dataset = "test",
 #' variable = c("Subj", "Param", "Val", "NotUsed"),
 #' type = c("numeric", "character", "numeric", "character"),
+#' format = NA,
 #' order = c(1, 3, 4, 2)
 #' )
 #'

R/type.R

@@ -21,7 +21,8 @@
 #' metadata <- data.frame(
 #' dataset = "test",
 #' variable = c("Subj", "Param", "Val", "NotUsed"),
-#' type = c("numeric", "character", "numeric", "character")
+#' type = c("numeric", "character", "numeric", "character"),
+#' format = NA
 #' )
 #'
 #' .df <- data.frame(
@@ -51,6 +52,7 @@ xportr_type <- function(.df,
  type_name <- getOption("xportr.type_name")
  characterTypes <- c(getOption("xportr.character_types"), "_character")
  numericTypes <- c(getOption("xportr.numeric_types"), "_numeric")
+ format_name <- getOption("xportr.format_name")
 
  ## Common section to detect domain from argument or pipes
 
@@ -73,8 +75,9 @@ xportr_type <- function(.df,
  metadata <- metadata %>%
  filter(!!sym(domain_name) == domain)
  }
- metadata <- metadata %>%
- select(!!sym(variable_name), !!sym(type_name))
+
+ metacore <- metadata %>%
+ select(!!sym(variable_name), !!sym(type_name), !!sym(format_name))
 
  # Common check for multiple variables name
  check_multiple_var_specs(metadata, variable_name)
@@ -92,9 +95,13 @@ xportr_type <- function(.df,
  # _character is used here as a mask of character, in case someone doesn't
  # want 'character' coerced to character
  type.x = if_else(type.x %in% characterTypes, "_character", type.x),
- type.x = if_else(type.x %in% numericTypes, "_numeric", type.x),
+ type.x = if_else(type.x %in% numericTypes | (grepl("DT$|DTM$|TM$", variable) & !is.na(format)),
+ "_numeric",
+ type.x
+ ),
+ type.y = if_else(is.na(type.y), type.x, type.y),
  type.y = tolower(type.y),
- type.y = if_else(type.y %in% characterTypes, "_character", type.y),
+ type.y = if_else(type.y %in% characterTypes | (grepl("DTC$", variable) & is.na(format)), "_character", type.y),
  type.y = if_else(type.y %in% numericTypes, "_numeric", type.y)
  )
 
@@ -105,7 +112,6 @@ xportr_type <- function(.df,
  type_mismatch_ind <- which(meta_ordered$type.x != meta_ordered$type.y)
  type_log(meta_ordered, type_mismatch_ind, verbose)
 
-
  # Check if variable types match
  is_correct <- sapply(meta_ordered[["type.x"]] == meta_ordered[["type.y"]], isTRUE)
  # Use the original variable iff metadata is missing that variable
@@ -128,6 +134,5 @@ xportr_type <- function(.df,
  }
  }, is_correct
  )
-
  .df
 }

R/utils-xportr.R

@@ -357,9 +357,8 @@ first_class <- function(x) {
 #' @param metadata A data frame containing variable level metadata.
 #' @param variable_name string with `getOption('xportr.variable_name')`
 #' @noRd
-check_multiple_var_specs <- function(
- metadata,
- variable_name = getOption("xportr.variable_name")) {
+check_multiple_var_specs <- function(metadata,
+ variable_name = getOption("xportr.variable_name")) {
  variable_len <- pluck(metadata, variable_name) %||% c()
  if (NROW(variable_len) != NROW(unique(variable_len))) {
  cli_alert_info(

R/xportr-package.R

@@ -26,7 +26,8 @@
 globalVariables(c(
  "abbr_parsed", "abbr_stem", "adj_orig", "adj_parsed", "col_pos", "dict_varname",
  "lower_original_varname", "my_minlength", "num_st_ind", "original_varname",
- "renamed_n", "renamed_var", "use_bundle", "viable_start", "type.x", "type.y"
+ "renamed_n", "renamed_var", "use_bundle", "viable_start", "type.x", "type.y",
+ "variable"
 ))
 
 # The following block is used by usethis to automatically manage

tests/testthat/test-depreciation.R

@@ -92,7 +92,8 @@ test_that("xportr_type: deprecated metacore argument still works and gives warni
  df_meta <- data.frame(
  dataset = "df",
  variable = c("Subj", "Param", "Val", "NotUsed"),
- type = c("numeric", "character", "numeric", "character")
+ type = c("numeric", "character", "numeric", "character"),
+ format = NA
  )
 
  df2 <- xportr_type(df, metacore = df_meta)

tests/testthat/test-length.R

@@ -45,7 +45,7 @@ test_that("xportr_length: Accepts valid domain names in metadata object", {
 test_that("xportr_length: CDISC data frame is being piped after another xportr function", {
  adsl <- minimal_table(30)
  metadata <- minimal_metadata(
- dataset = TRUE, length = TRUE, type = TRUE, var_names = colnames(adsl)
+ dataset = TRUE, length = TRUE, type = TRUE, format = TRUE, var_names = colnames(adsl)
  )
 
  # Setup temporary options with active verbose

tests/testthat/test-type.R

@@ -1,7 +1,8 @@
 meta_example <- data.frame(
  dataset = "df",
  variable = c("Subj", "Param", "Val", "NotUsed"),
- type = c("numeric", "character", "numeric", "character")
+ type = c("numeric", "character", "numeric", "character"),
+ format = NA
 )
 
 df <- data.frame(
@@ -23,7 +24,8 @@ test_that("xportr_type: NAs are handled as expected", {
  meta_example <- data.frame(
  dataset = "df",
  variable = c("Subj", "Param", "Val", "NotUsed"),
- type = c("numeric", "character", "numeric", "character")
+ type = c("numeric", "character", "numeric", "character"),
+ format = NA
  )
 
  df2 <- xportr_type(df, meta_example)
@@ -176,6 +178,63 @@ test_that("xportr_type: error when metadata is not set", {
  )
 })
 
+test_that("xportr_type: date variables are not converted to numeric", {
+ df <- data.frame(RFICDT = as.Date("2017-03-30"), RFICDTM = as.POSIXct("2017-03-30"))
+ metacore_meta <- suppressWarnings(
+ metacore::metacore(
+ var_spec = data.frame(
+ variable = c("RFICDT", "RFICDTM"),
+ type = "integer",
+ label = c("RFICDT Label", "RFICDTM Label"),
+ length = c(1, 2),
+ common = NA_character_,
+ format = c("date9.", "datetime20.")
+ )
+ )
+ )
+ expect_message(
+ {
+ processed_df <- xportr_type(df, metacore_meta)
+ },
+ NA
+ )
+ expect_equal(lapply(df, class), lapply(processed_df, class))
+ expect_equal(df$RFICDT, processed_df$RFICDT)
+ expect_equal(df$RFICDTM, processed_df$RFICDTM)
+
+ xportr_write(processed_df, file.path(tempdir(), "dfdates.xpt"))
+ df_xpt <- read_xpt(file.path(tempdir(), "dfdates.xpt"))
+
+ expect_equal(lapply(df, class), lapply(df_xpt, class))
+ expect_equal(df$RFICDT, df_xpt$RFICDT, ignore_attr = TRUE)
+ expect_equal(as.character(df$RFICDTM), as.character(df_xpt$RFICDTM), ignore_attr = TRUE)
+
+ metadata <- data.frame(
+ dataset = c("adsl", "adsl", "adsl", "adsl"),
+ variable = c("USUBJID", "DMDTC", "RFICDT", "RFICDTM"),
+ type = c("text", "date", "integer", "integer"),
+ format = c(NA, NA, "date9.", "datetime15.")
+ )
+
+ adsl_original <- data.frame(
+ USUBJID = c("test1", "test2"),
+ DMDTC = c("2017-03-30", "2017-01-08"),
+ RFICDT = c("2017-03-30", "2017-01-08"),
+ RFICDTM = c("2017-03-30", "2017-01-08")
+ )
+
+
+ adsl_original$RFICDT <- as.Date(adsl_original$RFICDT)
+ adsl_original$RFICDTM <- as.POSIXct(adsl_original$RFICDTM)
+
+ expect_message(adsl_xpt2 <- adsl_original %>%
+ xportr_type(metadata), NA)
+
+ attr(adsl_original, "_xportr.df_arg_") <- "adsl_original"
+
+ expect_equal(adsl_original, adsl_xpt2)
+})
+
 test_that("xportr_type: Gets warning when metadata has multiple rows with same variable", {
  # This test uses the (2) functions below to reduce code duplication
  # All `expect_*` are being called inside the functions