diff --git a/DESCRIPTION b/DESCRIPTION index 1a10839..1c19185 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: metacore Title: A Centralized Metadata Object Focus on Clinical Trial Data Programming Workflows -Version: 0.2.1 +Version: 0.3.0 Authors@R: c( person("Liam", "Hobby", , "liam.f.hobby@gsk.com", role = c("aut", "cre")), person("Christina", "Fillmore", , "christina.e.fillmore@gsk.com", role = "aut", diff --git a/NEWS.md b/NEWS.md index b96dda3..d743312 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,7 @@ +# Metacore 0.3.0 +- Added extended function of `quiet` argument in `spec_to_metacore()`, `define_to_metacore()`, and `select_dataset` functions to suppress optional messages, notes and warnings [#122](https://github.com/atorus-research/metacore/issues/122) +- `keep` variable in `ds_vars` table has been changed to `mandatory` to better reflect the CDISC standard terminology. + # Metacore 0.2.1 - Hotfix import `cli_alert_info` issue from {cli} package. diff --git a/R/metacore.R b/R/metacore.R index d96e585..7567206 100644 --- a/R/metacore.R +++ b/R/metacore.R @@ -22,46 +22,46 @@ MetaCore_initialize <- function(ds_spec, ds_vars, var_spec, value_spec, derivati private$.ds_spec <- ds_spec %>% add_labs(dataset = "Dataset Name", - structure = "Value Structure", - label = "Dataset Label") + structure = "Value Structure", + label = "Dataset Label") private$.ds_vars <- ds_vars %>% add_labs(dataset = "Dataset Name", - variable = "Variable Name", - key_seq = "Sequence Key", - order = "Variable Order", - keep = "Keep (Boolean)", - core = "ADaM core (Expected, Required, Permissible)", - supp_flag = "Supplemental Flag") + variable = "Variable Name", + key_seq = "Sequence Key", + order = "Variable Order", + mandatory = "Mandatory (Boolean)", + core = "ADaM core (Expected, Required, Permissible)", + supp_flag = "Supplemental Flag") private$.var_spec <- var_spec %>% add_labs(variable = "Variable Name", - length = "Variable Length", - label = "Variable Label", - type = "Variable Class", - common = "Common Across ADaM", - format = "Variable Format") + length = "Variable Length", + label = "Variable Label", + type = "Variable Class", + common = "Common Across ADaM", + format = "Variable Format") private$.value_spec <- value_spec %>% add_labs(type = "Value Type", - orgin = "Origin of Value", - code_id = "ID of the Code List", - dataset = "Dataset Name", - variable = "Variable Name", - where = "Value of the Variable", - derivation_id = "ID of Derivation") %>% + orgin = "Origin of Value", + code_id = "ID of the Code List", + dataset = "Dataset Name", + variable = "Variable Name", + where = "Value of the Variable", + derivation_id = "ID of Derivation") %>% mutate(origin = str_to_lower(.data$origin)) private$.derivations <- derivations %>% add_labs(derivation_id = "ID of Derivation", - derivation = "Derivation") + derivation = "Derivation") private$.codelist <- codelist %>% add_labs(code_id = "ID of the Code List", - names = "Name of the Code List", - type = "Code List/Permitted Values/External Library", - codes = "List of Codes") + names = "Name of the Code List", + type = "Code List/Permitted Values/External Library", + codes = "List of Codes") private$.codelist <- codelist %>% add_labs(code_id = "ID of the Code List", @@ -80,8 +80,14 @@ MetaCore_initialize <- function(ds_spec, ds_vars, var_spec, value_spec, derivati private$.ds_names <- ds_spec %>% pull(dataset) private$.ds_labels <- ds_spec %>% pull(label) + if(quiet){ + suppressWarnings(self$validate()) + } + else { + self$validate() + } + - self$validate() if (inherits_only(self, c("Metacore", "R6"))) { private$.greet(quiet) } } @@ -115,14 +121,14 @@ MetaCore_validate <- function() { if(var_name_check(private)){ if(nrow(private$.ds_spec) == 0 & - nrow(private$.ds_vars) == 0 & - nrow(private$.var_spec) == 0 & - nrow(private$.value_spec) == 0 & - nrow(private$.derivations) == 0 & - nrow(private$.codelist) == 0 & - nrow(private$.supp) == 0 ){ + nrow(private$.ds_vars) == 0 & + nrow(private$.var_spec) == 0 & + nrow(private$.value_spec) == 0 & + nrow(private$.derivations) == 0 & + nrow(private$.codelist) == 0 & + nrow(private$.supp) == 0 ){ cli_warn("Other checks were not preformed, because all datasets are empty", - call. = FALSE) + call. = FALSE) } else { check_columns(private$.ds_spec, private$.ds_vars, @@ -145,7 +151,7 @@ MetaCore_validate <- function() { } else { cli_warn("Other checks were not preformed, because column names were incorrect", - call. = FALSE) + call. = FALSE) } } @@ -228,85 +234,85 @@ MetaCore_filter <- function(value) { #' @noRd # MetaCore <- R6::R6Class("Metacore", - public = list( - initialize = MetaCore_initialize, - print = MetaCore_print, - validate = MetaCore_validate, - metacore_filter = MetaCore_filter - ), - - private = list( - .ds_spec = tibble( - dataset = character(), - structure = character(), - label = character() - ), - .ds_vars = tibble( - dataset = character(), - variable = character(), - keep = logical(), - key_seq = integer(), - order = integer(), - core = character(), - supp_flag = logical() - ), - .var_spec = tibble( - variable = character(), - label = character(), - length = integer(), - type = character(), - common = character(), - format = character() - ), - .value_spec = tibble( - dataset = character(), - variable = character(), - where = character(), - type = character(), - sig_dig = integer(), - code_id = character(), - origin = character(), - derivation_id = integer() - ), - .derivations = tibble( - derivation_id = integer(), - derivation = character() - ), - # code_type == df | permitted_val | external_lib - .codelist = tibble( - code_id = character(), - name = character(), - type = character(), - codes = list() - ), - .supp = tibble( - dataset = character(), - variable = character(), - idvar = character(), - qeval = character() - ), - .ds_len = NA, - .ds_names = list(), - .ds_labels = list(), - - .greet = function(quiet = FALSE) { - cli_par() - cli_alert_success("Metadata successfully imported") - if (quiet) cli_inform(c("i" = col_red("Dataset metadata imported with suppressed warnings"))) - cli_inform(c("i" = "To use the {.obj Metacore} object with {.pkg metatools} package, first subset a dataset using {.fn metacore::select_dataset}")) - cli_end() - } - ), - - active = list( - ds_spec = readonly('ds_spec'), - ds_vars = readonly('ds_vars'), - var_spec = readonly('var_spec'), - value_spec = readonly('value_spec'), - derivations = readonly('derivations'), - codelist = readonly('codelist'), - supp = readonly('supp') - ) + public = list( + initialize = MetaCore_initialize, + print = MetaCore_print, + validate = MetaCore_validate, + metacore_filter = MetaCore_filter + ), + + private = list( + .ds_spec = tibble( + dataset = character(), + structure = character(), + label = character() + ), + .ds_vars = tibble( + dataset = character(), + variable = character(), + mandatory = logical(), + key_seq = integer(), + order = integer(), + core = character(), + supp_flag = logical() + ), + .var_spec = tibble( + variable = character(), + label = character(), + length = integer(), + type = character(), + common = character(), + format = character() + ), + .value_spec = tibble( + dataset = character(), + variable = character(), + where = character(), + type = character(), + sig_dig = integer(), + code_id = character(), + origin = character(), + derivation_id = integer() + ), + .derivations = tibble( + derivation_id = integer(), + derivation = character() + ), + # code_type == df | permitted_val | external_lib + .codelist = tibble( + code_id = character(), + name = character(), + type = character(), + codes = list() + ), + .supp = tibble( + dataset = character(), + variable = character(), + idvar = character(), + qeval = character() + ), + .ds_len = NA, + .ds_names = list(), + .ds_labels = list(), + + .greet = function(quiet = FALSE) { + cli_par() + cli_alert_success("Metadata successfully imported") + if (quiet) cli_inform(c("i" = col_red("Dataset metadata imported with suppressed warnings"))) + cli_inform(c("i" = "To use the {.obj Metacore} object with {.pkg metatools} package, first subset a dataset using {.fn metacore::select_dataset}")) + cli_end() + } + ), + + active = list( + ds_spec = readonly('ds_spec'), + ds_vars = readonly('ds_vars'), + var_spec = readonly('var_spec'), + value_spec = readonly('value_spec'), + derivations = readonly('derivations'), + codelist = readonly('codelist'), + supp = readonly('supp') + ) ) @@ -326,56 +332,75 @@ MetaCore <- R6::R6Class("Metacore", #' #' @export #' -metacore <- function(ds_spec = tibble(dataset = character(), structure = character(), label = character()), - ds_vars = tibble(dataset = character(), variable = character(), keep = logical(), - key_seq = integer(), order = integer(), core = character(), - supp_flag = logical()), - var_spec = tibble(variable = character(), label = character(), length = integer(), - type = character(), common = character(), format = character()), - value_spec = tibble(dataset = character(), - variable = character(), - where = character(), - type = character(), - sig_dig = integer(), - code_id = character(), - origin = character(), - derivation_id = integer()), - derivations = tibble(derivation_id = integer(), derivation = character()), - codelist = tibble(code_id = character(), name = character(), type = character(), codes = list()), - supp = tibble(dataset = character(), variable = character(), idvar = character(), qeval = character()), - quiet = FALSE) { - # Check if there are any empty datasets that need adding - is_empty_df <- as.list(environment()) %>% - keep(is.null) - if(length(is_empty_df) > 0) { - # Adding empty datasets - to_replace <- all_message() %>% - #get the type each variable needs to be - mutate(convert = - map(.data$test, function(x){ - if(identical(x, .Primitive("is.numeric"))){ - numeric() - } else if(identical(x, .Primitive("is.logical"))){ - logical() - } else { - character() - } - })) %>% - filter(dataset %in% names(is_empty_df)) %>% - group_by(dataset) %>% - group_split() - replaced <- to_replace %>% - map(function(df){ - names(df$convert) <- df$var - df$convert %>% - as_tibble() - }) - names(replaced) <- to_replace %>% map_chr(~unique(.$dataset)) - list2env(replaced, environment()) +metacore <- function( + ds_spec = tibble(dataset = character(), structure = character(), label = character()), + ds_vars = tibble(dataset = character(), variable = character(), mandatory = logical(), + key_seq = integer(), order = integer(), core = character(), + supp_flag = logical()), + var_spec = tibble(variable = character(), label = character(), length = integer(), + type = character(), common = character(), format = character()), + value_spec = tibble(dataset = character(), + variable = character(), + where = character(), + type = character(), + sig_dig = integer(), + code_id = character(), + origin = character(), + derivation_id = integer()), + derivations = tibble(derivation_id = integer(), derivation = character()), + codelist = tibble(code_id = character(), name = character(), type = character(), codes = list()), + supp = tibble(dataset = character(), variable = character(), idvar = character(), qeval = character()), + quiet = FALSE +) { + + test <- quiet_if_true({ + + is_empty_df <- as.list(environment()) %>% + keep(is.null) + + if (length(is_empty_df) > 0) { + to_replace <- all_message() %>% + mutate( + convert = map(.data$test, function(x) { + if (identical(x, .Primitive("is.numeric"))) { + numeric() + } else if (identical(x, .Primitive("is.logical"))) { + logical() + } else { + character() + } + }) + ) %>% + filter(.data$dataset %in% names(is_empty_df)) %>% + group_by(.data$dataset) %>% + group_split() + + replaced <- to_replace %>% + map(function(df) { + names(df$convert) <- df$var + df$convert %>% + as_tibble() + }) + + names(replaced) <- to_replace %>% map_chr(~ unique(.x$dataset)) + list2env(replaced, environment()) } - MetaCore$new(ds_spec, ds_vars, var_spec, value_spec, derivations, codelist, supp, quiet) -} + MetaCore$new( + ds_spec = ds_spec, + ds_vars = ds_vars, + var_spec = var_spec, + value_spec = value_spec, + derivations = derivations, + codelist = codelist, + supp = supp, + quiet = quiet + ) + + }, quiet = quiet) + + if (quiet) invisible(test) else test +} #' Select metacore object to single dataset @@ -388,14 +413,14 @@ metacore <- function(ds_spec = tibble(dataset = character(), structure = charact #' #' @return a filtered subset of the metacore object #' @export -#' select_dataset <- function(.data, dataset, simplify = FALSE, quiet = FALSE) { cl <- .data$clone() cl$metacore_filter(dataset) if (simplify) { - test <- suppressMessages( + + test <- quiet_if_true({ list( cl$ds_vars, cl$var_spec, @@ -405,13 +430,19 @@ select_dataset <- function(.data, dataset, simplify = FALSE, quiet = FALSE) { cl$supp ) %>% reduce(left_join) - ) + }, quiet = quiet) + } else { - if (!quiet) DatasetMeta$new(metacore = cl) - else suppressWarnings(DatasetMeta$new(metacore = cl, quiet = quiet)) + + test <- quiet_if_true( + DatasetMeta$new(metacore = cl, quiet = quiet), + quiet = quiet + ) + } -} + if (quiet) invisible(test) else test +} #' Get Control Term @@ -528,14 +559,14 @@ save_metacore <- function(metacore_object, path = NULL) { nm <- deparse(substitute(metacore_object)) path <- paste0(nm, ".rds") - # check the suffix of the path + # check the suffix of the path } else { suffix <- str_extract(path, "\\.\\w*$") # if the extension is .rda keep it if (suffix == ".rds") { path <- path - # otherwise we need to replace it with .rda + # otherwise we need to replace it with .rda } else { prefix <- str_remove(path, "\\.\\w*$") path <- paste0(prefix, ".rds") @@ -557,7 +588,7 @@ load_metacore <- function(path = NULL) { cli_abort("please supply path to metacore object ending with extension .rds", call. = FALSE) } else { cli_abort("metacore object path required, did you mean:", - paste(" ", rdss, sep = "\n "), call. = FALSE) + paste(" ", rdss, sep = "\n "), call. = FALSE) } } readRDS(path) diff --git a/R/spec_builder.R b/R/spec_builder.R index bbac8f1..9f1c875 100644 --- a/R/spec_builder.R +++ b/R/spec_builder.R @@ -6,36 +6,52 @@ #' be used as building blocks for bespoke specification documents. #' #' @param path string of file location -#' @param quiet Option to quietly load in, this will suppress warnings, but not -#' errors +#' @param quiet Option to quietly load in; when `TRUE`, messages, warnings, +#' and other non-error console output are suppressed, but errors are still +#' raised. #' @param where_sep_sheet Option to tell if the where is in a separate sheet, #' like in older p21 specs or in a single sheet like newer p21 specs #' #' @return given a spec document it returns a metacore object #' @export spec_to_metacore <- function(path, quiet = FALSE, where_sep_sheet = TRUE){ - doc <- read_all_sheets(path) - - if(spec_type(path) == "by_type"){ - ds_spec <- spec_type_to_ds_spec(doc) - ds_vars <- spec_type_to_ds_vars(doc) - var_spec <- spec_type_to_var_spec(doc) - value_spec <- spec_type_to_value_spec(doc, where_sep_sheet = where_sep_sheet) - derivations <- spec_type_to_derivations(doc) - code_list <- spec_type_to_codelist(doc) - if(!quiet){ - out <- metacore(ds_spec, ds_vars, var_spec, value_spec, derivations, codelist = code_list) - } else{ - out<- suppressWarnings(metacore(ds_spec, ds_vars, var_spec, value_spec, derivations, codelist = code_list, quiet = quiet)) - } + + doc <- quiet_if_true(read_all_sheets(path), quiet = quiet) + + if (quiet_if_true(spec_type(path), quiet = quiet) == "by_type") { + + ds_spec <- quiet_if_true(spec_type_to_ds_spec(doc), quiet = quiet) + ds_vars <- quiet_if_true(spec_type_to_ds_vars(doc), quiet = quiet) + var_spec <- quiet_if_true(spec_type_to_var_spec(doc), quiet = quiet) + value_spec <- quiet_if_true( + spec_type_to_value_spec(doc, where_sep_sheet = where_sep_sheet), + quiet = quiet + ) + derivations <- quiet_if_true(spec_type_to_derivations(doc), quiet = quiet) + code_list <- quiet_if_true(spec_type_to_codelist(doc), quiet = quiet) + + test <- quiet_if_true( + metacore( + ds_spec, + ds_vars, + var_spec, + value_spec, + derivations, + codelist = code_list, + quiet = quiet + ), + quiet = quiet + ) + } else { - cli_abort("This specification format is not currently supported. You will need to write your own reader", - call. = FALSE) + cli_abort( + "This specification format is not currently supported. You will need to write your own reader", + call. = FALSE + ) } - out -} - + if (quiet) invisible(test) else test +} #' Check the type of spec document @@ -49,14 +65,14 @@ spec_type <- function(path){ sheets <- excel_sheets(path) if(!any(sheets %>% str_detect("[D|d]omains?|[D|d]atasets?"))){ cli_abort("File does not contain a Domain/Datasets tab, which is needed. Please either modify the spec document or write a reader (see documentation for more information)", - call. = FALSE) + call. = FALSE) } else if(any(sheets %>% str_detect("ADSL|DM"))){ type <- "by_ds" } else if(any(sheets %>% str_detect("[V|v]ariables?"))){ type <- "by_type" } else { cli_abort("File in an unknown format. Please either modify the spec document or write a reader (see documentation for more information)", - call. = FALSE) + call. = FALSE) } type } @@ -145,14 +161,14 @@ spec_type_to_ds_spec <- function(doc, cols = c("dataset" = "[N|n]ame|[D|d]ataset spec_type_to_ds_vars <- function(doc, cols = c("dataset" = "[D|d]ataset|[D|d]omain", "variable" = "[V|v]ariable [[N|n]ame]?|[V|v]ariables?", "order" = "[V|v]ariable [O|o]rder|[O|o]rder", - "keep" = "[K|k]eep|[M|m]andatory"), + "mandatory" = "[K|k]eep|[M|m]andatory"), key_seq_sep_sheet = TRUE, key_seq_cols = c("dataset" = "Dataset", "key_seq" = "Key Variables"), sheet = "[V|v]ar|Datasets"){ name_check <- names(cols) %in% c("variable", "dataset", "order", - "keep", "key_seq", "core", "supp_flag") %>% + "mandatory", "key_seq", "core", "supp_flag") %>% all() name_check_extra <- names(key_seq_cols) %in% c("dataset", "key_seq") %>% @@ -162,7 +178,7 @@ spec_type_to_ds_vars <- function(doc, cols = c("dataset" = "[D|d]ataset|[D|d]oma # Testing for names of vectors if(any(!name_check, !name_check_extra, is.null(names(cols)))){ cli_abort("Supplied column vector must be named using the following names: - 'variable', 'dataset', 'order', 'keep', 'core', 'key_seq', 'supp_flag'") + 'variable', 'dataset', 'order', 'mandatory', 'core', 'key_seq', 'supp_flag'") } # Subsetting sheets if(!is.null(sheet)){ @@ -193,10 +209,10 @@ spec_type_to_ds_vars <- function(doc, cols = c("dataset" = "[D|d]ataset|[D|d]oma out %>% distinct() %>% `is.na<-`(missing) %>% - mutate(key_seq = as.integer(key_seq), - keep = yn_to_tf(keep), - core = as.character(core), - order = as.numeric(order)) + mutate(key_seq = as.integer(.data$key_seq), + mandatory = yn_to_tf(.data$mandatory), + core = as.character(.data$core), + order = as.numeric(.data$order)) } @@ -343,7 +359,7 @@ spec_type_to_value_spec <- function(doc, cols = c("dataset" = "[D|d]ataset|[D|d] "i" = "'dataset', 'variable', 'origin', 'code_id', 'type', 'where', 'sig_dig', 'derivation_id','predecessor'", "i" = paste("If derivation_id is not avaliable it can be excluded and dataset.variable will be used.", "If the where information is on a seperate sheet, put the column with cross ref as where.") - ), call = FALSE) + ), call = FALSE) } # Select a subset of sheets if specified @@ -405,16 +421,16 @@ spec_type_to_value_spec <- function(doc, cols = c("dataset" = "[D|d]ataset|[D|d] left_join(where_df, by = c("where" = "id")) %>% select(-where, where = where_new) } else if(where_sep_sheet) { - cli_warn("Not able to add where infromation from seperate sheet cause a where column is needed to cross-reference the information", - call. = FALSE) + cli_warn("Not able to add where information from seperate sheet cause a where column is needed to cross-reference the information", + call. = FALSE) } if(!"derivation_id" %in% names(cols)){ out <- out %>% mutate(derivation_id = if_else(str_to_lower(.data$origin) == "assigned", - paste0(dataset, ".", variable), - paste0("pred.", dataset, ".", variable))) + paste0(dataset, ".", variable), + paste0("pred.", dataset, ".", variable))) } # Get missing columns @@ -478,7 +494,7 @@ spec_type_to_codelist <- function(doc, codelist_cols = c("code_id" = "ID", if(!name_check| is.null(names(codelist_cols))){ cli_abort("Supplied column vector for codelist_cols must be named using the following names: 'code_id', 'name', 'code', 'decode'", - call. = FALSE + call. = FALSE ) } } @@ -489,7 +505,7 @@ spec_type_to_codelist <- function(doc, codelist_cols = c("code_id" = "ID", if(!name_check){ cli_abort("Supplied column vector for permitted_val_cols must be named using the following names: 'code_id', 'name', 'code'", - call. = FALSE) + call. = FALSE) } } if(!is.null(dict_cols)){ @@ -571,9 +587,9 @@ spec_type_to_derivations <- function(doc, cols = c("derivation_id" = "ID", sheet = "Method|Derivations?", var_cols = c("dataset" = "[D|d]ataset|[D|d]omain", "variable" = "[N|n]ame|[V|v]ariables?", - "origin" = "[O|o]rigin", - "predecessor" = "[P|p]redecessor", - "comment" = "[C|c]omment")){ + "origin" = "[O|o]rigin", + "predecessor" = "[P|p]redecessor", + "comment" = "[C|c]omment")){ name_check <- names(cols) %in% c("derivation_id", "derivation") %>% all() @@ -615,7 +631,7 @@ spec_type_to_derivations <- function(doc, cols = c("derivation_id" = "ID", str_to_lower(.data$origin) == "predecessor" ~ paste0("pred.", as.character(.data$predecessor)), str_to_lower(.data$origin) == "assigned" ~ paste0(.data$dataset, ".", .data$variable), TRUE ~ NA_character_ - ), + ), derivation = case_when( str_to_lower(.data$origin) == "predecessor" ~ as.character(.data$predecessor), str_to_lower(.data$origin) == "assigned" ~ .data$comment, @@ -688,7 +704,7 @@ create_tbl <- function(doc, cols){ }) %>% paste0(collapse = "\n") %>% paste0("Unable to identify a sheet with all columns.\n", . ) %>% - (call. = FALSE) + (call. = FALSE) } else if(length(matches) == 1){ # Check names and write a better warning message if names don't work @@ -751,7 +767,7 @@ yn_to_tf <- function(x){ x } else { cli_warn("Keep column needs to be True or False, please correct before converting to a Metacore object", - call. = FALSE) + call. = FALSE) x } } diff --git a/R/utils.R b/R/utils.R index bb0116b..9864a78 100644 --- a/R/utils.R +++ b/R/utils.R @@ -120,3 +120,17 @@ metacore_example <- function(file = NULL) { system.file("extdata", file, package = "metacore", mustWork = TRUE) } } + +#' Conditionally suppress messages and warnings +#' @keywords internal +quiet_if_true <- function(expr, quiet = FALSE) { + if (isTRUE(quiet)) { + suppressWarnings( + suppressMessages( + force(expr) + ) + ) + } else { + force(expr) + } +} diff --git a/R/validators.R b/R/validators.R index fb3bbcb..298006e 100644 --- a/R/validators.R +++ b/R/validators.R @@ -194,7 +194,7 @@ supp_check <- function(ds_vars, supp){ #' @noRd col_vars <- function(){ list(.ds_spec = c("dataset", "structure", "label"), - .ds_vars = c("dataset", "variable", "key_seq", "order","keep", "core", "supp_flag"), + .ds_vars = c("dataset", "variable", "key_seq", "order","mandatory", "core", "supp_flag"), .var_spec = c("variable", "length", "label", "type", "common", "format"), .value_spec = c("dataset", "variable", "type", "origin","sig_dig", "code_id", "where", "derivation_id"), .derivations = c("derivation_id", "derivation"), @@ -259,7 +259,7 @@ all_message <- function() { "ds_vars", "variable", is.character, FALSE, "ds_vars", "key_seq", is.numeric, TRUE, "ds_vars", "order", is.numeric, TRUE, - "ds_vars", "keep", is.logical, TRUE, + "ds_vars", "mandatory", is.logical, TRUE, "ds_vars", "core", check_words("Expected", "Required", "Permissible", "Conditionally Required", "Conditionally Expected", NA), TRUE, "ds_vars", "supp_flag", is.logical, TRUE, "var_spec", "variable", is.character, FALSE, diff --git a/R/xml_builders.R b/R/xml_builders.R index 7981a86..0955389 100644 --- a/R/xml_builders.R +++ b/R/xml_builders.R @@ -1,38 +1,46 @@ #' Define XML to DataDef Object #' -#' Given a path, this function converts the define xml to a DataDef Object +#' Given a path, this function converts the define xml to a DataDef/Metacore object. #' #' @param path location of the define xml as a string -#' @param quiet Option to quietly load in, this will suppress warnings, but not errors +#' @param quiet Option to quietly load in; when `TRUE`, messages and warnings +#' are suppressed, but errors are still raised. #' -#' @return DataDef Object +#' @return Metacore/DataDef object #' @export -#' define_to_metacore <- function(path, quiet = FALSE){ - xml <- read_xml(path) - xml_ns_strip(xml) - - define_version <- xml_find_all(xml, "//MetaDataVersion") %>% - xml_attr("DefineVersion") %>% - as.numeric_version() + test <- quiet_if_true({ + + xml <- read_xml(path) + xml_ns_strip(xml) + + define_version <- xml_find_all(xml, "//MetaDataVersion") %>% + xml_attr("DefineVersion") %>% + as.numeric_version() + + ds_spec <- xml_to_ds_spec(xml) + ds_vars <- xml_to_ds_vars(xml) + var_spec <- xml_to_var_spec(xml) + value_spec <- xml_to_value_spec(xml) + code_list <- xml_to_codelist(xml) + derivations <- xml_to_derivations(xml) + + metacore( + ds_spec, + ds_vars, + var_spec, + value_spec, + derivations, + codelist = code_list, + quiet = quiet + ) + }, quiet = quiet) - ds_spec <- xml_to_ds_spec(xml) - ds_vars <- xml_to_ds_vars(xml) - var_spec <- xml_to_var_spec(xml) - value_spec <- xml_to_value_spec(xml) - code_list <- xml_to_codelist(xml) - derivations <- xml_to_derivations(xml) - if(!quiet){ - out <- metacore(ds_spec, ds_vars, var_spec, value_spec, derivations, codelist = code_list) - } else{ - out<- suppressWarnings(metacore(ds_spec, ds_vars, var_spec, value_spec, derivations, codelist = code_list, quiet = quiet)) - } - out + if (quiet) invisible(test) else test } - #' XML to Data Set Spec #' #' Creates a dataset specification, which has the domain name and label for each dataset @@ -82,13 +90,13 @@ xml_to_ds_vars <- function(doc) { }) %>% mutate( variable = id_to_var(.data$oid), - keep = .data$mandatory == "Yes", + mandatory = .data$mandatory == "Yes", core = NA_character_, supp_flag = NA ) %>% select(.data$dataset, .data$variable, .data$key_seq, - .data$order, .data$keep, .data$core, .data$supp_flag, - -.data$mandatory, -.data$oid) + .data$order, .data$mandatory, .data$core, .data$supp_flag, + .data$mandatory, -.data$oid) } diff --git a/R/zzz.R b/R/zzz.R index ef25cef..9d16d6b 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -39,3 +39,7 @@ globalVariables(c("private", "where_new", "var1", "n_lab")) + +.onAttach <- function(libname, pkgname) { + packageStartupMessage("Attaching package `metacore`\n\nAs of metacore 0.3.0 the `keep` variable in the `ds_vars` table has been renamed to `mandatory`. Please see release documentation for details.") +} diff --git a/README.Rmd b/README.Rmd index 44ecc52..7c02ad8 100644 --- a/README.Rmd +++ b/README.Rmd @@ -80,7 +80,7 @@ This table contains the information that bridges between purely dataset level an - *order*: Order sets the order of the columns to appear in the dataset. This is also a numeric value -- *keep*: Logical value about if the variable needs to be kept +- *mandatory (previously `keep`)*: Boolean specifying whether a variable can have blank values. From the CDISC Define-XML v2.1 documentation: Required items that have Mandatory set to "Yes" cannot have blank values. Variables in SDTM domains that have `core = "Required"` should have `mandatory = TRUE`. Note that `keep` was deprecated in v0.3.0 in favour of `mandatory` to better align the package and CDISC terminology. - *core*: ADaM core, which should be one of the following values: "Expected", "Required", "Permissible", "Conditionally Required", "Conditionally Expected", or NA. For more information about core see [CDISC](https://www.cdisc.org/standards/foundational/adam) diff --git a/_pkgdown.yml b/_pkgdown.yml index 0167c93..b3f2a01 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -1,9 +1,15 @@ +url: https://atorus-research.github.io/metacore + destination: docs template: + bootstrap: 5 params: bootswatch: yeti opengraph: image: src: man/figures/metacore.PNG alt: "metacore Hex Sticker" + +search: + exclude: ['news/index.html'] diff --git a/man/define_to_metacore.Rd b/man/define_to_metacore.Rd index 8aed297..d1aee51 100644 --- a/man/define_to_metacore.Rd +++ b/man/define_to_metacore.Rd @@ -9,11 +9,12 @@ define_to_metacore(path, quiet = FALSE) \arguments{ \item{path}{location of the define xml as a string} -\item{quiet}{Option to quietly load in, this will suppress warnings, but not errors} +\item{quiet}{Option to quietly load in; when \code{TRUE}, messages and warnings +are suppressed, but errors are still raised.} } \value{ -DataDef Object +Metacore/DataDef object } \description{ -Given a path, this function converts the define xml to a DataDef Object +Given a path, this function converts the define xml to a DataDef/Metacore object. } diff --git a/man/metacore.Rd b/man/metacore.Rd index f658c6e..743e1d7 100644 --- a/man/metacore.Rd +++ b/man/metacore.Rd @@ -6,7 +6,7 @@ \usage{ metacore( ds_spec = tibble(dataset = character(), structure = character(), label = character()), - ds_vars = tibble(dataset = character(), variable = character(), keep = logical(), + ds_vars = tibble(dataset = character(), variable = character(), mandatory = logical(), key_seq = integer(), order = integer(), core = character(), supp_flag = logical()), var_spec = tibble(variable = character(), label = character(), length = integer(), type = character(), common = character(), format = character()), diff --git a/man/quiet_if_true.Rd b/man/quiet_if_true.Rd new file mode 100644 index 0000000..7e443d8 --- /dev/null +++ b/man/quiet_if_true.Rd @@ -0,0 +1,12 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils.R +\name{quiet_if_true} +\alias{quiet_if_true} +\title{Conditionally suppress messages and warnings} +\usage{ +quiet_if_true(expr, quiet = FALSE) +} +\description{ +Conditionally suppress messages and warnings +} +\keyword{internal} diff --git a/man/spec_to_metacore.Rd b/man/spec_to_metacore.Rd index cc4cfdd..4a0557b 100644 --- a/man/spec_to_metacore.Rd +++ b/man/spec_to_metacore.Rd @@ -9,8 +9,9 @@ spec_to_metacore(path, quiet = FALSE, where_sep_sheet = TRUE) \arguments{ \item{path}{string of file location} -\item{quiet}{Option to quietly load in, this will suppress warnings, but not -errors} +\item{quiet}{Option to quietly load in; when \code{TRUE}, messages, warnings, +and other non-error console output are suppressed, but errors are still +raised.} \item{where_sep_sheet}{Option to tell if the where is in a separate sheet, like in older p21 specs or in a single sheet like newer p21 specs} diff --git a/man/spec_type_to_ds_vars.Rd b/man/spec_type_to_ds_vars.Rd index 844d3ff..70cabb4 100644 --- a/man/spec_type_to_ds_vars.Rd +++ b/man/spec_type_to_ds_vars.Rd @@ -8,7 +8,7 @@ spec_type_to_ds_vars( doc, cols = c(dataset = "[D|d]ataset|[D|d]omain", variable = "[V|v]ariable [[N|n]ame]?|[V|v]ariables?", order = - "[V|v]ariable [O|o]rder|[O|o]rder", keep = "[K|k]eep|[M|m]andatory"), + "[V|v]ariable [O|o]rder|[O|o]rder", mandatory = "[K|k]eep|[M|m]andatory"), key_seq_sep_sheet = TRUE, key_seq_cols = c(dataset = "Dataset", key_seq = "Key Variables"), sheet = "[V|v]ar|Datasets" diff --git a/tests/testthat/test-metacore.R b/tests/testthat/test-metacore.R index cb28713..bc0c4c4 100644 --- a/tests/testthat/test-metacore.R +++ b/tests/testthat/test-metacore.R @@ -56,7 +56,7 @@ test_that("Can pass metacore NULL df's", { dummy <- list(character(), character(), numeric(), numeric(), logical(), character(), logical()) names(dummy) <- c("dataset", "variable", "key_seq", "order", - "keep", "core", "supp_flag") + "mandatory", "core", "supp_flag") dummy <- as_tibble(dummy) #Because of the labels the dfs are slightly different so checking # the insides match @@ -152,3 +152,173 @@ test_that("get_keys works", { key_seq = "Sequence Key") ) }) + +test_that("spec_to_metacore() is silent when quiet = TRUE", { + test <- metacore_example("p21_mock.xlsx") + + expect_silent({ + out <- spec_to_metacore(test , quiet = TRUE) + }) + + expect_true(inherits(out, "Metacore")) +}) + +test_that("spec_to_metacore() quiet = TRUE is silent and returns Metacore", { + path_try <- try(metacore_example("p21_mock.xlsx"), silent = TRUE) + if (inherits(path_try, "try-error") || path_try == "") { + skip("p21_mock.xlsx example spec not available") + } + path <- path_try + + expect_silent({ + mc_q <- spec_to_metacore(path, quiet = TRUE) + expect_true(inherits(mc_q, "Metacore")) + }) +}) + +test_that("spec_to_metacore() quiet = TRUE returns invisibly", { + path_try <- try(metacore_example("p21_mock.xlsx"), silent = TRUE) + if (inherits(path_try, "try-error") || path_try == "") { + skip("p21_mock.xlsx example spec not available") + } + path <- path_try + + expect_invisible( + spec_to_metacore(path, quiet = TRUE) + ) +}) + +test_that("spec_to_metacore() quiet = FALSE returns a Metacore object", { + path_try <- try(metacore_example("p21_mock.xlsx"), silent = TRUE) + if (inherits(path_try, "try-error") || path_try == "") { + skip("p21_mock.xlsx example spec not available") + } + path <- path_try + + # We don't assert on printed output here; just on the return type. + mc_n <- suppressWarnings(spec_to_metacore(path, quiet = FALSE)) + expect_true(inherits(mc_n, "Metacore")) +}) + +test_that("spec_to_metacore() returns structurally similar objects for quiet TRUE/FALSE", { + path_try <- try(metacore_example("p21_mock.xlsx"), silent = TRUE) + if (inherits(path_try, "try-error") || path_try == "") { + skip("p21_mock.xlsx example spec not available") + } + path <- path_try + + mc_q <- suppressWarnings(spec_to_metacore(path, quiet = TRUE)) + mc_n <- suppressWarnings(spec_to_metacore(path, quiet = FALSE)) + + expect_true(inherits(mc_q, "Metacore")) + expect_true(inherits(mc_n, "Metacore")) + + # Basic structural check: same component tables + expect_identical(names(mc_q$data), names(mc_n$data)) +}) + + +test_that("select_dataset() is silent when quiet = TRUE", { + test <- spec_to_metacore(metacore_example("p21_mock.xlsx"), quiet = TRUE) + subset <- test %>% select_dataset("DM", quiet = TRUE) + expect_silent({ + subset <- test %>% select_dataset("DM", quiet = TRUE) + }) + +}) + +test_that("metacore() quiet = TRUE is silent and returns Metacore object", { + + # simplest small valid inputs + ds_spec <- tibble::tibble(dataset = "AE", structure = "OneRowPerRecord", label = "Adverse Events") + ds_vars <- tibble::tibble(dataset = "AE", variable = "AETERM", keep = TRUE, + key_seq = 1L, order = 1L, core = "Req", supp_flag = FALSE) + var_spec <- tibble::tibble(variable = "AETERM", label = "Reported Term", length = 200L, + type = "character", common = NA_character_, format = NA_character_) + value_spec <- tibble::tibble(dataset = "AE", variable = "AETERM", where = NA_character_, + type = "character", sig_dig = NA_integer_, + code_id = NA_character_, origin = "Collected", derivation_id = NA_integer_) + derivations <- tibble::tibble(derivation_id = integer(), derivation = character()) + codelist <- tibble::tibble(code_id = character(), name = character(), type = character(), codes = list()) + supp <- tibble::tibble(dataset = character(), variable = character(), idvar = character(), qeval = character()) + + expect_silent({ + mc_q <- metacore( + ds_spec, ds_vars, var_spec, value_spec, derivations, codelist, supp, + quiet = TRUE + ) + expect_true(inherits(mc_q, "Metacore")) + }) +}) + +test_that("metacore() quiet = TRUE returns invisibly", { + + ds_spec <- tibble::tibble(dataset = "AE", structure = "Row", label = "AE") + ds_vars <- tibble::tibble(dataset = "AE", variable = "AETERM", keep = TRUE, + key_seq = 1L, order = 1L, core = "Req", supp_flag = FALSE) + var_spec <- tibble::tibble(variable = "AETERM", label = "Term", length = 200L, + type = "character", common = NA_character_, format = NA_character_) + value_spec <- tibble::tibble(dataset = "AE", variable = "AETERM", where = NA_character_, + type = "character", sig_dig = NA_integer_, + code_id = NA_character_, origin = "Collected", derivation_id = NA_integer_) + + expect_invisible( + metacore( + ds_spec, ds_vars, var_spec, value_spec, + derivations = tibble::tibble(), + codelist = tibble::tibble(), + supp = tibble::tibble(), + quiet = TRUE + ) + ) +}) + +test_that("metacore() quiet = FALSE returns a Metacore object", { + + ds_spec <- tibble::tibble(dataset = "AE", structure = "Row", label = "AE") + ds_vars <- tibble::tibble(dataset = "AE", variable = "AETERM", keep = TRUE, + key_seq = 1L, order = 1L, core = "Req", supp_flag = FALSE) + var_spec <- tibble::tibble(variable = "AETERM", label = "Term", length = 200L, + type = "character", common = NA_character_, format = NA_character_) + value_spec <- tibble::tibble(dataset = "AE", variable = "AETERM", where = NA_character_, + type = "character", sig_dig = NA_integer_, + code_id = NA_character_, origin = "Collected", derivation_id = NA_integer_) + + mc <- suppressWarnings( + metacore( + ds_spec, ds_vars, var_spec, value_spec, + derivations = tibble::tibble(), + codelist = tibble::tibble(), + supp = tibble::tibble(), + quiet = FALSE + ) + ) + + expect_true(inherits(mc, "Metacore")) +}) + +test_that("metacore() quiet TRUE/FALSE paths produce similar structure", { + + ds_spec <- tibble::tibble(dataset = "AE", structure = "Row", label = "AE") + ds_vars <- tibble::tibble(dataset = "AE", variable = "AETERM", keep = TRUE, + key_seq = 1L, order = 1L, core = "Req", supp_flag = FALSE) + var_spec <- tibble::tibble(variable = "AETERM", label = "Term", length = 200L, + type = "character", common = NA_character_, format = NA_character_) + value_spec <- tibble::tibble(dataset = "AE", variable = "AETERM", where = NA_character_, + type = "character", sig_dig = NA_integer_, + code_id = NA_character_, origin = "Collected", derivation_id = NA_integer_) + + mc_q <- suppressWarnings( + metacore(ds_spec, ds_vars, var_spec, value_spec, + tibble::tibble(), tibble::tibble(), tibble::tibble(), + quiet = TRUE) + ) + + mc_n <- suppressWarnings( + metacore(ds_spec, ds_vars, var_spec, value_spec, + tibble::tibble(), tibble::tibble(), tibble::tibble(), + quiet = FALSE) + ) + + expect_identical(names(mc_q$data), names(mc_n$data)) +}) diff --git a/tests/testthat/test-reader.R b/tests/testthat/test-reader.R index d4c2623..bd06518 100644 --- a/tests/testthat/test-reader.R +++ b/tests/testthat/test-reader.R @@ -40,7 +40,7 @@ test_that("Test ds_spec readers", { test_that("Test ds_vars readers", { # Create a reference ds_vars ref_ds_vars <- tibble::tribble( - ~dataset, ~variable, ~key_seq, ~order, ~keep, ~core, ~supp_flag, + ~dataset, ~variable, ~key_seq, ~order, ~mandatory, ~core, ~supp_flag, "AE", "AEACN", NA, 21L, FALSE, NA_character_, NA, "AE", "AEBDSYCD", NA, 16L, FALSE, NA_character_, NA, "AE", "AEBODSYS", NA, 15L, FALSE, NA_character_, NA, @@ -150,7 +150,7 @@ test_that("Test ds_vars readers", { # Read from spec spec_ds_vars <- spec_type_to_ds_vars(spec) %>% arrange(dataset, variable) %>% - select(dataset, variable, key_seq, order, keep, core, supp_flag) + select(dataset, variable, key_seq, order, mandatory, core, supp_flag) # Tests diff --git a/tests/testthat/test-utils.R b/tests/testthat/test-utils.R index 9990d17..22d9b99 100644 --- a/tests/testthat/test-utils.R +++ b/tests/testthat/test-utils.R @@ -50,3 +50,67 @@ test_that("metacore example returns file options", { sort(c("ADaM_define_CDISC_pilot3.xml", "mock_spec.xlsx", "p21_mock.xlsx", "pilot_ADaM.rda", "pilot_SDTM.rda", "SDTM_define.xml", "SDTM_spec_CDISC_pilot.xlsx"))) }) +test_that("quiet_if_true returns expression result when quiet = FALSE", { + result <- quiet_if_true({ 1 + 1 }, quiet = FALSE) + expect_equal(result, 2) +}) + +test_that("quiet_if_true suppresses messages when quiet = TRUE", { + expect_silent( + quiet_if_true({ + message("this should not print") + 10 + }, quiet = TRUE) + ) +}) + +test_that("quiet_if_true suppresses warnings when quiet = TRUE", { + expect_silent( + quiet_if_true({ + warning("this should not print") + 5 + }, quiet = TRUE) + ) +}) + +test_that("quiet_if_true suppresses cli output when quiet = TRUE", { + skip_if_not_installed("cli") + + expect_silent( + quiet_if_true({ + cli::cli_alert_info("cli output should not print") + cli::cli_rule("Suppressed rule") + cli::cli_bullets(c("• Bullet should be suppressed")) + 42 + }, quiet = TRUE) + ) +}) + +test_that("quiet_if_true does not suppress errors when quiet = TRUE", { + expect_error( + quiet_if_true({ + stop("this error must propagate") + }, quiet = TRUE), + "this error must propagate" + ) +}) + +test_that("quiet_if_true still evaluates side-effect code when quiet = TRUE", { + env <- new.env(parent = emptyenv()) + env$x <- 0 + + quiet_if_true({ + env$x <- 99 + }, quiet = TRUE) + + expect_equal(env$x, 99) +}) + +test_that("quiet_if_true evaluates expr normally when quiet = FALSE", { + x <- quiet_if_true({ + message("this should print normally") + 123 + }, quiet = FALSE) + + expect_equal(x, 123) +}) diff --git a/vignettes/Building_Specification_Readers.Rmd b/vignettes/Building_Specification_Readers.Rmd index 5bb7574..a000ed9 100644 --- a/vignettes/Building_Specification_Readers.Rmd +++ b/vignettes/Building_Specification_Readers.Rmd @@ -107,7 +107,7 @@ The ds_vars table has 7 columns: - order: integer controlling the column order of each dataset -- keep: boolean to determine if the variable is needed +- mandatory: from Define-XML v2.1. A Boolean value indicating if NULL values are permitted. `mandatory = TRUE` indicates that NULL values are not permitted. - core: ADaM core (Expected, Required, Permissible) @@ -127,7 +127,7 @@ doc$Variables %>% head() ds_vars<- spec_type_to_ds_vars(doc, cols = c("dataset" = "Domain", "variable" = "[V|v]ariable [N|n]ame", "order" = "[V|v]ariable [O|o]rder", - "keep" = "[M|m]andatory"), + "mandatory" = "[M|m]andatory"), key_seq_cols = c("dataset" = "Domain Name", "key_seq" = "Key"), sheet = "[V|v]ar|Domains")