#' Checks the variables in ds_var are in var_spec
#'
#' @param ds_vars ds_var table
#' @param var_spec var_spec table
#'
#' @return writes warning to console if there is an issue
#' @noRd
ds_vars_check <- function(ds_vars, var_spec){
var_check <- anti_join(ds_vars, var_spec, by = "variable")
if(var_check %>% nrow()){
var_ls <- var_check %>%
pull(.data$variable) %>%
unique()
var_check_dbl <- ds_vars %>%
filter(.data$variable %in% var_ls) %>%
mutate(var_name = paste0(.data$dataset, ".", .data$variable)) %>%
anti_join(var_spec, by = c("var_name" = "variable")) %>%
pull(.data$variable) %>%
unique()
if(var_check_dbl %>% length() != 0){
cat("\n")
warning(
"The following variable(s) do not have labels and lengths: ",
paste(" ", var_check_dbl, sep = "\n "),
"\n\n",
call. = FALSE
)
}
}
}
#' Check Values
#'
#'
#' Check the value spec table works with the ds_var tables. All variables in the
#' ds_var should be in the value_spec and all variables in value_spec should be
#' in ds_vars
#' @param ds_vars ds_vars table
#' @param value_spec value_spec table
#'
#' @return writes warning to console if there is an issue
#' @noRd
value_check <- function(ds_vars, value_spec){
value_vars <- value_spec %>%
distinct(.data$dataset, .data$variable)
#Check the variables in ds_vars that don't have value specs
not_in_val <- anti_join(ds_vars, value_vars, by = c("dataset", "variable"))
if(nrow(not_in_val) != 0){
variables <- not_in_val %>%
mutate(full = str_c(.data$dataset, .data$variable, sep = ".")) %>%
pull(.data$full) %>%
str_c(collapse = ", ")
message <- paste("The following variables are in the ds_vars table, but don't have value specs:\n",
variables, "\n\n")
warning(message, call. = FALSE)
}
# Check the variables in value spec that aren't in ds_vars
not_in_ds <- anti_join(value_vars, ds_vars, by = c("dataset", "variable"))
if(nrow(not_in_ds) != 0){
variables <- not_in_ds %>%
pull(.data$variable) %>%
str_c(collapse = ", ")
message <- paste("The following variables are have value specifications, but aren't in the ds_vars table:\n",
variables, "\n\n")
warning(message, call. = FALSE)
}
}
#' Derivation check
#'
#' @param value_spec value_spec table
#' @param derivations derivation table
#'
#' @return writes warning to console if there is an issue
#' @noRd
derivation_check <- function(value_spec, derivations){
deriv_vars <- value_spec %>%
filter(!is.na(.data$derivation_id)) %>%
distinct(.data$variable,.data$ derivation_id)
#Check the variables that don't have derivations in derivations
not_in_val <- anti_join(deriv_vars, derivations, by = c("derivation_id"))
if(nrow(not_in_val) != 0){
variables <- not_in_val %>%
pull(.data$variable) %>%
str_c(collapse = "\n ")
message <- paste("The following variables have derivation ids not found in the derivations table:\n",
variables, "\n\n")
warning(message, call. = FALSE)
}
# Check the derivations in deriavtion that aren't in value spec
not_in_deriv <- anti_join(derivations, deriv_vars, by = c("derivation_id"))
if(nrow(not_in_deriv) != 0){
deriv <- not_in_deriv %>%
mutate(message = paste0(.data$derivation_id, ": ", .data$derivation)) %>%
pull(.data$message) %>%
str_c(collapse = "\n ")
message <- paste("The following derivations are never used:\n",
deriv, "\n\n")
warning(message, call. = FALSE)
}
}
#' Codelist Check
#'
#' @param value_spec value spec table
#' @param codelist codelist table
#'
#' @return writes warning to console if there is an issue
#' @noRd
codelist_check <- function(value_spec, codelist){
code_vars <- value_spec %>%
filter(!is.na(.data$code_id)) %>%
distinct(.data$variable, .data$code_id)
#Check the variables in don't codelists have codelist
not_in_val <- anti_join(code_vars, codelist, by = c("code_id"))
if(nrow(not_in_val)){
variables <- not_in_val %>%
pull(.data$variable) %>%
str_c(collapse = "\n ")
message <- paste("The following variables have code ids not found in the codelist(s):\n",
variables, "\n")
warning(message, call. = FALSE)
}
# Check the code_ids in codelist that aren't in value spec
not_in_cl <- anti_join(codelist, code_vars, by = c("code_id"))
if(nrow(not_in_cl)){
cl_nm <- not_in_cl %>%
pull(.data$name) %>%
str_c(collapse = "\n ")
message <- paste("The following codelist(s) are never used:\n",
cl_nm, "\n\n")
warning(message, call. = FALSE)
}
}
#' Check Supp
#'
#'
#' Check the supp table works with the ds_var tables. All variables in the
#' ds_var with a TRUE supp flag should be in the supp and all variables in supp
#' should be in ds_vars
#' @param ds_vars ds_vars table
#' @param supp supp table
#'
#' @return writes warning to console if there is an issue
#' @noRd
supp_check <- function(ds_vars, supp){
dist_test <- supp %>%
distinct(.data$dataset, .data$variable) %>%
nrow() == nrow(supp)
if(!dist_test){
warning("Supp table contains non-unique dataset/variable combinations")
}
ds_vars <- ds_vars %>%
filter(.data$supp_flag)
#Check the variables in ds_vars that don't have value specs
not_in_supp <- anti_join(ds_vars, supp, by = c("dataset", "variable"))
if(nrow(not_in_supp) != 0){
variables <- not_in_supp %>%
mutate(full = str_c(.data$dataset, .data$variable, sep = ".")) %>%
pull(.data$full) %>%
str_c(collapse = ", ")
message <- paste("The following variables are in the ds_vars table and tagged as supplement, but don't have supp specs:\n",
variables, "\n\n")
warning(message, call. = FALSE)
}
# Check the variables in value spec that aren't in ds_vars
not_in_ds <- anti_join(supp, ds_vars, by = c("dataset", "variable"))
if(nrow(not_in_ds) != 0){
variables <- not_in_ds %>%
pull(.data$variable) %>%
str_c(collapse = ", ")
message <- paste("The following variables are have supp specifications, but aren't in the ds_vars table:\n",
variables, "\n\n")
warning(message, call. = FALSE)
}
}
#' Column Names by dataset
#'
#' @return list of column names by dataset
#' @noRd
col_vars <- function(){
list(.ds_spec = c("dataset", "structure", "label"),
.ds_vars = c("dataset", "variable", "key_seq", "order","keep", "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"),
.codelist= c("code_id", "name","type", "codes"),
.supp = c("dataset", "variable", "idvar", "qeval"))
}
#' Check Variable names
#'
#' @param envrionment the private environment of the object
#'
#' @return warning messages to the console if there is an issue
#' @noRd
var_name_check <- function(envrionment){
# Set the name as they should be
col_names <- col_vars()
# Get the tables and table names from the environment
tbl_name <- ls(envrionment, all.names = TRUE)
tbls <- map(tbl_name, get, envir = envrionment)
# Checks is names match the table above, returns T if so F else. If the names
# don't match, will also produce a warning of what the names should be
map2_lgl(tbl_name, tbls, function(name, tbl){
name
if(is.null(tbl)){
# Checks for null tables
print_message <- name %>%
str_remove("[:punct:]") %>%
paste("is null")
warning(print_message, call. = FALSE)
FALSE
} else if(!setequal(names(tbl),col_names[[name]])){
# writes a message if the column names don't match
print_message <- name %>%
str_remove("[:punct:]") %>%
paste0("'", ., "' has incorrect column names. It should be:\n",
str_c(col_names[[name]], collapse = ", "), "\n")
warning(print_message, call. = FALSE)
FALSE
} else {
TRUE
}
}) %>%
all()
}
#' Column Data Check <- lol horrible name
#'
#' @return a data frame of the datasets, column
#' @noRd
#'
all_message <- function() {
tribble(
~dataset, ~var, ~test, ~any_na_acceptable,
"ds_spec", "dataset", is.character, FALSE,
"ds_spec", "structure", is.character, TRUE,
"ds_spec", "label", is.character, TRUE,
"ds_vars", "dataset", is.character, FALSE,
"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", "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,
"var_spec", "type", is.character, TRUE,
"var_spec", "length", is.numeric, TRUE,
"var_spec", "label", is.character, TRUE,
"var_spec", "format", is.character, TRUE,
"var_spec", "common", is.logical, TRUE,
"value_spec", "type", is.character, TRUE,
"value_spec", "sig_dig", is.integer, TRUE,
"value_spec", "origin", function(x){str_detect(x, "collected|derived|assigned|protocol|predecessor|crf.*")||is.na(x)}, TRUE,
"value_spec", "code_id", is.character, TRUE,
"value_spec", "dataset", is.character, FALSE,
"value_spec", "where", is.character, TRUE,
"value_spec", "derivation_id", is.character, TRUE,
"derivations", "derivation_id", is.character, FALSE,
"derivations", "derivation", is.character, TRUE,
"codelist", "code_id", is.character, FALSE,
"codelist", "name", is.character, TRUE,
"codelist", "codes", function(x){!is.null(x)}, TRUE,
"codelist", "type", is.character, TRUE,
"supp", "dataset", is.character, FALSE,
"supp", "variable", is.character, FALSE,
"supp", "idvar", is.character, TRUE,
"supp", "qeval", is.character, TRUE,
)
}
#' Check all data frames include the correct types of columns
#'
#' This function checks for vector types and accepted words
#'
#' @param ds_spec dataset specification
#' @param ds_vars dataset variables
#' @param var_spec variable specification
#' @param value_spec value specification
#' @param derivations derivation information
#' @param codelist codelist information
#' @param supp supp information
#'
check_columns <- function(ds_spec, ds_vars, var_spec, value_spec, derivations, codelist, supp) {
messages <- purrr::pmap(all_message(),
~check_structure(
get(..1), sym(..2), ..3, ..4, ..1)
)
# errors
errors <- map(messages, "error") %>%
compact() %>%
paste0(., collapse = "\n\n")
if(errors != "")
stop(paste0(errors, "\n\n"), call. = FALSE)
# warnings
warnings <- map(messages, "warning") %>%
compact() %>%
paste0(., collapse = "\n\n")
if(warnings != "")
warning(paste0(warnings, "\n\n"), call. = FALSE)
}
#' Is metacore object
#'
#' @param x object to check
#'
#' @return `TRUE` if metacore, `FALSE` if not
#' @export
#'
#' @examples
#' # Loads in a metacore obj called metacore
#' load(metacore_example("pilot_ADaM.rda"))
#' is_metacore(metacore)
#'
is_metacore <- function(x){
inherits(x, "Metacore")
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.