Overhaul messaged, warnings, and error handling

Author: Liam Hobby

NAMESPACE

@@ -44,6 +44,7 @@ importFrom(cli,cli_rule)
 importFrom(cli,cli_text)
 importFrom(cli,cli_warn)
 importFrom(cli,col_red)
+importFrom(cli,qty)
 importFrom(dplyr,across)
 importFrom(dplyr,anti_join)
 importFrom(dplyr,arrange)
@@ -93,6 +94,7 @@ importFrom(rlang,enexpr)
 importFrom(rlang,expr)
 importFrom(rlang,inherits_only)
 importFrom(rlang,prim_name)
+importFrom(rlang,set_names)
 importFrom(rlang,sym)
 importFrom(stats,na.omit)
 importFrom(stats,var)

R/checks.R

@@ -57,7 +57,7 @@ check_inconsistent_formats <- function(metacore){
 #' @importFrom dplyr across
 basic_check <- function(col_to_check, metacore){
    if(!is_metacore(metacore)){
-      stop("Expects a metacore object", call. = FALSE)
+      cli_abort("Expects a metacore object", call. = FALSE)
    }
 
    report_df <- metacore$var_spec %>%
@@ -73,10 +73,10 @@ basic_check <- function(col_to_check, metacore){
       select(variable = var1, everything())
 
    if(nrow(report_df) > 0){
-      message(str_glue("Mismatch {as_label(enexpr(col_to_check))}s detected"))
+      cli_warn(str_glue("Mismatch {as_label(enexpr(col_to_check))}s detected"))
       return(report_df)
    } else {
-      message(str_glue("No mismatch {as_label(enexpr(col_to_check))}s detected"))
+      cli_inform(str_glue("No mismatch {as_label(enexpr(col_to_check))}s detected"))
    }
 }
 

R/metacore.R

@@ -121,7 +121,7 @@ MetaCore_validate <-  function() {
       nrow(private$.derivations) == 0 &
       nrow(private$.codelist) == 0 &
       nrow(private$.supp) == 0 ){
-         warning("Other checks were not preformed, because all datasets are empty",
+         cli_warn("Other checks were not preformed, because all datasets are empty",
                  call. = FALSE)
       } else {
          check_columns(private$.ds_spec,
@@ -144,7 +144,7 @@ MetaCore_validate <-  function() {
       }
 
    } else {
-      warning("Other checks were not preformed, because column names were incorrect",
+      cli_warn("Other checks were not preformed, because column names were incorrect",
               call. = FALSE)
    }
 }
@@ -168,7 +168,7 @@ readonly <- function(name) {
       if (missing(value)) {
          private[[paste0(".", name)]]
       } else {
-         stop(paste0(name, " is read only"), call. = FALSE)
+         cli_abort("{name} is read only", call. = FALSE)
       }
    }
    attributes(inside) <- list(name = name)
@@ -182,7 +182,7 @@ MetaCore_filter <- function(value) {
 
    private$.ds_spec <- private$.ds_spec %>% filter(dataset == value)
    if(nrow(private$.ds_spec) == 0){
-      stop(paste0(value, " is not a dataset in the metacore object", call. = FALSE))
+      cli_abort("{value} is not a dataset in the metacore object", call. = FALSE)
    }
    private$.ds_vars <- private$.ds_vars %>% filter(dataset == value)
    private$.value_spec <- private$.value_spec %>% filter(dataset == value)
@@ -443,7 +443,7 @@ get_control_term <- function(metacode, variable, dataset = NULL){
    dataset_val <- ifelse(str_detect(as_label(enexpr(dataset)), "\""),
                          as_name(dataset), as_label(enexpr(dataset))) # to make the filter more explicit
    if(!var_str %in% metacode$value_spec$variable){
-      stop(paste0(var_str, " not found in the value_spec table. Please check the variable name"))
+      cli_abort("{var_str} not found in the value_spec table. Please check the variable name")
    }
    if(dataset_val == "NULL"){
       var_code_id <- metacode$value_spec %>%
@@ -454,21 +454,21 @@ get_control_term <- function(metacode, variable, dataset = NULL){
       subset_data <- metacode$value_spec %>%
          filter(dataset == dataset_val)
       if(nrow(subset_data) == 0){
-         stop(paste0(dataset_val, " not found in the value_spec table. Please check the dataset name"))
+         cli_abort("{dataset_val} not found in the value_spec table. Please check the dataset name")
       }
       var_code_id <- subset_data %>%
          filter(variable == var_str) %>%
          pull(code_id) %>%
          unique()
    }
    if(length(var_code_id) > 1){
-      stop(paste0(var_str, " does not have a unique control term, consider spcificing a dataset"))
+      cli_abort("{var_str} does not have a unique control term, consider spcificing a dataset")
    }
    ct <- metacode$codelist %>%
       filter(code_id == var_code_id) %>%
       pull(codes)
    if(length(ct) == 0){
-      message(paste0(var_str, " has no control terminology"))
+      cli_inform("{var_str} has no control terminology")
    } else {
       return(ct[[1]])
    }
@@ -500,7 +500,7 @@ get_keys <- function(metacode, dataset){
    subset_data <- metacode$ds_vars %>%
       filter(dataset == dataset_val)
    if(nrow(subset_data) == 0){
-      stop(paste0(dataset_val, " not found in the ds_vars table. Please check the dataset name"))
+      cli_abort("{dataset_val} not found in the ds_vars table. Please check the dataset name")
    }
 
    keys <- subset_data %>%
@@ -554,9 +554,9 @@ load_metacore <- function(path = NULL) {
    if (is.null(path)) {
       rdss <- list.files(".", ".rds")
       if (length(rdss) == 0) {
-         stop("please supply path to metacore object ending with extension .rds", call. = FALSE)
+         cli_abort("please supply path to metacore object ending with extension .rds", call. = FALSE)
       } else {
-         stop("metacore object path required, did you mean:",
+         cli_abort("metacore object path required, did you mean:",
               paste("   ", rdss, sep = "\n   "), call. = FALSE)
       }
    }

R/spec_builder.R

@@ -29,7 +29,7 @@ spec_to_metacore <- function(path, quiet = FALSE, where_sep_sheet = TRUE){
          out<- suppressWarnings(metacore(ds_spec, ds_vars, var_spec, value_spec, derivations, codelist = code_list, quiet = quiet))
       }
    } else {
-      stop("This specification format is not currently supported. You will need to write your own reader",
+      cli_abort("This specification format is not currently supported. You will need to write your own reader",
            call. = FALSE)
    }
    out
@@ -48,14 +48,14 @@ spec_to_metacore <- function(path, quiet = FALSE, where_sep_sheet = TRUE){
 spec_type <- function(path){
    sheets <- excel_sheets(path)
    if(!any(sheets %>% str_detect("[D|d]omains?|[D|d]atasets?"))){
-      stop("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)",
+      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)
    } else if(any(sheets %>% str_detect("ADSL|DM"))){
       type <- "by_ds"
    } else if(any(sheets %>% str_detect("[V|v]ariables?"))){
       type <- "by_type"
    } else {
-      stop("File in an unknown format. Please either modify the spec document or write a reader (see documentation for more information)",
+      cli_abort("File in an unknown format. Please either modify the spec document or write a reader (see documentation for more information)",
            call. = FALSE)
    }
    type
@@ -102,8 +102,10 @@ spec_type_to_ds_spec <- function(doc, cols = c("dataset" = "[N|n]ame|[D|d]ataset
    name_check <- names(cols) %in% c("dataset", "structure", "label") %>%
       all()
    if(!name_check | is.null(names(cols))){
-      stop("Supplied column vector must be named using the following names:
-              'dataset', 'structure', 'label'")
+      cli_abort(c(
+         "Supplied column vector must be named using the following names:",
+         "'dataset', 'structure', 'label'"
+      ))
    }
    if(!is.null(sheet)){
       sheet_ls <- str_subset(names(doc), sheet)
@@ -159,7 +161,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)))){
-      stop("Supplied column vector must be named using the following names:
+      cli_abort("Supplied column vector must be named using the following names:
               'variable', 'dataset', 'order', 'keep', 'core', 'key_seq', 'supp_flag'")
    }
    # Subsetting sheets
@@ -226,10 +228,12 @@ spec_type_to_var_spec <- function(doc, cols = c("variable" = "[N|n]ame|[V|v]aria
                                     "type", "dataset", "common", "format") %>%
       all()
    if(!name_check | is.null(names(cols))){
-      stop("Supplied column vector must be named using the following names:
-              'variable', 'length', 'label', 'type', 'dataset', 'common', 'format'
-              If common is not avaliable it can be excluded and will be automatically filled in.
-           Additionally, dataset is only used to clarify if information differs by domain")
+      cli_abort(paste(
+         "Supplied column vector must be named using the following names:",
+         "'variable', 'length', 'label', 'type', 'dataset', 'common', 'format'",
+         "If common is not avaliable it can be excluded and will be automatically filled in.",
+         "Additionally, dataset is only used to clarify if information differs by domain."
+      ))
    }
 
    # Check if sheet is specified
@@ -245,12 +249,12 @@ spec_type_to_var_spec <- function(doc, cols = c("variable" = "[N|n]ame|[V|v]aria
          summarise(n = n(), .groups = "drop") %>%
          filter(n > 1)
       if(nrow(dups) > 0){
-         dups %>%
-            pull(variable) %>%
-            paste(collapse = "\n") %>%
-            paste0("The following variables are repeated with different metadata for different datasets:\n",
-                   ., "\nPlease add 'dataset' = [Name of dataset column] to your named cols vector, to correct for this") %>%
-            stop(., call. = FALSE)
+         x <- dups %>% pull(variable)
+         cli_abort(c(
+            col_red("The following variables are repeated with different metadata for different datasets:"),
+            "i" = ansi_collapse(x),
+            "i" = "Please add 'dataset' = [Name of dataset column] to your named cols vector to correct this."
+         ), call. = FALSE)
       }
    } else {
       if(!"common" %in% names(cols)){
@@ -334,12 +338,12 @@ spec_type_to_value_spec <- function(doc, cols = c("dataset" = "[D|d]ataset|[D|d]
       all()
 
    if(!name_check| is.null(names(cols))){
-      stop("Supplied column vector must be named using the following names:
-              'dataset', 'variable', 'origin', 'code_id', 'type', 'where', 'sig_dig', 'derivation_id',
-              'predecessor'
-              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.")
+      cli_abort(c(
+         "Supplied column vector must be named using the following names:",
+         "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)
    }
 
    # Select a subset of sheets if specified
@@ -401,7 +405,7 @@ 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) {
-      warning("Not able to add where infromation from seperate sheet cause a where column is needed to cross-reference the information",
+      cli_warn("Not able to add where infromation from seperate sheet cause a where column is needed to cross-reference the information",
               call. = FALSE)
    }
 
@@ -467,12 +471,12 @@ spec_type_to_codelist <- function(doc, codelist_cols = c("code_id" = "ID",
                                                 "version" = "[V|v]ersion"),
                                   sheets = NULL, simplify = FALSE){
    if(is.null(codelist_cols)){
-      stop("Codelist column names must be provided", call. = FALSE)
+      cli_abort("Codelist column names must be provided", call. = FALSE)
    } else {
       name_check <- names(codelist_cols) %in% c("code_id", "name", "code", "decode") %>%
          all()
       if(!name_check| is.null(names(codelist_cols))){
-         stop("Supplied column vector for codelist_cols must be named using the following names:
+         cli_abort("Supplied column vector for codelist_cols must be named using the following names:
               'code_id', 'name', 'code', 'decode'",
               call. = FALSE
          )
@@ -483,7 +487,7 @@ spec_type_to_codelist <- function(doc, codelist_cols = c("code_id" = "ID",
       name_check <- names(permitted_val_cols) %in% c("code_id", "name", "code") %>%
          all()
       if(!name_check){
-         stop("Supplied column vector for permitted_val_cols must be named using the following names:
+         cli_abort("Supplied column vector for permitted_val_cols must be named using the following names:
               'code_id', 'name', 'code'",
               call. = FALSE)
       }
@@ -492,10 +496,10 @@ spec_type_to_codelist <- function(doc, codelist_cols = c("code_id" = "ID",
       name_check <- names(dict_cols) %in% c("code_id", "name", "dictionary", "version") %>%
          all()
       if(!name_check){
-         stop("Supplied column vector for `dict_cols` must be named using the following names:
-              'code_id', 'name', 'dictionary', 'version',
-              If a dictionary sheet isn't avaliable set `dict_cols` to NULL",
-              call. = FALSE)
+         cli_abort(paste0(
+            "Supplied column vector for `dict_cols` must be named using the following names:",
+            "'code_id', 'name', 'dictionary', 'version'. If a dictionary sheet isn't avaliable",
+            "set `dict_cols` to NULL"), call. = FALSE)
       }
    }
 
@@ -574,14 +578,15 @@ spec_type_to_derivations <- function(doc, cols = c("derivation_id" = "ID",
    name_check <- names(cols) %in% c("derivation_id", "derivation") %>%
       all()
    if(!name_check| is.null(names(cols))){
-      stop("Supplied column vector must be named using the following names:
-              'derivation_id', 'derivation'")
+      cli_abort(c(
+         "Supplied column vector must be named using the following names:",
+         "'derivation_id', 'derivation'"))
    }
 
    name_check <- names(var_cols) %in% c('dataset', 'variable', 'origin', 'predecessor', 'comment') %>%
       all()
    if(!name_check| is.null(names(var_cols))){
-      stop("Supplied variable column vector must be named using the following names:
+      cli_abort("Supplied variable column vector must be named using the following names:
                'dataset', 'variable', 'origin', 'predecessor', 'comment'")
    }
    # Get the predecessor
@@ -683,7 +688,7 @@ create_tbl <- function(doc, cols){
          }) %>%
          paste0(collapse = "\n") %>%
          paste0("Unable to identify a sheet with all columns.\n", . ) %>%
-         stop(call. = FALSE)
+        (call. = FALSE)
 
    } else if(length(matches) == 1){
       # Check names and write a better warning message if names don't work
@@ -702,26 +707,25 @@ create_tbl <- function(doc, cols){
             cols[names(nm_test)] <- cols[names(nm_test)] %>%
                paste0("^", ., "$")
          } else {
-            str_c(names(nm_test),  " matches ",nm_test, " columns") %>%
-               str_c(collapse = "\n ") %>%
-               paste0("Unable to rename the following columns in ", names(matches[1]), ":\n ", .,
-                      "\nPlease check your regular expression ") %>%
-               stop(call. = FALSE)
+            x <- str_c(names(nm_test),  " matches ",nm_test, " columns")
+            cli_abort(c(
+               "Unable to rename the following columns in {names(matches[1])}:",
+               "i" = ansi_collapse(x),
+               "i" = "Please check your regular expression"
+            ), call. = FALSE)
          }
       }
 
       # This needs to be done columnwise to allow for duplicate selection of the same column
       select_rename_w_dups(matches[[1]], cols)
 
    } else {
-      sheets_mats <- matches %>%
-         names()
-      paste("Column names are not specific enough to identify a single sheet. The following",
-            length(sheets_mats),
-            "match the criteria set:", paste(sheets_mats, collapse = ", ")) %>%
-         warning(., call. = FALSE)
-      matches %>%
-         map(~select_rename_w_dups(., cols))
+      sheets_mats <- matches %>% names()
+      cli_warn(c(paste(
+         "Column names are not specific enough to identify a single sheet."),
+         "The following {length(sheets_mats)} match the criteria set:"),
+         ansi_collapse(sheets_mats), call. = FALSE)
+      matches %>% map(~select_rename_w_dups(., cols))
    }
 }
 
@@ -741,7 +745,7 @@ yn_to_tf <- function(x){
    } else if(is.logical(x)){
       x
    } else {
-      warning("Keep column needs to be True or False, please correct before converting to a Metacore object",
+      cli_warn("Keep column needs to be True or False, please correct before converting to a Metacore object",
               call. = FALSE)
       x
    }