Merge pull request #32 from atorus-research/order_fix

fix order variable. Closes #8

.Rbuildignore

@@ -16,3 +16,5 @@
 ^xportr.*\.tar\.gz$
 ^xportr.*\.tgz$
 ^dev$
+^advs\.xpt$
+^advs_Define-Excel-Spec_match_admiral\.xlsx

NAMESPACE

@@ -41,6 +41,7 @@ importFrom(glue,glue_collapse)
 importFrom(graphics,stem)
 importFrom(janitor,make_clean_names)
 importFrom(magrittr,"%>%")
+importFrom(magrittr,extract2)
 importFrom(purrr,map)
 importFrom(purrr,map2_chr)
 importFrom(purrr,map_chr)
@@ -52,6 +53,7 @@ importFrom(stringr,str_extract)
 importFrom(stringr,str_replace)
 importFrom(stringr,str_replace_all)
 importFrom(tidyselect,all_of)
+importFrom(tidyselect,any_of)
 importFrom(tm,stemDocument)
 importFrom(utils,capture.output)
 importFrom(utils,packageVersion)

R/order.R

@@ -46,16 +46,18 @@ xportr_order <- function(.df, metacore, domain = NULL, verbose = getOption("xpor
   }
 
   # Grabs vars from Spec and inputted dataset
-  vars_in_spec_ds <- metadata[[variable_name]]
+  vars_in_spec_ds <- metadata[, c(variable_name, order_name)] %>%
+    arrange(!!sym(order_name)) %>%
+    extract2(variable_name)
 
+  vars_in_spec_ds <- vars_in_spec_ds[!is.na(vars_in_spec_ds)]
   # Grabs all variables from Spec file and orders accordingly
   ord_vars <- .df %>% 
-    select(all_of(vars_in_spec_ds)) %>%
-    arrange(!!sym(order_name))
+    select(any_of(vars_in_spec_ds))
 
   # Variables not in Spec file - will be moved to the end
   drop_vars <- .df %>% 
-    select(!all_of(vars_in_spec_ds))
+    select(!any_of(vars_in_spec_ds))
 
   # Used in warning message for how many vars have been moved
   moved_vars <- nrow(drop_vars)

R/utils-xportr.R

@@ -171,6 +171,6 @@ get_pipe_call <- function() {
 first_class <- function(x) {
   characterTypes <- getOption("xportr.character_types")
   class_ <- class(x)[1]
-  if(class_ %in% characterTypes) "character"
+  if (class_ %in% characterTypes) "character"
   else class_
 }

R/write.R

@@ -19,10 +19,6 @@
 #'
 #' @return A data frame. `write_xport()` returns the input data invisibly.
 #' @export
-#'
-#' @examples
-#' tmp <- file.path(tempdir(), "mtcars.xpt")
-#' xportr_write(mtcars, tmp)
 xportr_write <- function(.df, path, label = NULL) {
 
   path <- normalizePath(path, mustWork = FALSE)
@@ -55,10 +51,9 @@ xportr_write <- function(.df, path, label = NULL) {
 
   checks <- xpt_validate(.df)
 
-  # if (length(checks) > 0) {
-  #   names(checks) <- rep("x", length(checks))
-  #   abort(c("The following validation failed:", checks))
-  # }
+  if (length(checks) > 0) {
+    abort(c("The following validation failed:", checks))
+  }
 
 
   # `write.xport` supports only the class data.frame

R/xportr-package.R

@@ -11,14 +11,15 @@
 #' @importFrom glue glue glue_collapse
 #' @importFrom cli cli_alert_info cli_h2 cli_alert_success cli_alert_info
 #'   cli_div cli_alert_success cli_text cli_h2
-#' @importFrom tidyselect all_of
+#' @importFrom tidyselect all_of any_of
 #' @importFrom utils capture.output str tail packageVersion
 #' @importFrom stringr str_detect str_extract str_replace str_replace_all
 #' @importFrom readr parse_number
 #' @importFrom purrr map_chr map2_chr
 #' @importFrom janitor make_clean_names
 #' @importFrom tm stemDocument
 #' @importFrom graphics stem
+#' @importFrom magrittr extract2
 "_PACKAGE"
 
 globalVariables(c("abbr_parsed", "abbr_stem", "adj_orig", "adj_parsed", "col_pos", "dict_varname",

tests/testthat/test-length.R

@@ -0,0 +1,15 @@
+suppressWarnings({
+  library(haven)
+  library(readxl)
+})
+
+test_that("Domain not in character format", {
+
+  ADAE <- read_sas(system.file("extdata", "adae.sas7bdat", package = "xportr"))
+  met <- read_excel(system.file("specs", "ADaM_spec.xlsx", package = "xportr"), 3)
+
+  expect_error(
+       xportr_length(ADAE, metacore = met, domain = ADAE, verbose = "none")
+    )
+
+})

tests/testthat/test-order.R

@@ -0,0 +1,45 @@
+# library(dplyr)
+suppressWarnings({
+  library(haven)
+  library(readxl)
+})
+
+# 
+# #context("xportr_seq correctly order dataset according to spec")
+#
+
+test_that("Variable are ordered correctly", {
+
+  ADAE <- read_sas(system.file("extdata", "adae.sas7bdat", package = "xportr"))
+  met <- read_excel(system.file("specs", "ADaM_spec.xlsx", package = "xportr"), 3)
+
+  withr::with_options(
+    list(xportr.order_name = "Order", xportr.variable_name = "Variable"), {
+      ADAE_xportr <- xportr_order(ADAE, metacore = met, "ADAE", verbose = "none")
+    }
+  )
+
+  after_names <- c("STUDYID", "USUBJID", "AEDECOD", "AESOC", "AETERM", "AESER", 
+                   "ASTDT", "AENDT", "ATOXGR", "TRT01A", "TRT01AN", "SAFFL", "SUBJID", 
+                   "WEIGHTBL", "SEX", "AGE", "AGEU", "RACE", "SITEID", "RACEN", 
+                   "ASTTM", "ADURC", "AEACN", "AEOUT", "AEREL", "ATOXGRN", "AFTRTSTC", 
+                   "AEWDFL")
+
+  expect_equal(names(ADAE_xportr), after_names)
+})
+
+test_that("Domain not in character format", {
+
+  ADAE <- read_sas(system.file("extdata", "adae.sas7bdat", package = "xportr"))
+  met <- read_excel(system.file("specs", "ADaM_spec.xlsx", package = "xportr"), 3)
+
+  expect_error(
+    withr::with_options(
+    list(xportr.order_name = "Order", xportr.variable_name = "Variable"), {
+      ADAE_xportr <- xportr_order(ADAE, metacore = met, domain = ADAE, verbose = "none")
+    }
+  ))
+
+
+})
+

tests/testthat/test-write.R

@@ -5,12 +5,12 @@ test_that("SAS Transport file", {
 
   on.exit(unlink(tmpdir))
 
-  df <- data.frame(x = c(1, 2, NA), y = c("a", "", "c"), z = c(1, 2, 3))
+  df <- data.frame(X = c(1, 2, NA), Y = c("a", "", "c"), Z = c(1, 2, 3))
 
   #SASxport::SASformat(df$x, "format") <- "date7."
-  attr(df$x, "label") <- "foo"
-  attr(df$y, "label") <- "bar"
-  attr(df$z, "label") <- "baz"
+  attr(df$X, "label") <- "foo"
+  attr(df$Y, "label") <- "bar"
+  attr(df$Z, "label") <- "baz"
 
   xportr_write(df, path = tmp)
   #expect_output(str(read_xpt(tmp)), "$ X: labelled, format", fixed =TRUE)
@@ -32,3 +32,18 @@ test_that("SAS Transport file", {
   #   xportr_write(df, tmp),
   #   "Truncated 1 long names to 8 characters.")
 })
+
+test_that("Error message given if variable is greater than 8 characters",{
+
+  tmpdir <- tempdir()
+  tmp <- file.path(tmpdir, "abc.xpt")
+
+  on.exit(unlink(tmpdir))
+
+  df <- data.frame(a123456789 = c(1, 2, NA),
+                   ab123456789 = c("a", "", "c"),
+                   abc123456789 = c(1, 2, 3))
+
+  expect_error(xportr_write(df, path = tmp))
+
+})