R/check-args.R

In wid: Download Data from the World Inequality Database

#' @title Check list of indicator codes
#'
#' @author Thomas Blanchet
#'
#' @description Check that the list of indicator codes submitted by the
#' user is valid.
#'
#' @param indicators List of indicators.

check_indicators <- function(indicators) {
    if (length(indicators) > 1 || indicators != "all") {
        invalid <- !grepl("^[a-z]{6}$", indicators)
        if (any(invalid)) {
            stop(paste("indicators must be 6-letter codes, the following are",
                "invalid:", paste(indicators[invalid], collapse=", ")))
        }
    }
}

#' @title Check list of area codes
#'
#' @author Thomas Blanchet
#'
#' @description Check that the list of area codes submitted by the
#' user is valid.
#'
#' @param areas List of area codes

check_areas <- function(areas) {
  if (length(areas) > 1 || areas != "all") {
    invalid <- !grepl("^[A-Z]{2}(-[A-Z]{2,3})?$", areas)
    if (any(invalid)) {
      stop(paste("Area codes must take the form XX, XX-YY, or XX-YYY. The following are invalid:",
                 paste(areas[invalid], collapse=", ")))
    }
  }
}

#' @title Check list of years
#'
#' @author Thomas Blanchet
#'
#' @description Check that the list of years submitted by the user is valid
#'
#' @param years List of years

check_years <- function(years) {
    if (length(years) > 1 || years != "all") {
        years_num <- suppressWarnings(as.numeric(years))
        invalid <- is.na(years_num) | years_num > 9999 | years_num < 1000
        if (any(invalid)) {
            stop(paste("the following years are invalid:", paste(years[invalid], collapse=", ")))
        }
    }
}

#' @title Check list of percentiles
#'
#' @author Thomas Blanchet
#'
#' @description Check that the list of percentiles submitted by the user is valid
#'
#' @param perc List of percentiles

check_perc <- function(perc) {
    if (length(perc) > 1 || perc != "all") {
        invalid <- !grepl("^p[0-9]+(\\.[0-9]+)?(p[0-9]+(\\.[0-9]+)?)?$", perc)
        if (any(invalid)) {
            stop(paste("percentiles must take the form pXX or pXXpYY, the following are",
                "invalid:", paste(perc[invalid], collapse=", ")))
        }
    }
}

#' @title Check list of age codes
#'
#' @author Thomas Blanchet
#'
#' @description Check that the list of age codes submitted by the
#' user is valid.
#'
#' @param ages List of age codes

check_ages <- function(ages) {
    if (length(ages) > 1 || ages != "all") {
        ages_num <- suppressWarnings(as.numeric(ages))
        invalid <- is.na(ages_num) | ages_num > 999 | ages_num < 100
        if (any(invalid)) {
            stop(paste("ages must be numerical codes between 100 and 999, the",
                "following are invalid:", paste(ages[invalid], collapse=", ")))
        }
    }
}

#' @title Check list of population codes
#'
#' @author Thomas Blanchet
#'
#' @description Check that the list of population codes submitted by the
#' user is valid.
#'
#' @param pop List of population codes

check_pop <- function(pop) {
    if (length(pop) > 1 || pop != "all") {
        invalid <- !grepl("^[ijmfte]$", pop)
        if (any(invalid)) {
            stop(paste("population codes must be 'i', 'j', 'm', 'f', 't' or 'e',",
                "the following are invalid:", paste(pop[invalid], collapse=", ")))
        }
    }
}

parse_score_filter_value <- function(value, score_name) {
    if (is.list(value) && !is.data.frame(value)) {
        if (is.null(names(value)) || any(names(value) == "")) {
            stop(paste0(
                "score_filter$", score_name,
                " must use named entries min and/or max"
            ))
        }
        invalid_names <- setdiff(names(value), c("min", "max"))
        if (length(invalid_names) > 0) {
            stop(paste(
                "score_filter can only use min and max bounds, the following are invalid:",
                paste(invalid_names, collapse = ", ")
            ))
        }
        if (length(value) == 0) {
            stop(paste0("score_filter$", score_name, " cannot be empty"))
        }

        min_value <- NA_real_
        max_value <- NA_real_
        if ("min" %in% names(value)) {
            min_value <- suppressWarnings(as.numeric(value$min))
            if (length(min_value) != 1 || is.na(min_value)) {
                stop(paste0("score_filter$", score_name, "$min must be one number"))
            }
        }
        if ("max" %in% names(value)) {
            max_value <- suppressWarnings(as.numeric(value$max))
            if (length(max_value) != 1 || is.na(max_value)) {
                stop(paste0("score_filter$", score_name, "$max must be one number"))
            }
        }
    } else {
        score_values <- suppressWarnings(as.numeric(value))
        if (length(score_values) == 1) {
            min_value <- score_values
            max_value <- NA_real_
        } else if (length(score_values) == 2) {
            min_value <- score_values[1]
            max_value <- score_values[2]
        } else {
            stop(paste0(
                "score_filter$", score_name,
                " must be one number, two numbers, or a list with min and/or max"
            ))
        }
        if (any(is.na(score_values))) {
            stop(paste0("score_filter$", score_name, " must contain valid numbers"))
        }
    }

    bounds <- c(min = min_value, max = max_value)
    finite_bounds <- bounds[!is.na(bounds)]
    if (length(finite_bounds) == 0) {
        stop(paste0("score_filter$", score_name, " cannot be empty"))
    }
    if (any(finite_bounds < 0 | finite_bounds > 5)) {
        stop("score_filter scores must be between 0 and 5")
    }
    if (!is.na(bounds["min"]) && !is.na(bounds["max"]) &&
            bounds["min"] > bounds["max"]) {
        stop(paste0("score_filter$", score_name, " min cannot be greater than max"))
    }

    bounds
}

normalize_score_filter <- function(score_filter) {
    if (is.null(score_filter)) {
        return(NULL)
    }

    if (!is.list(score_filter)) {
        return(list(row_score = parse_score_filter_value(score_filter, "row_score")))
    }

    if (length(score_filter) == 0) {
        stop("score_filter cannot be an empty list")
    }
    if (is.null(names(score_filter)) || any(names(score_filter) == "")) {
        stop("score_filter must be a named list using row_score and/or series_score")
    }
    if (any(duplicated(names(score_filter)))) {
        stop("score_filter cannot contain duplicate score names")
    }

    allowed_names <- c("row_score", "series_score")
    invalid_names <- setdiff(names(score_filter), allowed_names)
    if (length(invalid_names) > 0) {
        stop(paste(
            "score_filter can only use row_score and series_score, the following are invalid:",
            paste(invalid_names, collapse = ", ")
        ))
    }

    parsed <- lapply(names(score_filter), function(score_name) {
        parse_score_filter_value(score_filter[[score_name]], score_name)
    })
    names(parsed) <- names(score_filter)
    parsed
}

apply_score_filter <- function(data, score_filter) {
    if (is.null(score_filter)) {
        return(data)
    }

    for (score_name in names(score_filter)) {
        if (!(score_name %in% names(data))) {
            stop(paste0("score_filter requested missing column: ", score_name))
        }
        score_values <- suppressWarnings(as.numeric(data[[score_name]]))
        keep <- !is.na(score_values)
        bounds <- score_filter[[score_name]]
        if (!is.na(bounds["min"])) {
            keep <- keep & score_values >= bounds["min"]
        }
        if (!is.na(bounds["max"])) {
            keep <- keep & score_values <= bounds["max"]
        }
        data <- data[keep, , drop = FALSE]
    }

    data
}