Nothing
#' Look Up Values in a Data Frame
#'
#' A convenience function to easily look for values in a
#' data frame.
#'
#' This function is mostly used to extract population
#' informations (such as mortality rates), given some
#' individual caracteristics.
#'
#' If binning is activated, numeric individual
#' characteristics are matched to the corresponding
#' reference value that is directly inferior.
#'
#' @param data A reference data frame.
#' @param value The value to extract from the reference
#' data frame.
#' @param ... Individual characteristics, should be named
#' like the columns of `data`.
#' @param bin Either logical: should all numeric variable be
#' binned, or character vector giving the names of
#' variables to bin (see examples).
#'
#' @return A vector of values, same lenght as `...`.
#' @export
#'
#' @example inst/examples/example_look_up.R
look_up <- function(data, ..., bin = FALSE, value = "value") {
if(!inherits(data, "data.frame"))
stop("'data' must be a data.frame")
data <- clean_factors(data)
list_specs <- list(...)
if (any(names(list_specs) == "")) {
stop("All variables passed to 'look_up()' must be named.")
}
df_vars <- do.call(
tibble::tibble,
list_specs
) %>%
clean_factors
if (any(pb <- ! c(names(df_vars), value) %in% names(data))) {
stop(sprintf(
"Names passed to 'look_up()' not found in 'data': %s.",
paste(c(names(df_vars), value)[pb], collapse = ", ")
))
}
num_vars <- names(df_vars)[unlist(Map(is.numeric, df_vars))]
if (isTRUE(bin)) {
bin <- num_vars
} else if (is.character(bin)) {
if (any(pb <- ! bin %in% names(df_vars))) {
stop(sprintf(
"Names in 'bin' not found in source data: %s.",
paste(bin[pb], collapse = ", ")
))
}
if (any(pb <- ! bin %in% num_vars)) {
stop(sprintf(
"Some variables in 'bin' are not numeric in the selection data: %s.",
paste(bin[pb], collapse = ", ")
))
}
} else {
bin <- character(0)
}
if (length(bin)) {
pb_bin_src <- bin[unlist(Map(
function(x) ! is.numeric(x), data[bin]))]
if (length(pb_bin_src)) {
stop(sprintf(
"Some variables in 'bin' are not numeric in the source data: %s.",
paste(pb_bin_src, collapse = ", ")
))
}
with_infinite <- bin[sapply(data[bin], function(x){any(is.infinite(x))})]
if(length(with_infinite))
stop("infinite values in look_up table element",
plur(length(with_infinite)),
": ",
paste(with_infinite, collapse = ", ")
)
for (n in bin) {
bin_values <- c(sort(unique(data[[n]])), +Inf)
data[[n]] <- cut(data[[n]], bin_values,
include.lowest = TRUE,
right = FALSE)
df_vars[[n]] <- cut(df_vars[[n]], bin_values,
include.lowest = TRUE,
right = FALSE)
}
}
# do this test after binning
if (any(pb <- duplicated(data[names(df_vars)]))) {
stop(sprintf(
"Some rows in 'data' are duplicates: %s.",
paste(which(pb), collapse = ", ")
))
}
res <- suppressMessages(
dplyr::left_join(
df_vars,
data
)[[value]]
)
if (length(res) != nrow(df_vars)) {
stop("Ooops, something went unexpectedly wrong...")
}
if (any(is.na(res))) {
did_not_find <- suppressMessages(dplyr::anti_join(df_vars, data)) %>%
as.data.frame()
missing_values <- map_chr(seq_len(ncol(did_not_find)), function(column_number){
missing <- paste(did_not_find[,column_number], collapse = ", ")
sprintf("%s : %s", colnames(did_not_find)[column_number], missing)
}) %>%
paste(collapse = "\n")
warning("Some values were not found, returning missing data:\n",
"arguments to look_up:\n", missing_values)
}
res
}
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.