Nothing
R/util_correct_variable_use.R
In dataquieR: Data Quality in Epidemiological Research
Defines functions
util_correct_variable_use
#' Check referred variables
#'
#' This function operates in the environment of its caller
#' (using [eval.parent], similar to [Function like C-Preprocessor-Macros](
#' https://www.programiz.com/c-programming/c-preprocessor-macros#example-define)
#' ).
#' Different from the other utility function that work
#' in the caller's environment ([prep_prepare_dataframes]), It has no side
#' effects except that the argument
#' of the calling function specified in `arg_name` is normalized (set to its
#' default or a general default if missing, variable names being all white
#' space replaced by NAs).
#' It expects two objects in the caller's environment: `ds1` and `meta_data`.
#' `meta_data` is the metadata data frame and `ds1` is produced by a preceding
#' call of [prep_prepare_dataframes] using `meta_data` and `study_data`.
#' So this function can only be used after calling the function
#' [prep_prepare_dataframes]
#'
#' `util_correct_variable_use` and `util_correct_variable_use2` differ only in
#' the default of the argument `role`.
#'
#' `util_correct_variable_use` and `util_correct_variable_use2` put strong
#' effort on producing compressible
#' error messages to the caller's caller (who is typically an end user of
#' a `dataquieR` function).
#'
#' The function ensures, that a specified argument of its caller that refers
#' variable names
#' (one or more as character vector) matches some expectations.
#'
#' This function accesses the caller's environment!
#'
#' @param arg_name [character] Name of a function argument of the caller
#' of `util_correct_variable_use`
#' @param allow_na [logical] default = FALSE. allow NAs in the variable names
#' argument given in `arg_name`
#' @param allow_more_than_one [logical] default = FALSE. allow more than one
#' variable names in `arg_name`
#' @param allow_null [logical] default = FALSE. allow an empty variable name
#' vector in the argument `arg_name`
#' @param allow_all_obs_na [logical] default = TRUE. check observations for not
#' being all `NA`
#' @param allow_any_obs_na [logical] default = TRUE. check observations for
#' being complete without any `NA`
#' @param min_distinct_values [integer] Minimum number of distinct observed
#' values of a study variable
#' @param need_type [character] if not `NA`, variables must be of data type
#' `need_type` according to the metadata,
#' can be a pipe (`|`) separated list of
#' allowed data types. Use `!` to exclude
#' a type. See [DATA_TYPES] for the
#' predefined variable types of the
#' `dataquieR` concept.
#' @param need_scale [character] if not `NA`, variables must be of scale level
#' `need_scale` according to the metadata,
#' can be a pipe (`|`) separated list of
#' allowed scale levels. Use `!` to exclude
#' a level. See [SCALE_LEVELS] for the
#' predefined scale levels of the
#' `dataquieR` concept.
#' @param need_role [character] see `need_scale`, but looks for `VARIABLE_ROLE`
#' @param need_computed_role [character] see `need_scale`, but looks for
#' `COMPUTED_VARIABLE_ROLE`
#' @param role [character] variable-argument role. Set different defaults for
#' all `allow`-arguments and `need_type` of
#' this `util_correct_variable_use.`. If given, it
#' defines the intended use
#' of the verified argument. For typical arguments and
#' typical use cases, roles
#' are predefined in [.variable_arg_roles].
#' The role's defaults can be overwritten by the
#' arguments. If `role` is "" (default),
#' the standards are `allow_na = FALSE`,
#' `allow_more_than_one = FALSE`, `allow_null = FALSE`,
#' `allow_all_obs_na = TRUE`, `allow_any_obs_na = TRUE`,
#' and `need_type = NA`.
#' Use `util_correct_variable_use2` for using the
#' `arg_name` as default for `role`.
#' See [.variable_arg_roles] for currently available
#' variable-argument roles.
#' @param overwrite [logical] overwrite vector of variable names
#' to match the labels given in `label_col`.
#' @param do_not_stop [logical] do not throw an error, if one of the variables
#' violates `allow_all_obs_na`, `allow_any_obs_na` or
#' `min_distinct_values`. Instead, the variable will be
#' removed from `arg_name` in the parent environment
#' with a warning. This is helpful for functions which
#' work with multiple variables.
#' @param remove_not_found [logical]
#' if variables are missing from the sutdy data, ignore
#' them
#'
#' @seealso [.variable_arg_roles]
#' @importFrom stats na.omit
#'
#' @family robustness_functions
#' @concept robustness
#' @noRd
util_correct_variable_use <- function(arg_name,
allow_na,
allow_more_than_one,
allow_null,
allow_all_obs_na,
allow_any_obs_na,
min_distinct_values,
need_type,
need_scale,
need_role,
need_computed_role,
role = "",
overwrite = TRUE,
do_not_stop = FALSE,
remove_not_found = FALSE) {
re_check <- TRUE
while (re_check) {
re_check <- FALSE
# interpret the arg_name argument
try({
arg_name <- as.character(substitute(arg_name))
}, # if called with a symbol, get that symbol as a character,
silent = TRUE # if called with a character, do nothing
)
if (!all(is.character(arg_name))) { # nocov start
# if we did not get a character up to here, there is an error in
# calling this util_correct_variable_use
# this should never happen anyway, so cannot test this
util_error(c(
"argument arg_name must be either one character or one symbol,",
"wrong use of util_correct_variable_use?"))
} # nocov end
if (length(arg_name) != 1) {
# if we have 0 or more than one argument name, this is also an
# error in calling util_correct_variable_use
util_error(c(
"argument arg_name must be of length 1,",
"wrong use of util_correct_variable_use?"))
}
# verify the "roles" argument
if (role %in% .variable_arg_roles$name) {
# if `role` is a known variable-argument role
if (missing(allow_na)) { # if missing the allow_na argument
allow_na <- subset(.variable_arg_roles, get("name") == role,
"allow_na", drop = TRUE)
} # fetch it from the role's defaults
if (missing(allow_more_than_one)) {
# if missing the allow_more_than_one argument
allow_more_than_one <- subset(.variable_arg_roles, get("name") == role,
"allow_more_than_one", drop = TRUE)
} # fetch it from the role's defaults
if (missing(allow_null)) { # if missing the allow_null argument
allow_null <- subset(.variable_arg_roles, get("name") == role,
"allow_null", drop = TRUE)
} # fetch it from the role's defaults
if (missing(allow_all_obs_na)) { # if missing the allow_all_obs_na argument
allow_all_obs_na <- subset(.variable_arg_roles, get("name") == role,
"allow_all_obs_na", drop = TRUE)
} # fetch it from the role's defaults
if (missing(allow_any_obs_na)) { # if missing the allow_any_obs_na argument
allow_any_obs_na <- subset(.variable_arg_roles, get("name") == role,
"allow_any_obs_na", drop = TRUE)
} # fetch it from the role's defaults
if (missing(min_distinct_values)) {
# if missing the min_distinct_values argument
min_distinct_values <- subset(.variable_arg_roles, get("name") == role,
"min_distinct_values", drop = TRUE)
} # fetch it from the role's defaults
if (missing(need_type)) { # if missing the need_type argument
need_type <- subset(.variable_arg_roles, get("name") == role,
"need_type", drop = TRUE)
} # fetch it from the role's defaults
if (missing(need_scale)) { # if missing the need_scale argument
need_scale <- subset(.variable_arg_roles, get("name") == role,
"need_scale", drop = TRUE)
} # fetch it from the role's defaults
if (missing(need_role)) { # if missing the need_role argument
need_role <- subset(.variable_arg_roles, get("name") == role,
"need_role", drop = TRUE)
} # fetch it from the role's defaults
if (missing(need_computed_role)) { # if missing the need_computed_role argument
need_computed_role <- subset(.variable_arg_roles, get("name") == role,
"need_computed_role", drop = TRUE)
} # fetch it from the role's defaults
} else { # no known variable-argument in argument `role`
if (role != "") { # if role is not empty
util_error(
c("Unknown variable-argument role: %s for argument %s,",
"wrong use of util_correct_variable_use?"),
role, arg_name
) # this is again a wrong use of this function.
}
if (missing(allow_na)) {
# set the default for allow_na if it has not been given
allow_na <- FALSE
}
if (missing(allow_more_than_one)) {
# set the default for allow_more_than_one if it has not been given
allow_more_than_one <- FALSE
}
if (missing(allow_null)) {
# set the default for allow_null if it has not been given
allow_null <- FALSE
}
if (missing(allow_all_obs_na)) {
# set the default for allow_all_obs_na if it has not been given
allow_all_obs_na <- TRUE
}
if (missing(allow_any_obs_na)) {
# set the default for allow_any_obs_na if it has not been given
allow_any_obs_na <- TRUE
}
if (missing(min_distinct_values)) {
# set the default for min_distinct_values if it has not been given
min_distinct_values <- 0
}
if (missing(need_type)) {
# set the default for need_type if it has not been given
need_type <- NA
}
if (missing(need_scale)) {
# set the default for need_scale if it has not been given
need_scale <- NA
}
if (missing(need_role)) {
# set the default for need_role if it has not been given
need_role <- NA
}
if (missing(need_computed_role)) {
# set the default for need_computed_role if it has not been given
need_computed_role <- NA
}
}
p <- parent.frame(1) # access the caller's environment
if (!exists(arg_name, envir = p)) {
# check, if the function argument exists in the calling function.
util_error(
c("Unknown function argument %s checked,",
"wrong use of util_correct_variable_use?"),
arg_name)
}
# if we have a label col, use it
if (exists("label_col", envir = p)) {
# calling function has a label_col argument
label_col <- try(get("label_col", envir = p), silent = TRUE)
# try to get its value
if (inherits(label_col, "try-error")) {
# no value avail, i.e. no default and not given
label_col <- VAR_NAMES # use VAR_NAMES as default
}
} else {
label_col <- VAR_NAMES
# calling function does not support label_col, so use VAR_NAMES as default
}
missing_in_parent <- eval.parent(call("missing", as.symbol(arg_name)))
variable <- try(get(arg_name, envir = p), silent = TRUE)
# try to get the value of the callers argument called `arg_name`.
if (inherits(variable, "try-error")) {
if (missing_in_parent) {
util_warning(
c("Missing argument %s without default value. Setting to NULL. As",
"a dataquieR developer, please add a default value for %s to",
"remove this warning."),
dQuote(arg_name), dQuote(arg_name),
applicability_problem = TRUE)
} else {
util_warning(
c("Could not get value of argument %s for unexpected reasons. Setting",
"to NULL."), arg_name, applicability_problem = TRUE)
util_warning(variable, applicability_problem = TRUE)
}
variable <- NULL
}
if (!exists("ds1", envir = p)) {
# if the calling function does not have a ds1, this is a wrong use of
# util_correct_variable_use
util_error(c(
"Did not find merged study data and metadata ds1.",
"Wrong use of util_correct_variable_use?"))
}
if (!exists("meta_data", envir = p)) {
# if the calling function does not have a meta_data, this is a wrong use of
# util_correct_variable_use
util_error(
"Did not find metadata. Wrong use of util_correct_variable_use?")
}
ds1 <- try(get("ds1", envir = p), silent = TRUE)
# try to fetch the ds1 object from the callers environment
if (!is.data.frame(ds1)) { # it this is not a data frame, this is again a
# wrong use of util_correct_variable_use
util_error(
c("ds1 does not provide merged study data and metadata.",
"Wrong use of util_correct_variable_use?"))
}
meta_data <- try(get("meta_data", envir = p), silent = TRUE)
# try to fetch the meta_data object from the callers environment
if (!is.data.frame(meta_data)) {
# it this is not a data frame, this is again a wrong use of
# util_correct_variable_use
util_error(
c("meta_data does not provide a metadata data frame.",
"Wrong use of util_correct_variable_use?"))
}
if (!allow_null && is.null(variable)) {
# if we need the argument in arg_name, but the user provided NULL
util_error("Argument %s is NULL", arg_name,
applicability_problem = TRUE) # this is an error
}
if (allow_more_than_one) {
# if we allow more than one variable in the argument arg_name
if (!allow_null && length(variable) == 0) {
# and we do need at least one variable name here, but the user did not
# provide any
util_error("Need at least one element in argument %s, got 0", arg_name,
applicability_problem = TRUE)
# this is an error
}
} else { # if we expect one value in the argument arg_name at most
if ((!allow_null && length(variable) != 1) ||
(allow_null && length(variable) > 1)) {
# but the user gave more than one or none although
# allow_null prohibits this
util_error("Need exactly one element in argument %s, got %d: [%s]",
arg_name, length(variable), paste0(variable, collapse = ", "),
applicability_problem = TRUE)
# this is an error
}
}
if (length(variable) > 0) { # if we have at least one variable name
if (!all(is.character(variable) |
is.na(variable))) { # and one name is not a character string
util_error("Need character variable names in argument %s", arg_name,
applicability_problem = TRUE)
# this is (at least up to now, may allow symbols here similar
# to subset or with) an error
}
variable[trimws(variable) == ""] <- NA # replace all variable names that are
# empty characters by NA.
}
assign(arg_name, variable, envir = p) # re-assign the possibly modified
# argument value in the caller's environment
if (!allow_na && any(is.na(variable))) {
# if we have NAs in the list of variable names in `arg_name`
# and this is not allowed
util_error("Missing entries not allowed in argument %s", arg_name,
applicability_problem = TRUE)
# then this is an error.
}
# Check whether variables can be found in the data (using all possible label columns).
possible_vars <- unique(c(meta_data[[VAR_NAMES]], # TODO this corresponds with TODO POSSIBLE_VARS in prep_prepare_dataframes
meta_data[[LABEL]],
meta_data[[LONG_LABEL]],
meta_data[[label_col]]))
if (!all(na.omit(variable) %in% possible_vars)) {
# if we have variable names in the caller's variable argument `arg_name`
# missing in the data
non_matching_vars <-
na.omit(variable)[!(na.omit(variable) %in% possible_vars)] # find them
only_in_sd <-
try({
n <- colnames(get("study_data", envir = p))
n[na.omit(match(tolower(non_matching_vars), tolower(n)))]
}, silent = TRUE)
if (util_is_try_error(only_in_sd)) {
only_in_sd <- character(0)
}
if (length(only_in_sd) > 0) {
hint_maybe_miss_in_meta <- sprintf(
paste("\nHINT: I've found the following variables in %s not covered",
"by %s: %s, so, maybe, your metadata is incomplete?"),
"study data",
"metadata",
util_pretty_vector_string(only_in_sd)
)
} else {
hint_maybe_miss_in_meta <- ""
}
fuzzy_match <- vapply( # and try to guess what the user wanted to put there
non_matching_vars,
function(v) {
unique(possible_vars)[which.min(adist(
trimws(v),
trimws(unique(possible_vars)),
ignore.case = TRUE,
fixed = TRUE
))]
}, "")
if (remove_not_found) {
cnd_f <- util_message
} else {
cnd_f <- util_error
}
cnd_f(
"Variable '%s' (%s) not found in metadata. Did you mean '%s'?%s",
# then emit an informative error message.
paste0(non_matching_vars, collapse = ", "),
arg_name,
paste0(fuzzy_match, collapse = ", "),
hint_maybe_miss_in_meta,
applicability_problem = TRUE,
intrinsic_applicability_problem = TRUE
)
variable <- setdiff(non_matching_vars, non_matching_vars)
re_check <- TRUE
if (overwrite) {
# Pass the 'variable' vector to the environment to use it within the calling function.
assign(arg_name, variable, envir = parent.frame())
}
} else {
# If users mix VAR_NAMES and LABELs (and maybe also LONG_LABELs), we need to
# map the variable names to the column names of ds1.
if (!all(na.omit(variable) %in% colnames(ds1))) {
non_matching_ind <- intersect(which(!(variable %in% colnames(ds1))),
which(!is.na(variable)))
non_matching_vars <- variable[non_matching_ind]
other_col <- setdiff(c(VAR_NAMES, LABEL, LONG_LABEL), label_col)
other_col <- intersect(other_col, colnames(meta_data))
map_res <- lapply(setNames(nm = other_col), function(oc) {
unname(
util_map_labels(
non_matching_vars,
warn_ambiguous = TRUE,
meta_data = meta_data,
to = label_col,
from = oc,
ifnotfound = NA_character_
)
)
})
map_res <- as.data.frame(map_res)
# check whether the user-specified variable could not be found in any of the other columns:
map_res_NA <- vapply(
1:nrow(map_res),
FUN.VALUE = logical(1),
FUN = function(i) {
all(is.na(map_res[i, ]))
}
)
if (any(map_res_NA)) { # may be dead code?
util_error("Variable '%s' (%s) not found in the metadata.",
paste0(non_matching_vars[map_res_NA],
collapse = ", "),
arg_name,
applicability_problem = TRUE)
}
# check whether the user-specified variable was found in different label columns and maps to different variables (= ambiguity)
map_res_ambiguous <- vapply(
1:nrow(map_res),
FUN.VALUE = logical(1),
FUN = function(i) {
length(unique(na.omit(as.character(map_res[i, ])))) > 1
}
)
if (any(map_res_ambiguous)) {
util_warning("Variable '%s' (%s) is ambiguous in the metadata.",
paste0(non_matching_vars[map_res_ambiguous],
collapse = ", "),
arg_name,
applicability_problem = TRUE)
}
variable[non_matching_ind] <- vapply(
1:nrow(map_res),
FUN.VALUE = character(1),
FUN = function(i) {
unique(na.omit(as.character(map_res[i, ])))[1]
# We select here the first element, such that in case of ambiguities
# VAR_NAME is preferred over LABEL and LONG_LABEL, and LABEL over LONG_LABEL.
# If there are no ambiguities, this works as well.
}
)
# The 'variable' vector contains now all variable names according to label_col.
if (overwrite) {
# Pass the 'variable' vector to the environment to use it within the calling function.
assign(arg_name, variable, envir = parent.frame())
}
}
}
record_problem <- ifelse(do_not_stop, util_message, util_error)
applicability_problem <- ifelse(do_not_stop, FALSE, TRUE)
intrinsic_applicability_problem <- ifelse(do_not_stop, FALSE, TRUE)
data_problem_container <- new.env(parent = emptyenv())
for (v in variable) { # now, check all variable values from the data
if (!allow_all_obs_na && all(is.na(ds1[[v]]))) {
if (is.na(v)) {
# if all observations are NA and this is prohibited
record_problem("There are NAs in the variable names passed in %s",
arg_name,
applicability_problem = applicability_problem,
intrinsic_applicability_problem =
intrinsic_applicability_problem)
} else{
# if all observations are NA and this is prohibited
record_problem("Variable '%s' (%s) has only NA observations",
na.omit(v)[na.omit(v) %in% colnames(ds1)], arg_name,
applicability_problem = applicability_problem,
intrinsic_applicability_problem =
intrinsic_applicability_problem)
}
data_problem_container[[v]] <- TRUE
}
# names(empty_containter) gibt die geflaggten Variablen
if (!allow_any_obs_na && any(is.na(ds1[[v]]))) {
# if no NAs are allowed at all, but we have some
record_problem("Variable '%s' (%s) has NA observations, which is not allowed",
na.omit(v)[na.omit(v) %in% colnames(ds1)], arg_name,
applicability_problem = applicability_problem,
intrinsic_applicability_problem =
intrinsic_applicability_problem)
data_problem_container[[v]] <- TRUE
}
if (min_distinct_values > 0) {
uniq_rv <- unique(ds1[[v]])
uniq_rv <- uniq_rv[!util_empty(uniq_rv)]
n_distinct_values <- length(uniq_rv)
if (n_distinct_values < min_distinct_values) {
# if we have fewer distinct values than required
record_problem(c("Variable '%s' (%s) has fewer distinct values than required",
"for the argument %s of %s"),
na.omit(v)[na.omit(v) %in% colnames(ds1)], arg_name,
sQuote(arg_name),
sQuote(rlang::caller_call()[[1]]),
applicability_problem = applicability_problem,
intrinsic_applicability_problem =
intrinsic_applicability_problem)
data_problem_container[[v]] <- TRUE
}
}
}
if (length(names(data_problem_container)) > 0) {
variable <- setdiff(variable, names(data_problem_container))
if (length(variable) == 0) {
util_error(
"In %s, none of the specified variables matches the requirements.",
dQuote(arg_name),
applicability_problem = TRUE,
intrinsic_applicability_problem = TRUE
)
} else {
util_warning(
c("In %s, variables %s were excluded."),
dQuote(arg_name),
paste(dQuote(names(data_problem_container)), collapse = ", "),
applicability_problem = TRUE,
intrinsic_applicability_problem = TRUE
)
assign(arg_name, variable, envir = p)
}
}
data_type_problem_container <- new.env(parent = emptyenv())
# data type given in metadata? (similar to util_get_meta_from_var ...)
if (DATA_TYPE %in% colnames(meta_data)) {
types <- meta_data[meta_data[[label_col]] %in% variable, DATA_TYPE]
# try to fetch the types from the metadata.
names(types) <- meta_data[meta_data[[label_col]] %in% variable, label_col]
types <- types[!is.na(types) & !is.na(names(types))]
} else {
types <- NULL
names(types) <- NULL
}
data_scale_problem_container <- new.env(parent = emptyenv())
# data type given in metadata? (similar to util_get_meta_from_var ...)
if (SCALE_LEVEL %in% colnames(meta_data)) {
scales <- meta_data[meta_data[[label_col]] %in% variable, SCALE_LEVEL]
# try to fetch the scales from the metadata.
names(scales) <- meta_data[meta_data[[label_col]] %in% variable, label_col]
scales <- scales[!is.na(scales) & !is.na(names(scales))]
} else {
scales <- NULL
names(scales) <- NULL
}
data_role_problem_container <- new.env(parent = emptyenv())
# variable role given in metadata? (similar to util_get_meta_from_var ...)
if (VARIABLE_ROLE %in% colnames(meta_data)) {
roles <- meta_data[meta_data[[label_col]] %in% variable, VARIABLE_ROLE]
# try to fetch the roles from the metadata.
names(roles) <- meta_data[meta_data[[label_col]] %in% variable, label_col]
roles <- roles[!is.na(roles) & !is.na(names(roles))]
} else {
roles <- NULL
names(roles) <- NULL
}
data_computed_role_problem_container <- new.env(parent = emptyenv())
# computed variable role given in metadata? (similar to util_get_meta_from_var ...)
if (!COMPUTED_VARIABLE_ROLE %in% colnames(meta_data)) {
meta_data[[COMPUTED_VARIABLE_ROLE]] <- rep("na", nrow(meta_data))
}
meta_data[[COMPUTED_VARIABLE_ROLE]][
is.na(meta_data[[COMPUTED_VARIABLE_ROLE]])] <- "na"
computed_roles <- meta_data[meta_data[[label_col]] %in% variable,
COMPUTED_VARIABLE_ROLE]
# try to fetch the computed roles from the metadata.
names(computed_roles) <-
meta_data[meta_data[[label_col]] %in% variable, label_col]
computed_roles <-
computed_roles[!is.na(computed_roles) & !is.na(names(computed_roles))]
if (!all(is.na(need_type)) && length(types) <
length(unique(variable[!is.na(variable)]))) {
util_warning(
c("In %s, variables with types matching %s should be specified, but not",
"all variables have a type assigned in the metadata.",
"I have %d variables but only %d types."),
dQuote(arg_name),
dQuote(need_type),
length(unique(variable[!is.na(variable)])),
length(types),
applicability_problem = TRUE
)
}
for (..vname in names(types)) {
# for all variables that have a data type assigned in the metadata
type <- types[[..vname]]
# fetch the type of the currently checked variable
if (!is.null(type) && !is.na(type) && !is.na(need_type)) {
# if we have a needed type and a variable type for the currently checked
# variable,
need_type. <- tolower(trimws(unlist(strsplit(need_type, "|",
fixed = TRUE),
recursive = TRUE)))
# parse the type (split at pipes |)
not_type <-
tolower(trimws(substring(need_type.[startsWith(need_type., "!")], 2)))
# and parse the type for negation (e.g. *not* INTEGER)
well_type <-
tolower(trimws(need_type.[!startsWith(need_type., "!")]))
# and parse the type for no negation resp. (e.g. INTEGER)
if ((length(well_type) > 0) &&
(!all(well_type %in%
tolower(trimws(names(DATA_TYPES)))))) {
util_error(c(
"Internal error:",
"%s's %s contains invalid type names %s (allowed are %s).",
"As a dataquieR developer, you should fix your call of %s."
),
sQuote(arg_name),
sQuote("need_type"),
paste(dQuote(
well_type[!(well_type %in%
tolower(trimws(names(DATA_TYPES))))]
), collapse = ", "),
paste(dQuote(tolower(trimws(names(DATA_TYPES)))), collapse = ", "),
sQuote(rlang::caller_call()[[1]])
)
}
if ((length(not_type) > 0) &&
(!all(not_type %in%
tolower(trimws(names(DATA_TYPES)))))) {
util_error(c(
"Internal error:",
"%s's %s contains invalid !type names %s (allowed are %s).",
"As a dataquieR developer, you should fix your call of %s."
),
sQuote(arg_name),
sQuote("need_type"),
paste(dQuote(
not_type[!(not_type %in%
tolower(trimws(names(DATA_TYPES))))]
), collapse = ", "),
paste(dQuote(tolower(trimws(names(DATA_TYPES)))), collapse = ", "),
sQuote(rlang::caller_call()[[1]])
)
}
if ((length(well_type) > 0) && (!tolower(trimws(type)) %in% well_type)) {
# now check for the allowed types
record_problem(
"Argument %s: Variable '%s' (%s) does not have an allowed type (%s)",
dQuote(arg_name), ..vname, tolower(trimws(type)), need_type,
applicability_problem = TRUE,
intrinsic_applicability_problem = TRUE)
data_type_problem_container[[..vname]] <- TRUE
}
if ((length(not_type) > 0) && (tolower(trimws(type)) %in% not_type)) {
# and for the disallowed types
record_problem(
"Argument %s: Variable '%s' (%s) has a disallowed type (%s)",
dQuote(arg_name), ..vname, tolower(trimws(type)),
util_pretty_vector_string(not_type),
applicability_problem = TRUE,
intrinsic_applicability_problem = TRUE)
data_type_problem_container[[..vname]] <- TRUE
}
# Check, if variable is really of declared data type.
sd_type <- prep_datatype_from_data(..vname, ds1)
if (!is.na(sd_type) && sd_type != type) {
if (sd_type != DATA_TYPES$INTEGER || type != DATA_TYPES$FLOAT) {
util_message(
c("Argument %s: Variable '%s' (%s) does not have matching",
"data type in the study data (%s)"),
dQuote(arg_name), ..vname, tolower(trimws(type)),
prep_dq_data_type_of(ds1[, ..vname, TRUE]),
applicability_problem = TRUE)
}
}
} else { # nocov start
# if the type is NA, it is not part of the types vector
# so this is dead code, likely (see
# "types <- types[!is.na(types) & !is.na(names(types))]" above).
if (!is.na(need_type)) {
util_warning(
c("Argument %s: No data type found for '%s' in the",
"metadata, cannot check type"), dQuote(arg_name), variable,
applicability_problem = TRUE)
}
} # nocov end
}
if (length(names(data_type_problem_container)) > 0) {
variable <- setdiff(variable, names(data_type_problem_container))
if (length(variable) == 0) {
util_error(
"In %s, none of the specified variables matches the requirements.",
dQuote(arg_name),
applicability_problem = TRUE,
intrinsic_applicability_problem = TRUE
)
} else {
util_warning(
c("In %s, variables %s were excluded."),
dQuote(arg_name),
paste(dQuote(names(data_type_problem_container)), collapse = ", "),
applicability_problem = TRUE,
intrinsic_applicability_problem = TRUE
)
assign(arg_name, variable, envir = p)
}
}
# TODO EK: Should we support hierarchy of sclae levels here, i.e.,
# util_correct_variable_use(resp_vars, need_scale = SCALE_LEVELS$ORDINAL)
# would pass, if SBP_0 is ratio so even "better" than ordinal? But maybe,
# we want to explicitly break the hierarchy for certain descriptors, e.g., run
# a function only for ordinal variables but not for ratio ones.
if (!all(is.na(need_scale)) && length(scales) <
length(unique(variable[!is.na(variable)]))) {
util_warning(
c("In %s, variables with scale levels matching %s should be specified, but not",
"all variables have a scale level assigned in the metadata.",
"I have %d variables but only %d scale levels"),
dQuote(arg_name),
dQuote(need_scale),
length(unique(variable[!is.na(variable)])),
length(scales),
applicability_problem = TRUE
)
}
for (..vname in names(scales)) {
# for all variables that have a scale level assigned in the metadata
scale <- scales[[..vname]]
# fetch the scale level of the currently checked variable
if (!is.null(scale) && !is.na(scale) && !is.na(need_scale)) {
# if we have a needed scale level and a variable scale leve for the
# currently checked variable,
need_scale. <- tolower(trimws(unlist(strsplit(need_scale, "|",
fixed = TRUE),
recursive = TRUE)))
# parse the scale level (split at pipes |)
not_scale <-
tolower(trimws(substring(need_scale.[startsWith(need_scale., "!")], 2)))
# and parse the scale level for negation (e.g. *not* NOMINAL)
well_scale <-
tolower(trimws(need_scale.[!startsWith(need_scale., "!")]))
# and parse the scale level for no negation resp. (e.g. NOMINAL)
if ((length(well_scale) > 0) &&
(!all(well_scale %in%
tolower(trimws(names(SCALE_LEVELS)))))) {
util_error(c( # TODO EK This should not happen outside pipelines, then it should be a warning only.
"Internal error:",
"%s's %s contains invalid scale-level names %s (allowed are %s).",
"As a dataquieR developer, you should fix your call of %s."
),
sQuote(arg_name),
sQuote("need_scale"),
paste(dQuote(
well_scale[!(well_scale %in%
tolower(trimws(names(SCALE_LEVELS))))]
), collapse = ", "),
paste(dQuote(tolower(trimws(names(SCALE_LEVELS)))), collapse = ", "),
sQuote(rlang::caller_call()[[1]])
)
}
if ((length(not_scale) > 0) &&
(!all(not_scale %in%
tolower(trimws(names(SCALE_LEVELS)))))) {
util_error(c(
"Internal error:",
"%s's %s contains invalid !scale-level names %s (allowed are %s).",
"As a dataquieR developer, you should fix your call of %s."
),
sQuote(arg_name),
sQuote("need_scale"),
paste(dQuote(
not_scale[!(not_scale %in%
tolower(trimws(names(SCALE_LEVELS))))]
), collapse = ", "),
paste(dQuote(tolower(trimws(names(SCALE_LEVELS)))), collapse = ", "),
sQuote(rlang::caller_call()[[1]])
)
}
if ((length(well_scale) > 0) && (!tolower(trimws(scale)) %in% well_scale)) {
# now check for the allowed scale levels
record_problem(
"Argument %s: Variable '%s' (%s) does not have an allowed scale level (%s)",
dQuote(arg_name), ..vname, tolower(trimws(scale)), need_scale,
applicability_problem = TRUE,
intrinsic_applicability_problem = TRUE)
data_scale_problem_container[[..vname]] <- TRUE
}
if ((length(not_scale) > 0) && (tolower(trimws(scale)) %in% not_scale)) {
# and for the disallowed scale levels
record_problem(
"Argument %s: Variable '%s' (%s) has a disallowed scale level (%s)",
dQuote(arg_name), ..vname, tolower(trimws(scale)),
util_pretty_vector_string(not_scale),
applicability_problem = TRUE,
intrinsic_applicability_problem = TRUE)
data_scale_problem_container[[..vname]] <- TRUE
}
# TODO: Implement this check also for scale levels
# # Check, if variable is really of declared scale level.
# sd_scale <- prep_scale_level_from_data(..vname, ds1)
# if (!is.na(sd_scale) && sd_scale != scale) {
# util_message(
# c("Argument %s: Variable '%s' (%s) does not have matching",
# "scale level in the study data (%s)"),
# dQuote(arg_name), ..vname, tolower(trimws(scale)),
# prep_scale_level_from_data(ds1[, ..vname, TRUE]),
# applicability_problem = TRUE)
# }
} else { # nocov start
# if the scale is NA, it is not part of the scales vector
# so this is dead code, likely (see
# "types <- types[!is.na(types) & !is.na(names(types))]" above).
if (!is.na(need_scale)) {
util_warning(
c("Argument %s: No scale level found for '%s' in the",
"metadata, cannot check scale level"), dQuote(arg_name), variable,
applicability_problem = TRUE)
}
} # nocov end
}
if (length(names(data_scale_problem_container)) > 0) {
variable <- setdiff(variable, names(data_scale_problem_container))
if (length(variable) == 0) {
util_error(
"In %s, none of the specified variables matches the requirements.",
dQuote(arg_name),
applicability_problem = TRUE,
intrinsic_applicability_problem = TRUE
)
} else {
util_warning(
c("In %s, variables %s were excluded."),
dQuote(arg_name),
paste(dQuote(names(data_scale_problem_container)), collapse = ", "),
applicability_problem = TRUE,
intrinsic_applicability_problem = TRUE
)
assign(arg_name, variable, envir = p)
}
}
if (!all(is.na(need_role)) && length(roles) <
length(unique(variable[!is.na(variable)]))) {
util_warning(
c("In %s, variables with roles matching %s should be specified, but not",
"all variables have a role assigned in the metadata.",
"I have %d variables but only %d roles"),
dQuote(arg_name),
dQuote(need_role),
length(unique(variable[!is.na(variable)])),
length(roles),
applicability_problem = TRUE
)
}
for (..vname in names(roles)) {
# for all variables that have a variable role assigned in the metadata
role <- roles[[..vname]]
# fetch the variable role of the currently checked variable
if (!is.null(role) && !is.na(role) && !is.na(need_role)) {
# if we have a needed variable role and a variable role for the
# currently checked variable,
need_role. <- tolower(trimws(unlist(strsplit(need_role, "|",
fixed = TRUE),
recursive = TRUE)))
# parse the variable role (split at pipes |)
not_role <-
tolower(trimws(substring(need_role.[startsWith(need_role., "!")], 2)))
# and parse the variable role for negation (e.g. *not* CONTEXT)
well_role <-
tolower(trimws(need_role.[!startsWith(need_role., "!")]))
# and parse the variable role for no negation resp. (e.g. ANALYSIS)
if ((length(well_role) > 0) &&
(!all(well_role %in%
tolower(trimws(names(VARIABLE_ROLES)))))) {
util_error(c(
"Internal error:",
"%s's %s contains invalid variable role names %s (allowed are %s).",
"As a dataquieR developer, you should fix your call of %s."
),
sQuote(arg_name),
sQuote("need_role"),
paste(dQuote(
well_role[!(well_role %in%
tolower(trimws(names(VARIABLE_ROLES))))]
), collapse = ", "),
paste(dQuote(tolower(trimws(names(VARIABLE_ROLES)))), collapse = ", "),
sQuote(rlang::caller_call()[[1]])
)
}
if ((length(not_role) > 0) &&
(!all(not_role %in%
tolower(trimws(names(VARIABLE_ROLES)))))) {
util_error(c(
"Internal error:",
"%s's %s contains invalid !variable role names %s (allowed are %s).",
"As a dataquieR developer, you should fix your call of %s."
),
sQuote(arg_name),
sQuote("need_role"),
paste(dQuote(
not_role[!(not_role %in%
tolower(trimws(names(VARIABLE_ROLES))))]
), collapse = ", "),
paste(dQuote(tolower(trimws(names(VARIABLE_ROLES)))), collapse = ", "),
sQuote(rlang::caller_call()[[1]])
)
}
if ((length(well_role) > 0) && (!tolower(trimws(role)) %in% well_role)) {
# now check for the allowed variable roles
record_problem(
"Argument %s: Variable '%s' (%s) does not have an allowed variable role (%s)",
dQuote(arg_name), ..vname, tolower(trimws(role)), need_role,
applicability_problem = TRUE,
intrinsic_applicability_problem = TRUE)
data_role_problem_container[[..vname]] <- TRUE
}
if ((length(not_role) > 0) && (tolower(trimws(role)) %in% not_role)) {
# and for the disallowed variable roles
record_problem(
"Argument %s: Variable '%s' (%s) has a disallowed variable role (%s)",
dQuote(arg_name), ..vname, tolower(trimws(role)),
util_pretty_vector_string(not_role),
applicability_problem = TRUE,
intrinsic_applicability_problem = TRUE)
data_role_problem_container[[..vname]] <- TRUE
}
} else { # nocov start
if (!is.na(need_role)) {
util_warning(
c("Argument %s: No variable role found for '%s' in the",
"metadata, cannot check variable role"), dQuote(arg_name), variable,
applicability_problem = TRUE)
}
} # nocov end
}
if (length(names(data_role_problem_container)) > 0) {
variable <- setdiff(variable, names(data_role_problem_container))
if (length(variable) == 0) {
util_error(
"In %s, none of the specified variables matches the requirements.",
dQuote(arg_name),
applicability_problem = TRUE,
intrinsic_applicability_problem = TRUE
)
} else {
util_warning(
c("In %s, variables %s were excluded."),
dQuote(arg_name),
paste(dQuote(names(data_role_problem_container)), collapse = ", "),
applicability_problem = TRUE,
intrinsic_applicability_problem = TRUE
)
assign(arg_name, variable, envir = p)
}
}
if (!all(is.na(need_computed_role)) && length(computed_roles) <
length(unique(variable[!is.na(variable)]))) {
util_warning(
c("In %s, variables with computed roles matching %s should be specified, but not",
"all variables have a computed role assigned in the metadata.",
"I have %d variables but only %d computed roles"),
dQuote(arg_name),
dQuote(need_computed_role),
length(unique(variable[!is.na(variable)])),
length(computed_roles),
applicability_problem = TRUE
)
}
for (..vname in names(computed_roles)) {
# for all variables that have a computed variable role assigned in the metadata
computed_role <- computed_roles[[..vname]]
# fetch the computed variable role of the currently checked variable
if (!is.null(computed_role) && !is.na(computed_role) &&
!is.na(need_computed_role)) {
# if we have a needed computed variable role and a computed variable
# role for the currently checked variable,
need_computed_role. <-
tolower(trimws(unlist(strsplit(need_computed_role, "|",
fixed = TRUE),
recursive = TRUE)))
# parse the computed variable role (split at pipes |)
not_computed_role <-
tolower(trimws(substring(
need_computed_role.[startsWith(need_computed_role., "!")], 2)))
# and parse the computed variable role for negation
well_computed_role <-
tolower(trimws(
need_computed_role.[!startsWith(need_computed_role., "!")]))
# and parse the computed variable role for no negation
if ((length(well_computed_role) > 0) &&
(!all(well_computed_role %in%
tolower(trimws(names(COMPUTED_VARIABLE_ROLES)))))) {
util_error(c(
"Internal error:",
"%s's %s contains invalid computed variable role names %s (allowed are %s).",
"As a dataquieR developer, you should fix your call of %s."
),
sQuote(arg_name),
sQuote("need_computed_role"),
paste(dQuote(
well_computed_role[!(well_computed_role %in%
tolower(trimws(names(COMPUTED_VARIABLE_ROLES))))]
), collapse = ", "),
paste(dQuote(tolower(trimws(names(COMPUTED_VARIABLE_ROLES)))), collapse = ", "),
sQuote(rlang::caller_call()[[1]])
)
}
if ((length(not_computed_role) > 0) &&
(!all(not_computed_role %in%
tolower(trimws(names(COMPUTED_VARIABLE_ROLES)))))) {
util_error(c(
"Internal error:",
"%s's %s contains invalid !computed variable role names %s (allowed are %s).",
"As a dataquieR developer, you should fix your call of %s."
),
sQuote(arg_name),
sQuote("need_computed_role"),
paste(dQuote(
not_computed_role[!(not_computed_role %in%
tolower(trimws(names(COMPUTED_VARIABLE_ROLES))))]
), collapse = ", "),
paste(dQuote(tolower(trimws(names(COMPUTED_VARIABLE_ROLES)))), collapse = ", "),
sQuote(rlang::caller_call()[[1]])
)
}
if ((length(well_computed_role) > 0) &&
(!tolower(trimws(computed_role)) %in% well_computed_role)) {
# now check for the allowed computed variable roles
record_problem(
"Argument %s: Variable '%s' (%s) does not have an allowed computed variable role (%s)",
dQuote(arg_name), ..vname, tolower(trimws(computed_role)),
need_computed_role,
applicability_problem = TRUE,
intrinsic_applicability_problem = TRUE)
data_computed_role_problem_container[[..vname]] <- TRUE
}
if ((length(not_computed_role) > 0) &&
(tolower(trimws(computed_role)) %in% not_computed_role)) {
# and for the disallowed computed variable roles
record_problem(
"Argument %s: Variable '%s' (%s) has a disallowed computed variable role (%s)",
dQuote(arg_name), ..vname, tolower(trimws(computed_role)),
util_pretty_vector_string(not_computed_role),
applicability_problem = TRUE,
intrinsic_applicability_problem = TRUE)
data_computed_role_problem_container[[..vname]] <- TRUE
}
} else { # nocov start
if (!is.na(need_computed_role)) {
util_warning(
c("Argument %s: No computed variable role found for '%s' in the",
"metadata, cannot check computed variable role"),
dQuote(arg_name), variable,
applicability_problem = TRUE)
}
} # nocov end
}
if (length(names(data_computed_role_problem_container)) > 0) {
variable <- setdiff(variable, names(data_computed_role_problem_container))
if (length(variable) == 0) {
util_error(
"In %s, none of the specified variables matches the requirements.",
dQuote(arg_name),
applicability_problem = TRUE,
intrinsic_applicability_problem = TRUE
)
} else {
util_warning(
c("In %s, variables %s were excluded."),
dQuote(arg_name),
paste(dQuote(names(data_computed_role_problem_container)),
collapse = ", "),
applicability_problem = TRUE,
intrinsic_applicability_problem = TRUE
)
assign(arg_name, variable, envir = p)
}
}
}
}
#' Variable-argument roles
#'
#' A Variable-argument role is the intended use of an argument of a indicator
#' function -- an argument that refers variables.
#' In general for the table .variable_arg_roles, the suffix _var means one
#' variable allowed,
#' while _vars means more than one. The default sets of arguments
#' for `util_correct_variable_use`/`util_correct_variable_use2` are defined
#' from the point of usage, e.g. if it could be, that NAs are in
#' the list of variable names, the function should be able to remove certain
#' response variables
#' from the output and not disallow them by setting `allow_na` to `FALSE`.
#'
#' @seealso `util_correct_variable_use()`
#' @seealso `util_correct_variable_use2()`
#'
#' @keywords internal
.variable_arg_roles <-
dplyr::tribble(
~name, ~allow_na, ~allow_more_than_one, ~allow_null, ~allow_all_obs_na,
~allow_any_obs_na, ~min_distinct_values, ~need_type, ~need_scale,
~need_role, ~need_computed_role,
"resp_var", FALSE, FALSE, FALSE, FALSE, TRUE, 0, NA, NA, NA, NA,
"response_var", FALSE, FALSE, FALSE, FALSE, TRUE, 0, NA, NA, NA, NA,
"resp_vars", FALSE, TRUE, FALSE, FALSE, TRUE, 0, NA, NA, NA, NA,
"response_vars", FALSE, TRUE, FALSE, FALSE, TRUE, 0, NA, NA, NA, NA,
"control_vars", TRUE, TRUE, TRUE, FALSE, TRUE, 0, NA, NA, NA, NA,
"co_vars", TRUE, TRUE, TRUE, FALSE, TRUE, 0, NA, NA, NA, NA,
"cluster_vars", FALSE, TRUE, FALSE, FALSE, FALSE, 0, NA, NA, NA, NA,
"group_vars", FALSE, TRUE, FALSE, FALSE, FALSE, 0, NA, NA, NA, NA,
"level_vars", FALSE, TRUE, FALSE, FALSE, FALSE, 0, NA, NA, NA, NA,
"cluster_var", FALSE, FALSE, TRUE, FALSE, TRUE, 0, NA, NA, NA, NA,
"level_var", FALSE, FALSE, TRUE, FALSE, TRUE, 0, NA, NA, NA, NA,
"strata_vars", FALSE, FALSE, TRUE, FALSE, TRUE, 0, NA, NA, NA, NA,
"time_vars", FALSE, FALSE, FALSE, FALSE, FALSE, 0, NA, NA, NA, NA,
"id_vars", FALSE, FALSE, FALSE, FALSE, FALSE, 0, NA, NA, NA, NA
)
# "process_vars",
# "key_segment_vars"
#' @importFrom stats na.omit
#' @rdname util_correct_variable_use
#' @family robustness_functions
#' @concept robustness
#' @noRd
util_correct_variable_use2 <- util_correct_variable_use
formals(util_correct_variable_use2)[["role"]] <- quote(arg_name)
Try the dataquieR package in your browser
Any scripts or data that you put into this service are public.
dataquieR documentation built on May 12, 2026, 1:06 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions util_correct_variable_use
#' Check referred variables
#'
#' This function operates in the environment of its caller
#' (using [eval.parent], similar to [Function like C-Preprocessor-Macros](
#' https://www.programiz.com/c-programming/c-preprocessor-macros#example-define)
#' ).
#' Different from the other utility function that work
#' in the caller's environment ([prep_prepare_dataframes]), It has no side
#' effects except that the argument
#' of the calling function specified in `arg_name` is normalized (set to its
#' default or a general default if missing, variable names being all white
#' space replaced by NAs).
#' It expects two objects in the caller's environment: `ds1` and `meta_data`.
#' `meta_data` is the metadata data frame and `ds1` is produced by a preceding
#' call of [prep_prepare_dataframes] using `meta_data` and `study_data`.
#' So this function can only be used after calling the function
#' [prep_prepare_dataframes]
#'
#' `util_correct_variable_use` and `util_correct_variable_use2` differ only in
#' the default of the argument `role`.
#'
#' `util_correct_variable_use` and `util_correct_variable_use2` put strong
#' effort on producing compressible
#' error messages to the caller's caller (who is typically an end user of
#' a `dataquieR` function).
#'
#' The function ensures, that a specified argument of its caller that refers
#' variable names
#' (one or more as character vector) matches some expectations.
#'
#' This function accesses the caller's environment!
#'
#' @param arg_name [character] Name of a function argument of the caller
#' of `util_correct_variable_use`
#' @param allow_na [logical] default = FALSE. allow NAs in the variable names
#' argument given in `arg_name`
#' @param allow_more_than_one [logical] default = FALSE. allow more than one
#' variable names in `arg_name`
#' @param allow_null [logical] default = FALSE. allow an empty variable name
#' vector in the argument `arg_name`
#' @param allow_all_obs_na [logical] default = TRUE. check observations for not
#' being all `NA`
#' @param allow_any_obs_na [logical] default = TRUE. check observations for
#' being complete without any `NA`
#' @param min_distinct_values [integer] Minimum number of distinct observed
#' values of a study variable
#' @param need_type [character] if not `NA`, variables must be of data type
#' `need_type` according to the metadata,
#' can be a pipe (`|`) separated list of
#' allowed data types. Use `!` to exclude
#' a type. See [DATA_TYPES] for the
#' predefined variable types of the
#' `dataquieR` concept.
#' @param need_scale [character] if not `NA`, variables must be of scale level
#' `need_scale` according to the metadata,
#' can be a pipe (`|`) separated list of
#' allowed scale levels. Use `!` to exclude
#' a level. See [SCALE_LEVELS] for the
#' predefined scale levels of the
#' `dataquieR` concept.
#' @param need_role [character] see `need_scale`, but looks for `VARIABLE_ROLE`
#' @param need_computed_role [character] see `need_scale`, but looks for
#' `COMPUTED_VARIABLE_ROLE`
#' @param role [character] variable-argument role. Set different defaults for
#' all `allow`-arguments and `need_type` of
#' this `util_correct_variable_use.`. If given, it
#' defines the intended use
#' of the verified argument. For typical arguments and
#' typical use cases, roles
#' are predefined in [.variable_arg_roles].
#' The role's defaults can be overwritten by the
#' arguments. If `role` is "" (default),
#' the standards are `allow_na = FALSE`,
#' `allow_more_than_one = FALSE`, `allow_null = FALSE`,
#' `allow_all_obs_na = TRUE`, `allow_any_obs_na = TRUE`,
#' and `need_type = NA`.
#' Use `util_correct_variable_use2` for using the
#' `arg_name` as default for `role`.
#' See [.variable_arg_roles] for currently available
#' variable-argument roles.
#' @param overwrite [logical] overwrite vector of variable names
#' to match the labels given in `label_col`.
#' @param do_not_stop [logical] do not throw an error, if one of the variables
#' violates `allow_all_obs_na`, `allow_any_obs_na` or
#' `min_distinct_values`. Instead, the variable will be
#' removed from `arg_name` in the parent environment
#' with a warning. This is helpful for functions which
#' work with multiple variables.
#' @param remove_not_found [logical]
#' if variables are missing from the sutdy data, ignore
#' them
#'
#' @seealso [.variable_arg_roles]
#' @importFrom stats na.omit
#'
#' @family robustness_functions
#' @concept robustness
#' @noRd
util_correct_variable_use <- function(arg_name,
allow_na,
allow_more_than_one,
allow_null,
allow_all_obs_na,
allow_any_obs_na,
min_distinct_values,
need_type,
need_scale,
need_role,
need_computed_role,
role = "",
overwrite = TRUE,
do_not_stop = FALSE,
remove_not_found = FALSE) {
re_check <- TRUE
while (re_check) {
re_check <- FALSE
# interpret the arg_name argument
try({
arg_name <- as.character(substitute(arg_name))
}, # if called with a symbol, get that symbol as a character,
silent = TRUE # if called with a character, do nothing
)
if (!all(is.character(arg_name))) { # nocov start
# if we did not get a character up to here, there is an error in
# calling this util_correct_variable_use
# this should never happen anyway, so cannot test this
util_error(c(
"argument arg_name must be either one character or one symbol,",
"wrong use of util_correct_variable_use?"))
} # nocov end
if (length(arg_name) != 1) {
# if we have 0 or more than one argument name, this is also an
# error in calling util_correct_variable_use
util_error(c(
"argument arg_name must be of length 1,",
"wrong use of util_correct_variable_use?"))
}
# verify the "roles" argument
if (role %in% .variable_arg_roles$name) {
# if `role` is a known variable-argument role
if (missing(allow_na)) { # if missing the allow_na argument
allow_na <- subset(.variable_arg_roles, get("name") == role,
"allow_na", drop = TRUE)
} # fetch it from the role's defaults
if (missing(allow_more_than_one)) {
# if missing the allow_more_than_one argument
allow_more_than_one <- subset(.variable_arg_roles, get("name") == role,
"allow_more_than_one", drop = TRUE)
} # fetch it from the role's defaults
if (missing(allow_null)) { # if missing the allow_null argument
allow_null <- subset(.variable_arg_roles, get("name") == role,
"allow_null", drop = TRUE)
} # fetch it from the role's defaults
if (missing(allow_all_obs_na)) { # if missing the allow_all_obs_na argument
allow_all_obs_na <- subset(.variable_arg_roles, get("name") == role,
"allow_all_obs_na", drop = TRUE)
} # fetch it from the role's defaults
if (missing(allow_any_obs_na)) { # if missing the allow_any_obs_na argument
allow_any_obs_na <- subset(.variable_arg_roles, get("name") == role,
"allow_any_obs_na", drop = TRUE)
} # fetch it from the role's defaults
if (missing(min_distinct_values)) {
# if missing the min_distinct_values argument
min_distinct_values <- subset(.variable_arg_roles, get("name") == role,
"min_distinct_values", drop = TRUE)
} # fetch it from the role's defaults
if (missing(need_type)) { # if missing the need_type argument
need_type <- subset(.variable_arg_roles, get("name") == role,
"need_type", drop = TRUE)
} # fetch it from the role's defaults
if (missing(need_scale)) { # if missing the need_scale argument
need_scale <- subset(.variable_arg_roles, get("name") == role,
"need_scale", drop = TRUE)
} # fetch it from the role's defaults
if (missing(need_role)) { # if missing the need_role argument
need_role <- subset(.variable_arg_roles, get("name") == role,
"need_role", drop = TRUE)
} # fetch it from the role's defaults
if (missing(need_computed_role)) { # if missing the need_computed_role argument
need_computed_role <- subset(.variable_arg_roles, get("name") == role,
"need_computed_role", drop = TRUE)
} # fetch it from the role's defaults
} else { # no known variable-argument in argument `role`
if (role != "") { # if role is not empty
util_error(
c("Unknown variable-argument role: %s for argument %s,",
"wrong use of util_correct_variable_use?"),
role, arg_name
) # this is again a wrong use of this function.
}
if (missing(allow_na)) {
# set the default for allow_na if it has not been given
allow_na <- FALSE
}
if (missing(allow_more_than_one)) {
# set the default for allow_more_than_one if it has not been given
allow_more_than_one <- FALSE
}
if (missing(allow_null)) {
# set the default for allow_null if it has not been given
allow_null <- FALSE
}
if (missing(allow_all_obs_na)) {
# set the default for allow_all_obs_na if it has not been given
allow_all_obs_na <- TRUE
}
if (missing(allow_any_obs_na)) {
# set the default for allow_any_obs_na if it has not been given
allow_any_obs_na <- TRUE
}
if (missing(min_distinct_values)) {
# set the default for min_distinct_values if it has not been given
min_distinct_values <- 0
}
if (missing(need_type)) {
# set the default for need_type if it has not been given
need_type <- NA
}
if (missing(need_scale)) {
# set the default for need_scale if it has not been given
need_scale <- NA
}
if (missing(need_role)) {
# set the default for need_role if it has not been given
need_role <- NA
}
if (missing(need_computed_role)) {
# set the default for need_computed_role if it has not been given
need_computed_role <- NA
}
}
p <- parent.frame(1) # access the caller's environment
if (!exists(arg_name, envir = p)) {
# check, if the function argument exists in the calling function.
util_error(
c("Unknown function argument %s checked,",
"wrong use of util_correct_variable_use?"),
arg_name)
}
# if we have a label col, use it
if (exists("label_col", envir = p)) {
# calling function has a label_col argument
label_col <- try(get("label_col", envir = p), silent = TRUE)
# try to get its value
if (inherits(label_col, "try-error")) {
# no value avail, i.e. no default and not given
label_col <- VAR_NAMES # use VAR_NAMES as default
}
} else {
label_col <- VAR_NAMES
# calling function does not support label_col, so use VAR_NAMES as default
}
missing_in_parent <- eval.parent(call("missing", as.symbol(arg_name)))
variable <- try(get(arg_name, envir = p), silent = TRUE)
# try to get the value of the callers argument called `arg_name`.
if (inherits(variable, "try-error")) {
if (missing_in_parent) {
util_warning(
c("Missing argument %s without default value. Setting to NULL. As",
"a dataquieR developer, please add a default value for %s to",
"remove this warning."),
dQuote(arg_name), dQuote(arg_name),
applicability_problem = TRUE)
} else {
util_warning(
c("Could not get value of argument %s for unexpected reasons. Setting",
"to NULL."), arg_name, applicability_problem = TRUE)
util_warning(variable, applicability_problem = TRUE)
}
variable <- NULL
}
if (!exists("ds1", envir = p)) {
# if the calling function does not have a ds1, this is a wrong use of
# util_correct_variable_use
util_error(c(
"Did not find merged study data and metadata ds1.",
"Wrong use of util_correct_variable_use?"))
}
if (!exists("meta_data", envir = p)) {
# if the calling function does not have a meta_data, this is a wrong use of
# util_correct_variable_use
util_error(
"Did not find metadata. Wrong use of util_correct_variable_use?")
}
ds1 <- try(get("ds1", envir = p), silent = TRUE)
# try to fetch the ds1 object from the callers environment
if (!is.data.frame(ds1)) { # it this is not a data frame, this is again a
# wrong use of util_correct_variable_use
util_error(
c("ds1 does not provide merged study data and metadata.",
"Wrong use of util_correct_variable_use?"))
}
meta_data <- try(get("meta_data", envir = p), silent = TRUE)
# try to fetch the meta_data object from the callers environment
if (!is.data.frame(meta_data)) {
# it this is not a data frame, this is again a wrong use of
# util_correct_variable_use
util_error(
c("meta_data does not provide a metadata data frame.",
"Wrong use of util_correct_variable_use?"))
}
if (!allow_null && is.null(variable)) {
# if we need the argument in arg_name, but the user provided NULL
util_error("Argument %s is NULL", arg_name,
applicability_problem = TRUE) # this is an error
}
if (allow_more_than_one) {
# if we allow more than one variable in the argument arg_name
if (!allow_null && length(variable) == 0) {
# and we do need at least one variable name here, but the user did not
# provide any
util_error("Need at least one element in argument %s, got 0", arg_name,
applicability_problem = TRUE)
# this is an error
}
} else { # if we expect one value in the argument arg_name at most
if ((!allow_null && length(variable) != 1) ||
(allow_null && length(variable) > 1)) {
# but the user gave more than one or none although
# allow_null prohibits this
util_error("Need exactly one element in argument %s, got %d: [%s]",
arg_name, length(variable), paste0(variable, collapse = ", "),
applicability_problem = TRUE)
# this is an error
}
}
if (length(variable) > 0) { # if we have at least one variable name
if (!all(is.character(variable) |
is.na(variable))) { # and one name is not a character string
util_error("Need character variable names in argument %s", arg_name,
applicability_problem = TRUE)
# this is (at least up to now, may allow symbols here similar
# to subset or with) an error
}
variable[trimws(variable) == ""] <- NA # replace all variable names that are
# empty characters by NA.
}
assign(arg_name, variable, envir = p) # re-assign the possibly modified
# argument value in the caller's environment
if (!allow_na && any(is.na(variable))) {
# if we have NAs in the list of variable names in `arg_name`
# and this is not allowed
util_error("Missing entries not allowed in argument %s", arg_name,
applicability_problem = TRUE)
# then this is an error.
}
# Check whether variables can be found in the data (using all possible label columns).
possible_vars <- unique(c(meta_data[[VAR_NAMES]], # TODO this corresponds with TODO POSSIBLE_VARS in prep_prepare_dataframes
meta_data[[LABEL]],
meta_data[[LONG_LABEL]],
meta_data[[label_col]]))
if (!all(na.omit(variable) %in% possible_vars)) {
# if we have variable names in the caller's variable argument `arg_name`
# missing in the data
non_matching_vars <-
na.omit(variable)[!(na.omit(variable) %in% possible_vars)] # find them
only_in_sd <-
try({
n <- colnames(get("study_data", envir = p))
n[na.omit(match(tolower(non_matching_vars), tolower(n)))]
}, silent = TRUE)
if (util_is_try_error(only_in_sd)) {
only_in_sd <- character(0)
}
if (length(only_in_sd) > 0) {
hint_maybe_miss_in_meta <- sprintf(
paste("\nHINT: I've found the following variables in %s not covered",
"by %s: %s, so, maybe, your metadata is incomplete?"),
"study data",
"metadata",
util_pretty_vector_string(only_in_sd)
)
} else {
hint_maybe_miss_in_meta <- ""
}
fuzzy_match <- vapply( # and try to guess what the user wanted to put there
non_matching_vars,
function(v) {
unique(possible_vars)[which.min(adist(
trimws(v),
trimws(unique(possible_vars)),
ignore.case = TRUE,
fixed = TRUE
))]
}, "")
if (remove_not_found) {
cnd_f <- util_message
} else {
cnd_f <- util_error
}
cnd_f(
"Variable '%s' (%s) not found in metadata. Did you mean '%s'?%s",
# then emit an informative error message.
paste0(non_matching_vars, collapse = ", "),
arg_name,
paste0(fuzzy_match, collapse = ", "),
hint_maybe_miss_in_meta,
applicability_problem = TRUE,
intrinsic_applicability_problem = TRUE
)
variable <- setdiff(non_matching_vars, non_matching_vars)
re_check <- TRUE
if (overwrite) {
# Pass the 'variable' vector to the environment to use it within the calling function.
assign(arg_name, variable, envir = parent.frame())
}
} else {
# If users mix VAR_NAMES and LABELs (and maybe also LONG_LABELs), we need to
# map the variable names to the column names of ds1.
if (!all(na.omit(variable) %in% colnames(ds1))) {
non_matching_ind <- intersect(which(!(variable %in% colnames(ds1))),
which(!is.na(variable)))
non_matching_vars <- variable[non_matching_ind]
other_col <- setdiff(c(VAR_NAMES, LABEL, LONG_LABEL), label_col)
other_col <- intersect(other_col, colnames(meta_data))
map_res <- lapply(setNames(nm = other_col), function(oc) {
unname(
util_map_labels(
non_matching_vars,
warn_ambiguous = TRUE,
meta_data = meta_data,
to = label_col,
from = oc,
ifnotfound = NA_character_
)
)
})
map_res <- as.data.frame(map_res)
# check whether the user-specified variable could not be found in any of the other columns:
map_res_NA <- vapply(
1:nrow(map_res),
FUN.VALUE = logical(1),
FUN = function(i) {
all(is.na(map_res[i, ]))
}
)
if (any(map_res_NA)) { # may be dead code?
util_error("Variable '%s' (%s) not found in the metadata.",
paste0(non_matching_vars[map_res_NA],
collapse = ", "),
arg_name,
applicability_problem = TRUE)
}
# check whether the user-specified variable was found in different label columns and maps to different variables (= ambiguity)
map_res_ambiguous <- vapply(
1:nrow(map_res),
FUN.VALUE = logical(1),
FUN = function(i) {
length(unique(na.omit(as.character(map_res[i, ])))) > 1
}
)
if (any(map_res_ambiguous)) {
util_warning("Variable '%s' (%s) is ambiguous in the metadata.",
paste0(non_matching_vars[map_res_ambiguous],
collapse = ", "),
arg_name,
applicability_problem = TRUE)
}
variable[non_matching_ind] <- vapply(
1:nrow(map_res),
FUN.VALUE = character(1),
FUN = function(i) {
unique(na.omit(as.character(map_res[i, ])))[1]
# We select here the first element, such that in case of ambiguities
# VAR_NAME is preferred over LABEL and LONG_LABEL, and LABEL over LONG_LABEL.
# If there are no ambiguities, this works as well.
}
)
# The 'variable' vector contains now all variable names according to label_col.
if (overwrite) {
# Pass the 'variable' vector to the environment to use it within the calling function.
assign(arg_name, variable, envir = parent.frame())
}
}
}
record_problem <- ifelse(do_not_stop, util_message, util_error)
applicability_problem <- ifelse(do_not_stop, FALSE, TRUE)
intrinsic_applicability_problem <- ifelse(do_not_stop, FALSE, TRUE)
data_problem_container <- new.env(parent = emptyenv())
for (v in variable) { # now, check all variable values from the data
if (!allow_all_obs_na && all(is.na(ds1[[v]]))) {
if (is.na(v)) {
# if all observations are NA and this is prohibited
record_problem("There are NAs in the variable names passed in %s",
arg_name,
applicability_problem = applicability_problem,
intrinsic_applicability_problem =
intrinsic_applicability_problem)
} else{
# if all observations are NA and this is prohibited
record_problem("Variable '%s' (%s) has only NA observations",
na.omit(v)[na.omit(v) %in% colnames(ds1)], arg_name,
applicability_problem = applicability_problem,
intrinsic_applicability_problem =
intrinsic_applicability_problem)
}
data_problem_container[[v]] <- TRUE
}
# names(empty_containter) gibt die geflaggten Variablen
if (!allow_any_obs_na && any(is.na(ds1[[v]]))) {
# if no NAs are allowed at all, but we have some
record_problem("Variable '%s' (%s) has NA observations, which is not allowed",
na.omit(v)[na.omit(v) %in% colnames(ds1)], arg_name,
applicability_problem = applicability_problem,
intrinsic_applicability_problem =
intrinsic_applicability_problem)
data_problem_container[[v]] <- TRUE
}
if (min_distinct_values > 0) {
uniq_rv <- unique(ds1[[v]])
uniq_rv <- uniq_rv[!util_empty(uniq_rv)]
n_distinct_values <- length(uniq_rv)
if (n_distinct_values < min_distinct_values) {
# if we have fewer distinct values than required
record_problem(c("Variable '%s' (%s) has fewer distinct values than required",
"for the argument %s of %s"),
na.omit(v)[na.omit(v) %in% colnames(ds1)], arg_name,
sQuote(arg_name),
sQuote(rlang::caller_call()[[1]]),
applicability_problem = applicability_problem,
intrinsic_applicability_problem =
intrinsic_applicability_problem)
data_problem_container[[v]] <- TRUE
}
}
}
if (length(names(data_problem_container)) > 0) {
variable <- setdiff(variable, names(data_problem_container))
if (length(variable) == 0) {
util_error(
"In %s, none of the specified variables matches the requirements.",
dQuote(arg_name),
applicability_problem = TRUE,
intrinsic_applicability_problem = TRUE
)
} else {
util_warning(
c("In %s, variables %s were excluded."),
dQuote(arg_name),
paste(dQuote(names(data_problem_container)), collapse = ", "),
applicability_problem = TRUE,
intrinsic_applicability_problem = TRUE
)
assign(arg_name, variable, envir = p)
}
}
data_type_problem_container <- new.env(parent = emptyenv())
# data type given in metadata? (similar to util_get_meta_from_var ...)
if (DATA_TYPE %in% colnames(meta_data)) {
types <- meta_data[meta_data[[label_col]] %in% variable, DATA_TYPE]
# try to fetch the types from the metadata.
names(types) <- meta_data[meta_data[[label_col]] %in% variable, label_col]
types <- types[!is.na(types) & !is.na(names(types))]
} else {
types <- NULL
names(types) <- NULL
}
data_scale_problem_container <- new.env(parent = emptyenv())
# data type given in metadata? (similar to util_get_meta_from_var ...)
if (SCALE_LEVEL %in% colnames(meta_data)) {
scales <- meta_data[meta_data[[label_col]] %in% variable, SCALE_LEVEL]
# try to fetch the scales from the metadata.
names(scales) <- meta_data[meta_data[[label_col]] %in% variable, label_col]
scales <- scales[!is.na(scales) & !is.na(names(scales))]
} else {
scales <- NULL
names(scales) <- NULL
}
data_role_problem_container <- new.env(parent = emptyenv())
# variable role given in metadata? (similar to util_get_meta_from_var ...)
if (VARIABLE_ROLE %in% colnames(meta_data)) {
roles <- meta_data[meta_data[[label_col]] %in% variable, VARIABLE_ROLE]
# try to fetch the roles from the metadata.
names(roles) <- meta_data[meta_data[[label_col]] %in% variable, label_col]
roles <- roles[!is.na(roles) & !is.na(names(roles))]
} else {
roles <- NULL
names(roles) <- NULL
}
data_computed_role_problem_container <- new.env(parent = emptyenv())
# computed variable role given in metadata? (similar to util_get_meta_from_var ...)
if (!COMPUTED_VARIABLE_ROLE %in% colnames(meta_data)) {
meta_data[[COMPUTED_VARIABLE_ROLE]] <- rep("na", nrow(meta_data))
}
meta_data[[COMPUTED_VARIABLE_ROLE]][
is.na(meta_data[[COMPUTED_VARIABLE_ROLE]])] <- "na"
computed_roles <- meta_data[meta_data[[label_col]] %in% variable,
COMPUTED_VARIABLE_ROLE]
# try to fetch the computed roles from the metadata.
names(computed_roles) <-
meta_data[meta_data[[label_col]] %in% variable, label_col]
computed_roles <-
computed_roles[!is.na(computed_roles) & !is.na(names(computed_roles))]
if (!all(is.na(need_type)) && length(types) <
length(unique(variable[!is.na(variable)]))) {
util_warning(
c("In %s, variables with types matching %s should be specified, but not",
"all variables have a type assigned in the metadata.",
"I have %d variables but only %d types."),
dQuote(arg_name),
dQuote(need_type),
length(unique(variable[!is.na(variable)])),
length(types),
applicability_problem = TRUE
)
}
for (..vname in names(types)) {
# for all variables that have a data type assigned in the metadata
type <- types[[..vname]]
# fetch the type of the currently checked variable
if (!is.null(type) && !is.na(type) && !is.na(need_type)) {
# if we have a needed type and a variable type for the currently checked
# variable,
need_type. <- tolower(trimws(unlist(strsplit(need_type, "|",
fixed = TRUE),
recursive = TRUE)))
# parse the type (split at pipes |)
not_type <-
tolower(trimws(substring(need_type.[startsWith(need_type., "!")], 2)))
# and parse the type for negation (e.g. *not* INTEGER)
well_type <-
tolower(trimws(need_type.[!startsWith(need_type., "!")]))
# and parse the type for no negation resp. (e.g. INTEGER)
if ((length(well_type) > 0) &&
(!all(well_type %in%
tolower(trimws(names(DATA_TYPES)))))) {
util_error(c(
"Internal error:",
"%s's %s contains invalid type names %s (allowed are %s).",
"As a dataquieR developer, you should fix your call of %s."
),
sQuote(arg_name),
sQuote("need_type"),
paste(dQuote(
well_type[!(well_type %in%
tolower(trimws(names(DATA_TYPES))))]
), collapse = ", "),
paste(dQuote(tolower(trimws(names(DATA_TYPES)))), collapse = ", "),
sQuote(rlang::caller_call()[[1]])
)
}
if ((length(not_type) > 0) &&
(!all(not_type %in%
tolower(trimws(names(DATA_TYPES)))))) {
util_error(c(
"Internal error:",
"%s's %s contains invalid !type names %s (allowed are %s).",
"As a dataquieR developer, you should fix your call of %s."
),
sQuote(arg_name),
sQuote("need_type"),
paste(dQuote(
not_type[!(not_type %in%
tolower(trimws(names(DATA_TYPES))))]
), collapse = ", "),
paste(dQuote(tolower(trimws(names(DATA_TYPES)))), collapse = ", "),
sQuote(rlang::caller_call()[[1]])
)
}
if ((length(well_type) > 0) && (!tolower(trimws(type)) %in% well_type)) {
# now check for the allowed types
record_problem(
"Argument %s: Variable '%s' (%s) does not have an allowed type (%s)",
dQuote(arg_name), ..vname, tolower(trimws(type)), need_type,
applicability_problem = TRUE,
intrinsic_applicability_problem = TRUE)
data_type_problem_container[[..vname]] <- TRUE
}
if ((length(not_type) > 0) && (tolower(trimws(type)) %in% not_type)) {
# and for the disallowed types
record_problem(
"Argument %s: Variable '%s' (%s) has a disallowed type (%s)",
dQuote(arg_name), ..vname, tolower(trimws(type)),
util_pretty_vector_string(not_type),
applicability_problem = TRUE,
intrinsic_applicability_problem = TRUE)
data_type_problem_container[[..vname]] <- TRUE
}
# Check, if variable is really of declared data type.
sd_type <- prep_datatype_from_data(..vname, ds1)
if (!is.na(sd_type) && sd_type != type) {
if (sd_type != DATA_TYPES$INTEGER || type != DATA_TYPES$FLOAT) {
util_message(
c("Argument %s: Variable '%s' (%s) does not have matching",
"data type in the study data (%s)"),
dQuote(arg_name), ..vname, tolower(trimws(type)),
prep_dq_data_type_of(ds1[, ..vname, TRUE]),
applicability_problem = TRUE)
}
}
} else { # nocov start
# if the type is NA, it is not part of the types vector
# so this is dead code, likely (see
# "types <- types[!is.na(types) & !is.na(names(types))]" above).
if (!is.na(need_type)) {
util_warning(
c("Argument %s: No data type found for '%s' in the",
"metadata, cannot check type"), dQuote(arg_name), variable,
applicability_problem = TRUE)
}
} # nocov end
}
if (length(names(data_type_problem_container)) > 0) {
variable <- setdiff(variable, names(data_type_problem_container))
if (length(variable) == 0) {
util_error(
"In %s, none of the specified variables matches the requirements.",
dQuote(arg_name),
applicability_problem = TRUE,
intrinsic_applicability_problem = TRUE
)
} else {
util_warning(
c("In %s, variables %s were excluded."),
dQuote(arg_name),
paste(dQuote(names(data_type_problem_container)), collapse = ", "),
applicability_problem = TRUE,
intrinsic_applicability_problem = TRUE
)
assign(arg_name, variable, envir = p)
}
}
# TODO EK: Should we support hierarchy of sclae levels here, i.e.,
# util_correct_variable_use(resp_vars, need_scale = SCALE_LEVELS$ORDINAL)
# would pass, if SBP_0 is ratio so even "better" than ordinal? But maybe,
# we want to explicitly break the hierarchy for certain descriptors, e.g., run
# a function only for ordinal variables but not for ratio ones.
if (!all(is.na(need_scale)) && length(scales) <
length(unique(variable[!is.na(variable)]))) {
util_warning(
c("In %s, variables with scale levels matching %s should be specified, but not",
"all variables have a scale level assigned in the metadata.",
"I have %d variables but only %d scale levels"),
dQuote(arg_name),
dQuote(need_scale),
length(unique(variable[!is.na(variable)])),
length(scales),
applicability_problem = TRUE
)
}
for (..vname in names(scales)) {
# for all variables that have a scale level assigned in the metadata
scale <- scales[[..vname]]
# fetch the scale level of the currently checked variable
if (!is.null(scale) && !is.na(scale) && !is.na(need_scale)) {
# if we have a needed scale level and a variable scale leve for the
# currently checked variable,
need_scale. <- tolower(trimws(unlist(strsplit(need_scale, "|",
fixed = TRUE),
recursive = TRUE)))
# parse the scale level (split at pipes |)
not_scale <-
tolower(trimws(substring(need_scale.[startsWith(need_scale., "!")], 2)))
# and parse the scale level for negation (e.g. *not* NOMINAL)
well_scale <-
tolower(trimws(need_scale.[!startsWith(need_scale., "!")]))
# and parse the scale level for no negation resp. (e.g. NOMINAL)
if ((length(well_scale) > 0) &&
(!all(well_scale %in%
tolower(trimws(names(SCALE_LEVELS)))))) {
util_error(c( # TODO EK This should not happen outside pipelines, then it should be a warning only.
"Internal error:",
"%s's %s contains invalid scale-level names %s (allowed are %s).",
"As a dataquieR developer, you should fix your call of %s."
),
sQuote(arg_name),
sQuote("need_scale"),
paste(dQuote(
well_scale[!(well_scale %in%
tolower(trimws(names(SCALE_LEVELS))))]
), collapse = ", "),
paste(dQuote(tolower(trimws(names(SCALE_LEVELS)))), collapse = ", "),
sQuote(rlang::caller_call()[[1]])
)
}
if ((length(not_scale) > 0) &&
(!all(not_scale %in%
tolower(trimws(names(SCALE_LEVELS)))))) {
util_error(c(
"Internal error:",
"%s's %s contains invalid !scale-level names %s (allowed are %s).",
"As a dataquieR developer, you should fix your call of %s."
),
sQuote(arg_name),
sQuote("need_scale"),
paste(dQuote(
not_scale[!(not_scale %in%
tolower(trimws(names(SCALE_LEVELS))))]
), collapse = ", "),
paste(dQuote(tolower(trimws(names(SCALE_LEVELS)))), collapse = ", "),
sQuote(rlang::caller_call()[[1]])
)
}
if ((length(well_scale) > 0) && (!tolower(trimws(scale)) %in% well_scale)) {
# now check for the allowed scale levels
record_problem(
"Argument %s: Variable '%s' (%s) does not have an allowed scale level (%s)",
dQuote(arg_name), ..vname, tolower(trimws(scale)), need_scale,
applicability_problem = TRUE,
intrinsic_applicability_problem = TRUE)
data_scale_problem_container[[..vname]] <- TRUE
}
if ((length(not_scale) > 0) && (tolower(trimws(scale)) %in% not_scale)) {
# and for the disallowed scale levels
record_problem(
"Argument %s: Variable '%s' (%s) has a disallowed scale level (%s)",
dQuote(arg_name), ..vname, tolower(trimws(scale)),
util_pretty_vector_string(not_scale),
applicability_problem = TRUE,
intrinsic_applicability_problem = TRUE)
data_scale_problem_container[[..vname]] <- TRUE
}
# TODO: Implement this check also for scale levels
# # Check, if variable is really of declared scale level.
# sd_scale <- prep_scale_level_from_data(..vname, ds1)
# if (!is.na(sd_scale) && sd_scale != scale) {
# util_message(
# c("Argument %s: Variable '%s' (%s) does not have matching",
# "scale level in the study data (%s)"),
# dQuote(arg_name), ..vname, tolower(trimws(scale)),
# prep_scale_level_from_data(ds1[, ..vname, TRUE]),
# applicability_problem = TRUE)
# }
} else { # nocov start
# if the scale is NA, it is not part of the scales vector
# so this is dead code, likely (see
# "types <- types[!is.na(types) & !is.na(names(types))]" above).
if (!is.na(need_scale)) {
util_warning(
c("Argument %s: No scale level found for '%s' in the",
"metadata, cannot check scale level"), dQuote(arg_name), variable,
applicability_problem = TRUE)
}
} # nocov end
}
if (length(names(data_scale_problem_container)) > 0) {
variable <- setdiff(variable, names(data_scale_problem_container))
if (length(variable) == 0) {
util_error(
"In %s, none of the specified variables matches the requirements.",
dQuote(arg_name),
applicability_problem = TRUE,
intrinsic_applicability_problem = TRUE
)
} else {
util_warning(
c("In %s, variables %s were excluded."),
dQuote(arg_name),
paste(dQuote(names(data_scale_problem_container)), collapse = ", "),
applicability_problem = TRUE,
intrinsic_applicability_problem = TRUE
)
assign(arg_name, variable, envir = p)
}
}
if (!all(is.na(need_role)) && length(roles) <
length(unique(variable[!is.na(variable)]))) {
util_warning(
c("In %s, variables with roles matching %s should be specified, but not",
"all variables have a role assigned in the metadata.",
"I have %d variables but only %d roles"),
dQuote(arg_name),
dQuote(need_role),
length(unique(variable[!is.na(variable)])),
length(roles),
applicability_problem = TRUE
)
}
for (..vname in names(roles)) {
# for all variables that have a variable role assigned in the metadata
role <- roles[[..vname]]
# fetch the variable role of the currently checked variable
if (!is.null(role) && !is.na(role) && !is.na(need_role)) {
# if we have a needed variable role and a variable role for the
# currently checked variable,
need_role. <- tolower(trimws(unlist(strsplit(need_role, "|",
fixed = TRUE),
recursive = TRUE)))
# parse the variable role (split at pipes |)
not_role <-
tolower(trimws(substring(need_role.[startsWith(need_role., "!")], 2)))
# and parse the variable role for negation (e.g. *not* CONTEXT)
well_role <-
tolower(trimws(need_role.[!startsWith(need_role., "!")]))
# and parse the variable role for no negation resp. (e.g. ANALYSIS)
if ((length(well_role) > 0) &&
(!all(well_role %in%
tolower(trimws(names(VARIABLE_ROLES)))))) {
util_error(c(
"Internal error:",
"%s's %s contains invalid variable role names %s (allowed are %s).",
"As a dataquieR developer, you should fix your call of %s."
),
sQuote(arg_name),
sQuote("need_role"),
paste(dQuote(
well_role[!(well_role %in%
tolower(trimws(names(VARIABLE_ROLES))))]
), collapse = ", "),
paste(dQuote(tolower(trimws(names(VARIABLE_ROLES)))), collapse = ", "),
sQuote(rlang::caller_call()[[1]])
)
}
if ((length(not_role) > 0) &&
(!all(not_role %in%
tolower(trimws(names(VARIABLE_ROLES)))))) {
util_error(c(
"Internal error:",
"%s's %s contains invalid !variable role names %s (allowed are %s).",
"As a dataquieR developer, you should fix your call of %s."
),
sQuote(arg_name),
sQuote("need_role"),
paste(dQuote(
not_role[!(not_role %in%
tolower(trimws(names(VARIABLE_ROLES))))]
), collapse = ", "),
paste(dQuote(tolower(trimws(names(VARIABLE_ROLES)))), collapse = ", "),
sQuote(rlang::caller_call()[[1]])
)
}
if ((length(well_role) > 0) && (!tolower(trimws(role)) %in% well_role)) {
# now check for the allowed variable roles
record_problem(
"Argument %s: Variable '%s' (%s) does not have an allowed variable role (%s)",
dQuote(arg_name), ..vname, tolower(trimws(role)), need_role,
applicability_problem = TRUE,
intrinsic_applicability_problem = TRUE)
data_role_problem_container[[..vname]] <- TRUE
}
if ((length(not_role) > 0) && (tolower(trimws(role)) %in% not_role)) {
# and for the disallowed variable roles
record_problem(
"Argument %s: Variable '%s' (%s) has a disallowed variable role (%s)",
dQuote(arg_name), ..vname, tolower(trimws(role)),
util_pretty_vector_string(not_role),
applicability_problem = TRUE,
intrinsic_applicability_problem = TRUE)
data_role_problem_container[[..vname]] <- TRUE
}
} else { # nocov start
if (!is.na(need_role)) {
util_warning(
c("Argument %s: No variable role found for '%s' in the",
"metadata, cannot check variable role"), dQuote(arg_name), variable,
applicability_problem = TRUE)
}
} # nocov end
}
if (length(names(data_role_problem_container)) > 0) {
variable <- setdiff(variable, names(data_role_problem_container))
if (length(variable) == 0) {
util_error(
"In %s, none of the specified variables matches the requirements.",
dQuote(arg_name),
applicability_problem = TRUE,
intrinsic_applicability_problem = TRUE
)
} else {
util_warning(
c("In %s, variables %s were excluded."),
dQuote(arg_name),
paste(dQuote(names(data_role_problem_container)), collapse = ", "),
applicability_problem = TRUE,
intrinsic_applicability_problem = TRUE
)
assign(arg_name, variable, envir = p)
}
}
if (!all(is.na(need_computed_role)) && length(computed_roles) <
length(unique(variable[!is.na(variable)]))) {
util_warning(
c("In %s, variables with computed roles matching %s should be specified, but not",
"all variables have a computed role assigned in the metadata.",
"I have %d variables but only %d computed roles"),
dQuote(arg_name),
dQuote(need_computed_role),
length(unique(variable[!is.na(variable)])),
length(computed_roles),
applicability_problem = TRUE
)
}
for (..vname in names(computed_roles)) {
# for all variables that have a computed variable role assigned in the metadata
computed_role <- computed_roles[[..vname]]
# fetch the computed variable role of the currently checked variable
if (!is.null(computed_role) && !is.na(computed_role) &&
!is.na(need_computed_role)) {
# if we have a needed computed variable role and a computed variable
# role for the currently checked variable,
need_computed_role. <-
tolower(trimws(unlist(strsplit(need_computed_role, "|",
fixed = TRUE),
recursive = TRUE)))
# parse the computed variable role (split at pipes |)
not_computed_role <-
tolower(trimws(substring(
need_computed_role.[startsWith(need_computed_role., "!")], 2)))
# and parse the computed variable role for negation
well_computed_role <-
tolower(trimws(
need_computed_role.[!startsWith(need_computed_role., "!")]))
# and parse the computed variable role for no negation
if ((length(well_computed_role) > 0) &&
(!all(well_computed_role %in%
tolower(trimws(names(COMPUTED_VARIABLE_ROLES)))))) {
util_error(c(
"Internal error:",
"%s's %s contains invalid computed variable role names %s (allowed are %s).",
"As a dataquieR developer, you should fix your call of %s."
),
sQuote(arg_name),
sQuote("need_computed_role"),
paste(dQuote(
well_computed_role[!(well_computed_role %in%
tolower(trimws(names(COMPUTED_VARIABLE_ROLES))))]
), collapse = ", "),
paste(dQuote(tolower(trimws(names(COMPUTED_VARIABLE_ROLES)))), collapse = ", "),
sQuote(rlang::caller_call()[[1]])
)
}
if ((length(not_computed_role) > 0) &&
(!all(not_computed_role %in%
tolower(trimws(names(COMPUTED_VARIABLE_ROLES)))))) {
util_error(c(
"Internal error:",
"%s's %s contains invalid !computed variable role names %s (allowed are %s).",
"As a dataquieR developer, you should fix your call of %s."
),
sQuote(arg_name),
sQuote("need_computed_role"),
paste(dQuote(
not_computed_role[!(not_computed_role %in%
tolower(trimws(names(COMPUTED_VARIABLE_ROLES))))]
), collapse = ", "),
paste(dQuote(tolower(trimws(names(COMPUTED_VARIABLE_ROLES)))), collapse = ", "),
sQuote(rlang::caller_call()[[1]])
)
}
if ((length(well_computed_role) > 0) &&
(!tolower(trimws(computed_role)) %in% well_computed_role)) {
# now check for the allowed computed variable roles
record_problem(
"Argument %s: Variable '%s' (%s) does not have an allowed computed variable role (%s)",
dQuote(arg_name), ..vname, tolower(trimws(computed_role)),
need_computed_role,
applicability_problem = TRUE,
intrinsic_applicability_problem = TRUE)
data_computed_role_problem_container[[..vname]] <- TRUE
}
if ((length(not_computed_role) > 0) &&
(tolower(trimws(computed_role)) %in% not_computed_role)) {
# and for the disallowed computed variable roles
record_problem(
"Argument %s: Variable '%s' (%s) has a disallowed computed variable role (%s)",
dQuote(arg_name), ..vname, tolower(trimws(computed_role)),
util_pretty_vector_string(not_computed_role),
applicability_problem = TRUE,
intrinsic_applicability_problem = TRUE)
data_computed_role_problem_container[[..vname]] <- TRUE
}
} else { # nocov start
if (!is.na(need_computed_role)) {
util_warning(
c("Argument %s: No computed variable role found for '%s' in the",
"metadata, cannot check computed variable role"),
dQuote(arg_name), variable,
applicability_problem = TRUE)
}
} # nocov end
}
if (length(names(data_computed_role_problem_container)) > 0) {
variable <- setdiff(variable, names(data_computed_role_problem_container))
if (length(variable) == 0) {
util_error(
"In %s, none of the specified variables matches the requirements.",
dQuote(arg_name),
applicability_problem = TRUE,
intrinsic_applicability_problem = TRUE
)
} else {
util_warning(
c("In %s, variables %s were excluded."),
dQuote(arg_name),
paste(dQuote(names(data_computed_role_problem_container)),
collapse = ", "),
applicability_problem = TRUE,
intrinsic_applicability_problem = TRUE
)
assign(arg_name, variable, envir = p)
}
}
}
}
#' Variable-argument roles
#'
#' A Variable-argument role is the intended use of an argument of a indicator
#' function -- an argument that refers variables.
#' In general for the table .variable_arg_roles, the suffix _var means one
#' variable allowed,
#' while _vars means more than one. The default sets of arguments
#' for `util_correct_variable_use`/`util_correct_variable_use2` are defined
#' from the point of usage, e.g. if it could be, that NAs are in
#' the list of variable names, the function should be able to remove certain
#' response variables
#' from the output and not disallow them by setting `allow_na` to `FALSE`.
#'
#' @seealso `util_correct_variable_use()`
#' @seealso `util_correct_variable_use2()`
#'
#' @keywords internal
.variable_arg_roles <-
dplyr::tribble(
~name, ~allow_na, ~allow_more_than_one, ~allow_null, ~allow_all_obs_na,
~allow_any_obs_na, ~min_distinct_values, ~need_type, ~need_scale,
~need_role, ~need_computed_role,
"resp_var", FALSE, FALSE, FALSE, FALSE, TRUE, 0, NA, NA, NA, NA,
"response_var", FALSE, FALSE, FALSE, FALSE, TRUE, 0, NA, NA, NA, NA,
"resp_vars", FALSE, TRUE, FALSE, FALSE, TRUE, 0, NA, NA, NA, NA,
"response_vars", FALSE, TRUE, FALSE, FALSE, TRUE, 0, NA, NA, NA, NA,
"control_vars", TRUE, TRUE, TRUE, FALSE, TRUE, 0, NA, NA, NA, NA,
"co_vars", TRUE, TRUE, TRUE, FALSE, TRUE, 0, NA, NA, NA, NA,
"cluster_vars", FALSE, TRUE, FALSE, FALSE, FALSE, 0, NA, NA, NA, NA,
"group_vars", FALSE, TRUE, FALSE, FALSE, FALSE, 0, NA, NA, NA, NA,
"level_vars", FALSE, TRUE, FALSE, FALSE, FALSE, 0, NA, NA, NA, NA,
"cluster_var", FALSE, FALSE, TRUE, FALSE, TRUE, 0, NA, NA, NA, NA,
"level_var", FALSE, FALSE, TRUE, FALSE, TRUE, 0, NA, NA, NA, NA,
"strata_vars", FALSE, FALSE, TRUE, FALSE, TRUE, 0, NA, NA, NA, NA,
"time_vars", FALSE, FALSE, FALSE, FALSE, FALSE, 0, NA, NA, NA, NA,
"id_vars", FALSE, FALSE, FALSE, FALSE, FALSE, 0, NA, NA, NA, NA
)
# "process_vars",
# "key_segment_vars"
#' @importFrom stats na.omit
#' @rdname util_correct_variable_use
#' @family robustness_functions
#' @concept robustness
#' @noRd
util_correct_variable_use2 <- util_correct_variable_use
formals(util_correct_variable_use2)[["role"]] <- quote(arg_name)
Try the dataquieR package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.