Merge pull request #84 from metrumresearchgroup/release/0.5.1

Release/0.5.1

DESCRIPTION

@@ -1,10 +1,18 @@
 Package: yspec
 Type: Package
 Title: Data Specification for Pharmacometrics
-Version: 0.5.0
+Version: 0.5.1
 Authors@R: c(
        person("Kyle T", "Baron", "", "kyleb@metrumrg.com", c("aut", "cre"), comment=c(ORCID="0000-0001-7252-5656")),
-       person("Metrum Research Group", role =  c("cph"))
+       person(given = "Katherine", 
+           family = "Kay",
+           role = "ctb",
+           email = "katherinek@metrumrg.com"),  
+       person(given = "Eric", 
+           family = "Anderson",
+           role = "ctb",
+           email = "andersone@metrumrg.com"),  
+       person("Metrum Research Group", role = "cph")
        )
 Maintainer: Kyle Baron <kyleb@metrumrg.com>
 URL: https://github.com/metrumresearchgroup/yspec
@@ -13,7 +21,6 @@ Description: Generate Define.pdf from yaml specification.
 License: GPL (>=2)
 Encoding: UTF-8
 Language: en-US
-LazyData: true
 Depends: R (>= 3.5.0)
 Imports: 
     yaml (>= 2.2),

NEWS.md

