Nothing
#' Prepare and verify study data with metadata
#'
#' @description
#' This function ensures, that a data frame `ds1` with suitable variable
#' names study_data and meta_data exist as base [data.frame]s.
#'
#' @details
#'
#' This function defines `ds1` and modifies `study_data` and `meta_data` in the
#' environment of its caller (see [eval.parent]). It also defines or modifies
#' the object `label_col` in the calling environment. Almost all functions
#' exported by `dataquieR` call this function initially, so that aspects common
#' to all functions live here, e.g. testing, if an argument `meta_data` has been
#' given and features really a [data.frame]. It verifies the existence of
#' required metadata attributes ([VARATT_REQUIRE_LEVELS]). It can also replace
#' missing codes by `NA`s, and calls [prep_study2meta] to generate a minimum
#' set of metadata from the study data on the fly (should be amended, so
#' on-the-fly-calling is not recommended for an instructive use of `dataquieR`).
#'
#' The function also detects `tibbles`, which are then converted to base-R
#' [data.frame]s, which are expected by `dataquieR`.
#'
#' Different from the other utility function that work
#' in the caller's environment, so it modifies objects in the calling function.
#' It defines a new object `ds1`, it modifies `study_data` and/or `meta_data`
#' and `label_col`, if `.internal` is `TRUE`.
#'
#' @param .study_data if provided, use this data set as study_data
#' @param .meta_data if provided, use this data set as meta_data
#' @param .label_col if provided, use this as label_col
#' @param .replace_hard_limits replace `HARD_LIMIT` violations by `NA`,
#' defaults to `FALSE`.
#' @param .replace_missings replace missing codes, defaults to `TRUE`
#' @param .sm_code missing code for `NAs`, if they have been
#' re-coded by `util_combine_missing_lists`
#' @param .allow_empty allow `ds1` to be empty, i.e., 0 rows and/or 0 columns
#' @param .adjust_data_type ensure that the data type of variables in the study
#' data corresponds to their data type specified in the metadata
#' @param .amend_scale_level ensure that `SCALE_LEVEL` is available in the
#' item-level `meta_data`. internally used to prevent
#' recursion, if called from
#' [prep_scalelevel_from_data_and_metadata()].
#' @param .internal [logical] internally called, modify caller's environment.
#'
#' @seealso acc_margins
#'
#' @return `ds1` the study data with mapped column names
#'
#' @examples
#' \dontrun{
#' acc_test1 <- function(resp_variable, aux_variable,
#' time_variable, co_variables,
#' group_vars, study_data, meta_data) {
#' prep_prepare_dataframes()
#' invisible(ds1)
#' }
#' acc_test2 <- function(resp_variable, aux_variable,
#' time_variable, co_variables,
#' group_vars, study_data, meta_data, label_col) {
#' ds1 <- prep_prepare_dataframes(study_data, meta_data)
#' invisible(ds1)
#' }
#' environment(acc_test1) <- asNamespace("dataquieR")
#' # perform this inside the package (not needed for functions that have been
#' # integrated with the package already)
#'
#' environment(acc_test2) <- asNamespace("dataquieR")
#' # perform this inside the package (not needed for functions that have been
#' # integrated with the package already)
#' acc_test3 <- function(resp_variable, aux_variable, time_variable,
#' co_variables, group_vars, study_data, meta_data,
#' label_col) {
#' prep_prepare_dataframes()
#' invisible(ds1)
#' }
#' acc_test4 <- function(resp_variable, aux_variable, time_variable,
#' co_variables, group_vars, study_data, meta_data,
#' label_col) {
#' ds1 <- prep_prepare_dataframes(study_data, meta_data)
#' invisible(ds1)
#' }
#' environment(acc_test3) <- asNamespace("dataquieR")
#' # perform this inside the package (not needed for functions that have been
#' # integrated with the package already)
#'
#' environment(acc_test4) <- asNamespace("dataquieR")
#' # perform this inside the package (not needed for functions that have been
#' # integrated with the package already)
#' load(system.file("extdata/meta_data.RData", package = "dataquieR"))
#' load(system.file("extdata/study_data.RData", package = "dataquieR"))
#' try(acc_test1())
#' try(acc_test2())
#' acc_test1(study_data = study_data)
#' try(acc_test1(meta_data = meta_data))
#' try(acc_test2(study_data = 12, meta_data = meta_data))
#' print(head(acc_test1(study_data = study_data, meta_data = meta_data)))
#' print(head(acc_test2(study_data = study_data, meta_data = meta_data)))
#' print(head(acc_test3(study_data = study_data, meta_data = meta_data)))
#' print(head(acc_test3(study_data = study_data, meta_data = meta_data,
#' label_col = LABEL)))
#' print(head(acc_test4(study_data = study_data, meta_data = meta_data)))
#' print(head(acc_test4(study_data = study_data, meta_data = meta_data,
#' label_col = LABEL)))
#' try(acc_test2(study_data = NULL, meta_data = meta_data))
#' }
#'
#' @export
#'
#' @importFrom rlang caller_fn
#' @importFrom utils object.size
prep_prepare_dataframes <- function(.study_data, .meta_data, .label_col,
.replace_hard_limits, # TODO: .replace_inadmissible_categorical_values
.replace_missings, .sm_code = NULL,
.allow_empty = FALSE,
.adjust_data_type = TRUE,
.amend_scale_level = TRUE,
.internal =
rlang::env_inherits(
rlang::caller_env(),
parent.env(environment()))) {
# dimension <- substr(rlang::call_name(rlang::caller_call()), 1, 3)
# TODO: Add missing tables from meta_data$MISSING_LIST_TABLE
util_expect_scalar(.sm_code,
check_type = util_all_is_integer,
allow_null = TRUE)
if (missing(.replace_hard_limits)) .replace_hard_limits <- FALSE
util_expect_scalar(.replace_hard_limits, check_type = is.logical)
util_expect_scalar(.allow_empty, check_type = is.logical)
if (!missing(.replace_missings) && (length(.replace_missings) != 1 ||
!is.logical(.replace_missings) ||
is.na(.replace_missings))) {
util_error(
"Called prepare_dataframes with .replace_missings not being logical(1)",
applicability_problem = TRUE)
}
if (missing(.replace_missings)) .replace_missings <- TRUE
# TODO: include check for (hard) limits similar to replace_missings
callfn <- caller_fn(1)
caller_defaults <- suppressWarnings(formals(callfn))
caller_formals <- names(caller_defaults)
caller_has_default <- suppressWarnings({
!vapply(formals(callfn), identical, formals(function(x) {
})[["x"]], FUN.VALUE = logical(1))
})
if (missing(.label_col)) {
if ("label_col" %in% caller_formals) {
if (!eval.parent(substitute({
missing(label_col)
}))) {
quoted_label_col <- eval.parent(substitute(substitute(label_col)))
.label_col <- try(eval(quoted_label_col, envir = parent.frame()),
silent = TRUE)
if (inherits(.label_col, "try-error")) {
.label_col <- try(eval(quoted_label_col, envir =
dataquieR::WELL_KNOWN_META_VARIABLE_NAMES),
silent = TRUE)
}
if (inherits(.label_col, "try-error")) {
util_error("Cannot resolve %s", dQuote(paste0("label_col", " = ",
quoted_label_col)),
applicability_problem = TRUE)
}
} else if (caller_has_default[["label_col"]]) {
.label_col <- eval(caller_defaults[["label_col"]],
envir = asNamespace("dataquieR"), enclos =
parent.frame(2))
} else {
.label_col <- VAR_NAMES
}
} else if (exists("label_col", parent.frame())) {
.label_col <- get("label_col", parent.frame())
} else {
.label_col <- VAR_NAMES
}
}
# if no study_data have been provided -> error
if (missing(.study_data)) {
if ("study_data" %in% caller_formals) {
if (!eval.parent(substitute({
missing(study_data)
}))) {
if (exists("study_data", parent.frame())) { # FIXME: Test this and the same for metadata
.study_data <- try(eval(quote(study_data), parent.frame()),
silent = TRUE)
if (inherits(.study_data, "try-error")) {
cnd <- attr(.study_data, "condition")
cnd$call <- sys.call(1)
util_error(cnd)
}
} else {
util_error("object %s not found", dQuote("study_data"))
}
} else if (caller_has_default[["study_data"]]) {
.study_data <- try(eval.parent(caller_defaults[["study_data"]], n = 2),
silent = TRUE)
if (inherits(.study_data, "try-error")) {
cnd <- attr(.study_data, "condition")
cnd$call <- sys.call(1)
util_error(cnd)
}
} else {
.study_data <- NULL
}
} else if (exists("study_data", parent.frame())) {
.study_data <- get("study_data", parent.frame())
} else {
.study_data <- NULL
}
}
e <- new.env(parent = environment())
e$study_data <- .study_data
.study_data <-
eval(
quote(try(util_expect_data_frame(study_data, keep_types = TRUE),
silent = TRUE)),
e
)
if (inherits(.study_data, "try-error")) {
util_error("Need study data as a data frame: %s",
conditionMessage(attr(.study_data, "condition")))
}
if (missing(.meta_data)) {
if ("meta_data" %in% caller_formals) {
if (!eval.parent(substitute({
missing(meta_data)
}))) {
if (exists("meta_data", parent.frame())) {
.meta_data <- try(eval(quote(meta_data), envir = parent.frame()),
silent = TRUE)
if (inherits(.meta_data, "try-error")) {
cnd <- attr(.meta_data, "condition")
cnd$call <- sys.call(1)
util_error(cnd)
}
} else {
util_error("object %s not found", dQuote("meta_data"))
}
} else if (caller_has_default[["meta_data"]]) {
.meta_data <- try(eval.parent(caller_defaults[["meta_data"]], n = 2),
silent = TRUE)
if (inherits(.meta_data, "try-error")) {
cnd <- attr(.meta_data, "condition")
cnd$call <- sys.call(1)
util_error(cnd)
}
} else {
if ("item_level" %in% prep_list_dataframes()) {
.meta_data <- util_expect_data_frame("item_level")
}
if (missing(.meta_data) || !is.data.frame(.meta_data)) {
util_warning(
c("Missing %s, try to guess a preliminary one from the data",
"using %s. Please consider amending this minimum guess manually."),
dQuote("meta_data"),
dQuote("prep_prepare_dataframes"),
applicability_problem = TRUE
)
.meta_data <- prep_study2meta(.study_data, level =
VARATT_REQUIRE_LEVELS$RECOMMENDED)
}
}
} else if (exists("meta_data", parent.frame())) {
.meta_data <- get("meta_data", parent.frame())
} else {
.meta_data <- data.frame()
}
}
# if no meta_data have been provided -> error
e <- new.env(parent = environment())
e$meta_data <- .meta_data
.meta_data <-
eval(
quote(try(util_expect_data_frame(meta_data), silent = TRUE)),
e
)
if (inherits(.meta_data, "try-error")) {
util_error("Need metadata as a data frame: %s",
conditionMessage(attr(.meta_data, "condition")))
}
util_expect_data_frame(.meta_data)
if (!prod(dim(.meta_data))) {
util_warning(
c("Missing %s, try to guess a preliminary one from the data using %s.",
"Please consider amending this minimum guess manually."),
dQuote("meta_data"),
dQuote("prep_prepare_dataframes"),
applicability_problem = TRUE
)
.meta_data <- prep_study2meta(.study_data, level =
VARATT_REQUIRE_LEVELS$REQUIRED)
}
if (is.null(.label_col)) {
.label_col <- VAR_NAMES
}
study_data <- .study_data
meta_data <- .meta_data
label_col <- .label_col
if (any(is.na(colnames(study_data)))) {
util_error("%s must not feature columns with columns names being %s",
sQuote("study_data"),
sQuote("NA"), applicability_problem = TRUE,
intrinsic_applicability_problem = TRUE)
}
# Exchanged to "label_col"
if (!exists("label_col")) {
label_col <- VAR_NAMES
}
try(if (missing(label_col)) {
label_col <- VAR_NAMES
}, silent = TRUE)
# TODO: include a check that VAR_NAMES/label_col exists, and that they are unique and not too long
# intermediate solution - fill empty labels, since we will map to metadata label columns, and otherwise empty fields will cause errors
for (lcol in unique(c(label_col, LABEL, LONG_LABEL))) {
if (is.data.frame(meta_data) && lcol %in% colnames(meta_data)) {
meta_data[[lcol]][which(util_empty(meta_data[[lcol]]))] <-
meta_data[[VAR_NAMES]][which(util_empty(meta_data[[lcol]]))]
}
}
meta_data <- prep_meta_data_v1_to_item_level_meta_data(meta_data =
meta_data,
verbose = FALSE,
label_col = label_col)
if (!(DATA_TYPE %in% colnames(meta_data)) ||
any(util_empty(meta_data[[DATA_TYPE]])) ||
!all(meta_data[[DATA_TYPE]] %in% DATA_TYPES)) {
if (!(DATA_TYPE %in% colnames(meta_data))) {
meta_data[[DATA_TYPE]] <- NA_character_
}
which_wrong <-
util_empty(meta_data[[DATA_TYPE]]) |
!(meta_data[[DATA_TYPE]] %in% DATA_TYPES)
wrong_names <- meta_data[which_wrong, VAR_NAMES, drop = TRUE]
wrong_names <- intersect(colnames(study_data), wrong_names)
datatypes <- prep_datatype_from_data(resp_vars = wrong_names,
study_data = study_data)
util_warning(
c("For the variables %s, I have no valid %s in the %s. I've predicted",
"the %s from the %s yielding %s."),
util_pretty_vector_string(wrong_names),
sQuote(DATA_TYPE),
sQuote("meta_data"),
sQuote(DATA_TYPE),
sQuote("study_data"),
dQuote(prep_deparse_assignments(names(datatypes), datatypes,
mode = "string_codes")),
applicability_problem = TRUE,
intrinsic_applicability_problem = FALSE
)
meta_data[which_wrong, DATA_TYPE] <-
datatypes[meta_data[which_wrong, VAR_NAMES]]
}
if (!.called_in_pipeline) util_validate_known_meta(meta_data)
if (.replace_missings) {
# Are missing codes replaced?
if (!("Codes_to_NA" %in% names(attributes(study_data)))) {
study_data <-
util_replace_codes_by_NA(
study_data = study_data, meta_data = meta_data,
split_char = SPLIT_CHAR, sm_code = .sm_code)
}
}
# The call below is not executed here, but stored for later use
# when ds1 is actually available.
repl_lim_viol <- quote({
if (.replace_hard_limits) {
# Are hard limit violations replaced?
if (!("HL_viol_to_NA" %in% names(attributes(ds1)))) {
ds1 <-
util_replace_hard_limit_violations(
study_data = ds1, meta_data = meta_data, label_col = label_col)
}
}
})
study_data_hash <- rlang::hash(.study_data)
meta_data_hash <- rlang::hash(.meta_data)
a <- formals(prep_prepare_dataframes)[.to_combine]
a2 <- rlang::call_args(sys.call())
a2 <- a2[intersect(names(a2), .to_combine)]
a[names(a2)] <- a2
missing_from_a <- vapply(a, rlang::is_missing, FUN.VALUE = logical(1))
a[missing_from_a] <- mget(names(which(missing_from_a)))
a <- rlang::hash(a)
key <-
paste0(a, "@", study_data_hash,
"@", meta_data_hash, "@", label_col)
if (key %in% names(.study_data_cache)) {
if (getOption("dataquieR.study_data_cache_metrics", FALSE)) {
e <- getOption("dataquieR.study_data_cache_metrics_env")
if (is.null(e$usage)) e$usage <- list()
if (is.null(e$usage[[key]])) e$usage[[key]] <- 0
e$usage[[key]] <- e$usage[[key]] + 1
}
study_data <- .study_data_cache[[key]]
}
# If study_data exist and metadata were already mapped, then we can return ds1
# directly, but only if all requested modifications are already considered
# (if possible).
if (isTRUE(attr(study_data, "MAPPED", exact = TRUE))) {
# labels can be modified easily
if (attr(study_data, "label_col") != label_col) {
colnames(study_data) <-
util_map_labels(colnames(study_data),
meta_data = meta_data,
from = attr(study_data, "label_col"),
to = label_col)
attr(study_data, "label_col") <- label_col
}
# replacement of missing value codes can not be undone
if ("Codes_to_NA" %in% names(attributes(study_data)) &&
!.replace_missings) {
browser()
util_error("Substitution of missing value codes cannot be undone.",
applicability_problem = TRUE)
}
# replacement of hard limits can not be undone
if ("HL_viol_to_NA" %in% names(attributes(study_data)) &&
!.replace_hard_limits) {
util_error("Discarding values outside the limits cannot be undone.",
applicability_problem = TRUE)
}
# data type correction can not be undone
if ("Data_type_matches" %in% names(attributes(study_data)) &&
!.adjust_data_type) {
util_error("Correction of data type mismatches cannot be undone.",
applicability_problem = TRUE)
}
# missing value codes replaced, if required (and vice versa)?
check_miss <-
(.replace_missings &&
"Codes_to_NA" %in% names(attributes(study_data))) ||
(!.replace_missings &&
!("Codes_to_NA" %in% names(attributes(study_data))))
# hard limit violations replaced, if required (and vice versa)?
check_hl <-
(.replace_hard_limits &&
"HL_viol_to_NA" %in% names(attributes(study_data))) ||
(!.replace_hard_limits &&
!("HL_viol_to_NA" %in% names(attributes(study_data))))
# data type adjusted, if required (and vice versa)?
check_dt <-
(.adjust_data_type &&
"Data_type_matches" %in% names(attributes(study_data))) ||
(!.adjust_data_type &&
!("Data_type_matches" %in% names(attributes(study_data))))
# if SCALE_LEVEL is required, then there should be no empty entries
check_sl <-
(.amend_scale_level && SCALE_LEVEL %in% colnames(meta_data) &&
!any(util_empty(meta_data[[SCALE_LEVEL]][meta_data$VAR_NAMES %in%
colnames(study_data)]))) ||
!.amend_scale_level
if (check_miss && check_hl && check_dt && check_sl) {
ds1 <- study_data
eval(repl_lim_viol) # TODO: Is this line needed here??
if (.internal) {
assign("study_data", study_data, parent.frame())
assign("meta_data", meta_data, parent.frame())
assign("ds1", ds1, parent.frame())
assign("label_col", label_col, parent.frame())
}
return(invisible(study_data))
} else {
# map column names to VAR_NAMES and let the rest of this function
# do its work
colnames(study_data) <-
util_map_labels(colnames(study_data),
meta_data = meta_data,
from = label_col,
to = VAR_NAMES)
attr(study_data, "label_col") <- VAR_NAMES
attr(study_data, "MAPPED") <- FALSE
}
}
Codes_to_NA <- attr(study_data, "Codes_to_NA")
if (!"VAR_NAMES" %in% colnames(meta_data)) {
# Should get caught before by 'util_validate_known_meta'.
util_error("'VAR_NAMES' not found in metadata [%s]",
paste0(colnames(meta_data), collapse = ", "),
applicability_problem = TRUE)
}
if (!isTRUE(attr(study_data, "MAPPED", exact = TRUE))) {
study_data <- study_data[, order(colnames(study_data)), FALSE]
meta_data <- meta_data[order(meta_data[[VAR_NAMES]]), , FALSE]
}
# adjust data types, if enabled
util_stop_if_not(
`Pipeline should never request study data w/ unchanged datatypes, sorry, internal error, please report` =
!(!.adjust_data_type && .called_in_pipeline))
if (.adjust_data_type && !.called_in_pipeline) {
relevant_vars_for_warnings <- lapply(
setNames(nm = names(.meta_data_env)[endsWith(names(.meta_data_env), "_vars")]), # all arguments populated by the pipeline with some variable references
util_find_indicator_function_in_callers
)
if (is.null(relevant_vars_for_warnings$resp_vars)) { # original call was not for item level, so no filtering of problems by related items
relevant_vars_for_warnings <- NULL
}
relevant_vars_for_warnings <- unlist(relevant_vars_for_warnings,
recursive = TRUE)
relevant_vars_for_warnings <-
relevant_vars_for_warnings[!util_empty(relevant_vars_for_warnings)]
try(relevant_vars_for_warnings <- # TODO: sometimes, relevant... does not have variables from label_col, if correct variable use used find var by names and mapped them to varnames already # this corresponds with TODO POSSIBLE_VARS in util_correct_variable_use
util_find_var_by_meta(relevant_vars_for_warnings,
meta_data = meta_data,
label_col = label_col,
target = VAR_NAMES,
allowed_sources =
c(VAR_NAMES, LABEL, LONG_LABEL, label_col),
ifnotfound = relevant_vars_for_warnings),
silent = TRUE)
study_data <- util_adjust_data_type(
study_data = study_data,
meta_data = meta_data,
relevant_vars_for_warnings = relevant_vars_for_warnings)
}
if (.amend_scale_level && (!(SCALE_LEVEL %in% colnames(meta_data)) ||
any(util_empty(
meta_data[[SCALE_LEVEL]][meta_data$VAR_NAMES %in%
colnames(study_data)])))) {
util_message(c("Did not find any %s column in item-level %s. Predicting",
"it from the data -- please verify these predictions, they",
"may be wrong and lead to functions claiming not to be",
"reasonably applicable to a variable."),
sQuote(SCALE_LEVEL), "meta_data",
applicability_problem = TRUE,
intrinsic_applicability_problem = FALSE)
meta_data <- prep_scalelevel_from_data_and_metadata(
study_data = study_data,
meta_data = meta_data,
label_col = label_col
)
}
# create ds1 -----------------------------------------------------------------
if (isTRUE(attr(study_data, "MAPPED", exact = TRUE))) {
ds1 <- study_data
} else {
ds1 <- util_map_all(label_col = label_col, study_data = study_data,
meta_data = meta_data)$df
}
if (!(.allow_empty) && ncol(ds1) * nrow(ds1) == 0) {
util_error(
"No data left. Aborting, since mapping of %s on %s was not possible",
sQuote("meta_data"),
sQuote("study_data"),
applicability_problem = FALSE)
}
ds1 <- as.data.frame(ds1)
meta_data <- as.data.frame(meta_data)
.all <- ncol(ds1)
ds1 <- ds1[, colnames(ds1) %in% meta_data[[label_col]], FALSE]
.mapped <- ncol(ds1)
if (.all > .mapped) { # nocov start
# Should be dead code, because util_map_all is called above, which
# performs an analogous check and clears out the unannotated variables
# from the study data.
util_warning("Lost %d variables, that I could not map using %s",
.all - .mapped, dQuote(label_col),
applicability_problem = TRUE)
} # nocov end
if (!.allow_empty) {
# this would delete the metadata, if the mapping has failed totally
meta_data <- meta_data[meta_data[[label_col]] %in% colnames(ds1), , FALSE]
}
if (STUDY_SEGMENT %in% colnames(meta_data) &&
any(util_empty(meta_data[[STUDY_SEGMENT]]))) {
dummy_name <- "SEGMENT"
i <- 1
while (dummy_name %in% meta_data[[STUDY_SEGMENT]]) {
dummy_name <- sprintf("SEGMENT %d", i)
i <- i + 1
}
util_message(c(
"Some %s are NA. Will assign those to an artificial",
"segment %s"), sQuote(STUDY_SEGMENT), dQuote(dummy_name),
applicability_problem = TRUE
)
meta_data[[STUDY_SEGMENT]][util_empty(meta_data[[STUDY_SEGMENT]])] <-
dummy_name
}
if (VARIABLE_ORDER %in% colnames(meta_data)) {
meta_data[] <- meta_data[order(meta_data[[VARIABLE_ORDER]]), , drop = FALSE]
vars <- meta_data[, label_col, drop = TRUE]
vars <- vars[vars %in% colnames(ds1)]
ds1 <- ds1[, vars, drop = FALSE]
}
if (PART_VAR %in% colnames(meta_data)) local({
.kssvs <- intersect(colnames(study_data), meta_data[, PART_VAR])
for (rv in .kssvs) {
vals <- util_replace_codes_by_NA(
study_data = study_data[, rv, drop = FALSE],
meta_data = meta_data, sm_code = .sm_code)[[rv]]
vals <- vals[!is.na(vals)]
if (is.character(vals)) vals <- vals[trimws(vals) != ""]
vals <- suppressWarnings(as.numeric(vals))
if (!all(vals %in% c(0:1, NA), na.rm = TRUE)) {
util_warning(c( # TODO: Maybe too frequently shown? see relevant_vars_for_warnings above
"Found entries different from TRUE/FALSE/1/0 and <empty>, segment",
"participation is expected, if values different from 0 are found.",
"For the segment indicator variable %s, a table of inadmissible",
"values: %s"),
dQuote(rv),
paste(capture.output(print(table(setdiff(vals, c(0:1, NA))))),
collapse = "\n"))
}
}
})
attr(study_data, "Codes_to_NA") <- Codes_to_NA
attr(ds1, "Codes_to_NA") <- Codes_to_NA
attr(ds1, "MAPPED") <- TRUE
attr(ds1, "label_col") <- label_col
attr(ds1, "Data_type_matches") <- attr(study_data, "Data_type_matches")
eval(repl_lim_viol)
study_data <- util_cast_off(study_data, "study_data", TRUE)
meta_data <- util_cast_off(meta_data, "meta_data", TRUE)
ds1 <- util_cast_off(ds1, "ds1", TRUE)
if (.internal) {
assign("study_data", study_data, parent.frame())
assign("meta_data", meta_data, parent.frame())
assign("ds1", ds1, parent.frame())
assign("label_col", label_col, parent.frame())
}
dataquieR.study_data_cache_max <-
getOption("dataquieR.study_data_cache_max", Inf)
if (is.data.frame(ds1) &&
!(key %in% names(.study_data_cache))) {
if (sum(object.size(ds1),
vapply(.study_data_cache, object.size, FUN.VALUE = numeric(1)),
na.rm = TRUE) <= dataquieR.study_data_cache_max) {
.study_data_cache[[key]] <- util_attach_attr(ds1, call = sys.call())
} else if (getOption("dataquieR.study_data_cache_metrics", FALSE)) {
class(dataquieR.study_data_cache_max) <- "object_size"
rlang::inform(
sprintf(
paste(
"Maximum size for study_data cache (%s) reached, not caching.",
"Adjust the %s to control"),
format(dataquieR.study_data_cache_max, units = "auto"),
sQuote("option(dataquieR.study_data_cache_max = )")
),
.frequency = "once", .frequency_id = paste(key)
)
}
}
invisible(ds1)
}
.ds1_attribute_names <- c("Codes_to_NA", "MAPPED", "label_col", "HL_viol_to_NA",
"Data_type_matches")
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.