@@ -1,3 +1,20 @@
+# yspec 0.5.1
+
+- Fix bug where dots in lookup file were not properly inherited by spec
+  columns that didn't already have a dots list (#69)
+
+- Fix bug in namespace creation when multiple fields include namespace info
+  (#81)
+
+- Fix bug where specification document didn't properly render when using 
+  R 4.1 (#73)
+
+- `ys_add_factors()` now substitutes missing values (`NA`) with a character 
+  string supplied by the user prior to making the factor; the `decode` list 
+  is also updated so that the "missing" data is the last level; the string is 
+  supplied by the new argument `.missing` argument (#79)
+
+
 # yspec 0.5.0
 
 - `ys_select()` will now rename columns if new names are provided (#62)

R/class-yspec.R

@@ -132,7 +132,7 @@ yml_rm <- function(x) {
 
 ##' @export
 summary.yspec <- function(object, ...) {
-  out <- data.frame(col = seq_along(object), name=names(object))
+  out <- data.frame(col = seq_along(object), name = names(object), stringsAsFactors = FALSE)
   type <- map_chr(object, "type", .default = ".")
   out$c <- ifelse(type=="character", "+", "-")
   dec <- map(object, "decode") %>% unname %>% map_int(length)

R/col_factor.R

@@ -6,12 +6,15 @@
 #' @param ... unquoted column names for modification
 #' @param .all if `TRUE` then any column with a `values` attribute or  where 
 #' the `make_factor` field evaluates to `TRUE` will be added as a factor
+#' @param .missing a label to use assign to missing values `NA` when making 
+#' the factor; keep this `NULL` (the default) to let missing values be handled
+#' naturally by `factor()`
 #' @param .suffix used to make the column name for the factors
-#' @param values a vector of values to convert to a factor
-#' @param x a ycol object
 #' 
 #' @details
-#' Note that `.suffix` can be chosen using option `ys.fct.suffix`. 
+#' Note that `.suffix` can be chosen using option `ys.fct.suffix`. When the 
+#' factor is made by [base::factor()], the `exclude` argument is forced to 
+#' `character(0)` so that nothing is excluded.
 #' 
 #' @examples
 #' 
@@ -31,10 +34,11 @@
 #' @md
 #' @export
 ys_add_factors <- function(.data, .spec, ... , 
-                           .all = TRUE, 
+                           .all = TRUE, .missing = NULL,
                            .suffix = getOption("ys.fct.suffix","_f")) {
 
   assert_that(inherits(.spec, "yspec"))
+  assert_that(is.null(.missing) || is.character(.missing))
 
   fct_ok <- map_lgl(.spec, ~ isTRUE(.x[["make_factor"]]))
 
@@ -49,7 +53,12 @@ ys_add_factors <- function(.data, .spec, ... ,
 
   for(v in vars) {
     newcol <- paste0(v, .suffix)
-    .data[[newcol]] <- ys_make_factor(.data[[v]],.spec[[v]],strict=!fct_ok[[v]])
+    .data[[newcol]] <- ys_make_factor(
+      .data[[v]],
+      .spec[[v]],
+      strict=!fct_ok[[v]], 
+      .missing = .missing
+    )
   }
   .data
 }
@@ -58,10 +67,15 @@ ys_add_factors <- function(.data, .spec, ... ,
 #' @export
 yspec_add_factors <- ys_add_factors
 
-#' @param strict if `FALSE`, then an factor will be returned for any `values` type
+#' @param values a vector of values to convert to a factor
+#' @param x a ycol object
+#' @param strict if `FALSE`, then a factor will be returned for any `values` type
 #' @rdname ys_add_factors
 #' @export
-ys_make_factor <- function(values,x,strict=TRUE) {
+ys_make_factor <- function(values, x, strict = TRUE, .missing = NULL) {
+  if(is.factor(values)) {
+    return(values)
+  }
   if(is.null(x[["values"]])) {
     if(!strict) return(factor(values))
     stop("column: ", x[["col"]], " - values field is not found", call. = FALSE)
@@ -74,7 +88,12 @@ ys_make_factor <- function(values,x,strict=TRUE) {
   } else {
     decode <- x[["decode"]]  
   }
-  factor(values, levels = x[["values"]], labels = decode)
+  if(!is.null(.missing) && anyNA(values)) {
+    values[is.na(values)] <- .missing
+    x[["values"]] <- c(x[["values"]], .missing)
+    decode <- c(decode, .missing)
+  }
+  factor(values, levels = x[["values"]], labels = decode, exclude = character(0))
 }
 
 #' @rdname ys_add_factors

R/define.R

@@ -126,7 +126,7 @@ render_define <- function(x, ...) {
 ##' @export
 render_define.yproj <- function(x, 
                                 stem = "define_working",
-                                format = c("x_table_2", "x_table","x_table_long"),
+                                format = "x_table_2",
                                 output_format = "pdf_document",
                                 output_dir = getwd(),
                                 build_dir = definetemplate(),

R/exspec.R

@@ -37,8 +37,8 @@ file_proj_ex <- function(file = "project.yml") {
 # test_spec <- function(x) {
 #   ys_load(
 #     system.file(
-#       "spec", "testthat", 
-#       x, 
+#       "spec", "testthat",
+#       x,
 #       package = "yspec"
 #     )
 #   )

R/lookup.R

@@ -90,9 +90,16 @@ lookup_ysdb_file <- function(do = TRUE) {
 }
 
 merge_dots <- function(x, dots) {
-  if(!is.list(dots) || !is.list(x[["dots"]])) {
+  # nothing to merge
+  if(!is.list(dots)) {
     return(x)  
   }
+  # dots exist in lookup but not col - replace
+  if(!is.list(x[["dots"]])) {
+    x[["dots"]] <- dots
+    return(x)
+  }
+  # dots exist in lookup and in col - merge
   x[["dots"]] <- combine_list(dots, x[["dots"]])
   x
 }

R/namespace.R

@@ -52,7 +52,6 @@ list_namespaces <- function(x) {
 #' Find and process namespaced input
 #' 
 #' @param col a list of column data
-#' @param col_name the column name (character)
 #' 
 #' @keywords internal
 #' @noRd
@@ -72,16 +71,17 @@ list_namespaces <- function(x) {
 #' @return 
 #' `col` is returned with possibly an extra slot called `namespace` 
 #' 
-create_namespaces <- function(col, col_name) {
+create_namespaces <- function(col) {
   if(!is.list(col)) return(col)
-  if(.has("namespace", col)) return(col)
+  if(.has("namespace", col)) return(col) 
+  col_name <- col[["col"]]
   # see check_spec_input_col where we also split on `.` for ns information
   has_ns <- str_detect(names(col), fixed("."))
   if(!any(has_ns)) return(col)
   ns_input <- col[which(has_ns)]
   col <- col[which(!has_ns)]
   ns_parsed <- str_split_fixed(names(ns_input), fixed("."), 2)
-  namespace <- list()
+  namespace <- list(base = list())
   for(i in seq(nrow(ns_parsed))) {
     ns <- ns_parsed[i,2]
     field <- ns_parsed[i,1]
@@ -91,11 +91,11 @@ create_namespaces <- function(col, col_name) {
     namespace[[ns]][[field]] <- ns_input[[i]]
     namespace[["base"]][[field]] <- col[[field]]
     if(field == "decode") {
-      validate_namespace_decode(col_name, namespace)
+      validate_namespace_decode(col_name, namespace, ns)
     }
   }
   if(is.list(col[["namespace"]])) {
-    col[["namespace"]] <- combine_list(col[["namespace"]],namespace)
+    col[["namespace"]] <- combine_list(col[["namespace"]], namespace)
   } else {
     col[["namespace"]] <- namespace  
   }
@@ -104,8 +104,9 @@ create_namespaces <- function(col, col_name) {
 
 #' Validate namespaced decode information
 #' 
-#' @param col a list of column data 
+#' @param col_name a list of column data 
 #' @param namespace a list of namespaced column data
+#' @param ns name of the namespace to evaluate
 #' 
 #' @details
 #' Check to make sure that the number of `decode` values in a namespace entry
@@ -116,15 +117,14 @@ create_namespaces <- function(col, col_name) {
 #' 
 #' @keywords internal
 #' @noRd
-validate_namespace_decode <- function(col, namespace) {
+validate_namespace_decode <- function(col_name, namespace, ns) {
   expected <- length(namespace[["base"]][["decode"]])
-  ns <- names(namespace)
-  for(i in seq_along(ns)) {
+  for(i in ns) {
     if(length(namespace[[i]][["decode"]]) == expected) next
     found <- length(namespace[[i]][["decode"]])
     message("decode is not the correct length:")
-    message(" - column: ", col)
-    message(" - input:  ", paste0("decode.", ns[[i]]))
+    message(" - column: ", col_name)
+    message(" - input:  ", paste0("decode.", i))
     message(" - expect: ", expected)
     message(" - actual: ", found)
     stop(

inst/internal/analysis1.yml

@@ -12,7 +12,7 @@ C:
 NUM:
 ID:
 SUBJ: !look
-TIME:
+TIME: !look
   label: time after first dose
   unit: hour
 SEQ: 
@@ -65,8 +65,10 @@ CP: !look
 TAFD:
   short: time after first dose
   unit: hours
+  dots: {timecol: true}
 TAD:
   about: [time after dose, hours]
+  dots: {timecol: true}
 LDOS:
   short: last dose amount
   unit: mg

inst/internal/look.yml

@@ -3,3 +3,5 @@ SETUP__:
     covariate: [CP]
 CP: 
   dots: {updated_from_lookup: true, came_from_lookup: true} # used in test
+TIME: 
+  dots: {timecol: true}

inst/spec/test/namespace-multiple.yml

@@ -0,0 +1,13 @@
+TIME:
+  short: time
+  unit: hr
+STUDY: 
+  short: short base
+  short.plot: short plot
+  values: [1,2,3]
+  decode: ["Phase 1", "Phase 2", "Phase 3"]
+  decode.lc: [ "phase 1", "phase 2", "phase 3"]
+  decode.uc: ["PHASE 1", "PHASE 2", "PHASE 3"]
+HT: 
+  short: height
+  unit: cm

tests/testthat/test-col_factor.R

@@ -52,3 +52,13 @@ test_that("ys_add_factors aliases yspec_add_factors", {
   expect_identical(a,b)
 })
 
+test_that("NA handling by ys_add_factors", {
+  dat1 <- ys_help$data()
+  sp <- ys_help$spec()
+  dat1$RF[c(3,10,30)] <- NA_character_
+  dat2 <- dat1
+  a <- yspec_add_factors(dat1, sp, RF)
+  expect_identical(levels(a$RF_f), sp$RF$decode)
+  b <- yspec_add_factors(dat2, sp, RF, .missing = "Missing")
+  expect_identical(levels(b$RF_f), c(sp$RF$decode, "Missing"))
+})

tests/testthat/test-lookup.R

@@ -21,12 +21,23 @@ test_that("lookup without internal db", {
   file <- system.file("spec", "lookup", "spec_nodb.yml",package = "yspec")
   expect_warning(ys_load(file), "not find lookup data for AGE")
   spec <- suppressWarnings(ys_load(file))
-  expect_equal(spec$A$values,1)
-  expect_equal(spec$B$values,2)
-  expect_equal(spec$C$short,"lookup")
-  expect_equal(spec$D$short,"lookup")
-  expect_equal(spec$E$short,"F")
+  expect_equal(spec$A$values, 1)
+  expect_equal(spec$B$values, 2)
+  expect_equal(spec$C$short, "lookup")
+  expect_equal(spec$D$short, "lookup")
+  expect_equal(spec$E$short, "F")
   expect_equal(spec$WT$short, "wait")
 })
 
-
+# issue #69
+test_that("dots are inherited when dots aren't already existing", {
+  spec <- ys_help$spec()
+  yam <- yaml::yaml.load_file(ys_help$file())
+  expect_is(yam$TIME$dots, "NULL")
+  expect_is(spec$TIME$dots, "list")
+  expect_is(spec$TIME$dots$timecol, "logical")
+  spect <- as.data.frame(ys_filter(spec, isTRUE(timecol)))
+  expect_equal(nrow(spect), 3)
+  expect_equal(spect$name, c("TIME", "TAFD", "TAD"))
+  expect_equal(spect$source, c("look.yml", ".", "."))
+})