## Checks of the 'values' slot of "Labels" objects,
## or of the 'x' argument of 'make_labels' functions
## Categories -----------------------------------------------------------------
## HAS_TESTS
#' Check values for Categories labels
#'
#' Checks:
#' \itemize{
#' \item is character
#' \item at most one NA
#' \item no blanks (zero-length strings)
#' \item no duplicates
#' }
#'
#' Function also called by \code{\link{chk_values_triangles}},
#' \code{\link{chk_values_directions}}, and
#' \code{\link{chk_values_quantiles}}.
#'
#' @param x A character vector.
#' @param name The name for \code{x} that
#' will be used in error messages.
#'
#' @examples
#' x <- c("Thailand", "Laos", "Cambodia")
#' chk_values_categories(x = x, name = "x")
#' @export
chk_values_categories <- function(x, name) {
## is character
val <- chk_is_character(x = x,
name = name)
if (!isTRUE(val))
return(val)
## at most one NA
val <- chk_at_most_one_na_vector(x = x,
name = name)
if (!isTRUE(val))
return(val)
## no blanks
val <- chk_not_blank_vector(x = x,
name = name)
if (!isTRUE(val))
return(val)
## no duplicates
val <- chk_no_duplicates(x = x,
name = name)
if (!isTRUE(val))
return(val)
TRUE
}
## HAS_TESTS
#' Check values for Triangles labels
#'
#' Checks:
#' \itemize{
#' \item is character
#' \item no duplicates
#' \item values belong to set {NA, "Lower", "Upper"}
#' }
#'
#' @inheritParams chk_values_categories
#'
#' @examples
#' x <- c("Upper", "Lower")
#' chk_values_triangles(x = x, name = "x")
#' @export
chk_values_triangles <- function(x, name) {
expected_set <- c("Lower", "Upper", NA)
val <- chk_values_categories(x = x,
name = name)
if (!isTRUE(val))
return(val)
## members of expected set
is_in_set <- x %in% expected_set
i_not_in_set <- match(FALSE, is_in_set, nomatch = 0L)
if (i_not_in_set > 0L)
return(gettextf("'%s' has unexpected value : \"%s\"",
name, x[[i_not_in_set]]))
TRUE
}
## HAS_TESTS
#' Check values for Directions labels
#'
#' Checks:
#' \itemize{
#' \item is character
#' \item no duplicates
#' \item values belong to set {NA, "In", "Out"}
#' }
#'
#' @inheritParams chk_values_categories
#'
#' @examples
#' x <- c("In", "Out")
#' chk_values_directions(x = x, name = "x")
#' @export
chk_values_directions <- function(x, name) {
expected_set <- c("In", "Out", NA)
val <- chk_values_categories(x = x,
name = name)
if (!isTRUE(val))
return(val)
## members of expected set
is_in_set <- x %in% expected_set
i_not_in_set <- match(FALSE, is_in_set, nomatch = 0L)
if (i_not_in_set > 0L)
return(gettextf("'%s' has unexpected value : \"%s\"",
name, x[[i_not_in_set]]))
TRUE
}
## HAS_TESTS
#' Check values for Quantiles labels
#'
#' Checks:
#' \itemize{
#' \item is character
#' \item no duplicates
#' \item all elements have format "<number>%" where 0 <= number <= 100
#' }
#'
#' @inheritParams chk_values_categories
#'
#' @examples
#' x <- c("2.5%", "50%", "97.5%")
#' chk_values_quantiles(x = x, name = "x")
#' @export
chk_values_quantiles <- function(x, name) {
val <- chk_values_categories(x = x,
name = name)
if (!isTRUE(val))
return(val)
## have correct format for quantiles
val <- chk_valid_quantile(x = x,
name = name)
if (!isTRUE(val))
return(val)
TRUE
}
## Pairs ----------------------------------------------------------------------
## HAS_TESTS
#' Checking function for subclasses of Pairs virtual superclass
#'
#' Function called by \code{\link{chk_values_integers}},
#' \code{\link{chk_values_intervals}},
#' \code{\link{chk_values_quantities}},
#' \code{\link{chk_values_quarters}},
#' \code{\link{chk_values_months}}, and
#' \code{\link{chk_values_dateranges}},
#'
#' Checks:
#' \itemize{
#' \item is list of vectors of length 2
#' \item second element of each vector greater than first
#' \item intervals do not overlap (including NAs)
#' }
#'
#' @inheritParams chk_values_categories
#' @param x A list of vectors,
#' each of which has length 2.
#'
#' @examples
#' x <- list(c(100L, NA), c(0L, 5L), c(NA, 0L), c(5L, 50L))
#' chk_values_pairs(x = x, name = "x")
#' x <- list(as.Date(c("2001-01-01", "2002-01-01")))
#' chk_values_pairs(x = x, name = "x")
#' @export
chk_values_pairs <- function(x, name) {
## x is list
val <- chk_is_list(x = x,
name = name)
if (!isTRUE(val))
return(val)
## all items in list have length 2
val <- chk_items_length_k(x = x,
k = 2L,
name = name)
if (!isTRUE(val))
return(val)
## second element greater than first element
val <- chk_items_increasing(x = x,
strict = TRUE,
name = name)
if (!isTRUE(val))
return(val)
## values do not overlap (including NAs)
val <- chk_no_overlap_pairs(x = x,
name = name)
if (!isTRUE(val))
return(val)
TRUE
}
## HAS_TESTS
#' Check values for Integers labels
#'
#' Checks:
#' \itemize{
#' \item is list of integer vectors of length 2
#' \item second element of each vector one greater than first
#' \item intervals do not overlap
#' }
#'
#' @inheritParams chk_values_categories
#' @param x A list of integer vectors,
#' each of which has length 2.
#'
#' @examples
#' x <- list(c(100L, NA), c(0L, 1L), c(NA, 0L), c(5L, 6L))
#' chk_values_integers(x = x, name = "x")
#' @export
chk_values_integers <- function(x, name) {
val <- chk_values_pairs(x = x,
name = name)
if (!isTRUE(val))
return(val)
## all items in list are integer
val <- chk_items_integer(x = x,
name = name)
if (!isTRUE(val))
return(val)
## second element one greater than first element
val <- chk_items_one_greater(x = x,
name = name)
if (!isTRUE(val))
return(val)
TRUE
}
## HAS_TESTS
#' Check values for Intervals labels
#'
#' Checks:
#' \itemize{
#' \item is list of integer vectors of length 2
#' \item second element of each vector greater than first
#' \item intervals do not overlap
#' }
#'
#' Identical to \code{\link{chk_values_quantities}}
#'
#' @inheritParams chk_values_categories
#' @param x A list of integer vectors,
#' each of which has length 2.
#'
#' @examples
#' x <- list(c(100L, NA), c(0L, 5L), c(NA, 0L), c(5L, 50L))
#' chk_values_intervals(x = x, name = "x")
#' @export
chk_values_intervals <- function(x, name) {
val <- chk_values_pairs(x = x,
name = name)
if (!isTRUE(val))
return(val)
## all items in list are integer
val <- chk_items_integer(x = x,
name = name)
if (!isTRUE(val))
return(val)
TRUE
}
## HAS_TESTS
#' Check values for Quantities labels
#'
#' Checks:
#' \itemize{
#' \item is list of integer vectors of length 2
#' \item second element of each vector greater than first
#' \item intervals do not overlap
#' }
#'
#' Identical to \code{\link{chk_values_intervals}}
#'
#' @inheritParams chk_values_categories
#' @param x A list of integer vectors,
#' each of which has length 2.
#'
#' @examples
#' x <- list(c(100L, NA), c(0L, 5L), c(NA, 0L), c(5L, 50L))
#' chk_values_quantities(x = x, name = "x")
#' @export
chk_values_quantities <- function(x, name) {
val <- chk_values_pairs(x = x,
name = name)
if (!isTRUE(val))
return(val)
## all items in list are integer
val <- chk_items_integer(x = x,
name = name)
if (!isTRUE(val))
return(val)
TRUE
}
## HAS_TESTS
#' Check values for Quarters labels
#'
#' Checks:
#' \itemize{
#' \item is list of date vectors of length 2
#' \item first element is first day of quarter
#' \item second element is one quarter later than first (if neither NA)
#' \item intervals do not overlap
#' }
#'
#' @inheritParams chk_values_categories
#' @param x A list of Date vectors,
#' each of which has length 2.
#'
#' @examples
#' x <- list(as.Date(c("2000-01-01", "2000-04-01")),
#' as.Date(c(NA, "2000-01-01")),
#' as.Date(c(NA, NA)))
#' chk_values_quarters(x = x, name = "x")
#' @export
chk_values_quarters <- function(x, name) {
val <- chk_values_pairs(x = x,
name = name)
if (!isTRUE(val))
return(val)
## all items in list are Date
val <- chk_items_date(x = x,
name = name)
if (!isTRUE(val))
return(val)
for (i in seq_along(x)) {
item <- x[[i]]
## both elements are first day of quarter
for (j in 1:2) {
el <- item[[j]]
if (!is.na(el)) {
month <- format(el, "%m")
day <- format(el, "%d")
month_valid <- month %in% c("01", "04", "07", "10")
day_valid <- identical(day, "01")
if (!month_valid || !day_valid)
return(gettextf(paste("problem with item %d of '%s' : element %d [\"%s\"]",
"is not first day of quarter"),
i, name, j, el))
}
}
## second element is one quarter later than first
first <- item[[1L]]
second <- item[[2L]]
if (!is.na(first) && !is.na(second)) {
second_expected <- seq.Date(from = first,
by = "quarter",
length.out = 2L)[[2L]]
if (!identical(second, second_expected))
return(gettextf(paste("problem with item %d of '%s' : second element [\"%s\"]",
"not one quarter later than first element [\"%s\"]"),
i, name, second, first))
}
}
TRUE
}
## HAS_TESTS
#' Check values for Months labels
#'
#' Checks:
#' \itemize{
#' \item is list of date vectors of length 2
#' \item both elements are first day of month
#' \item second element is one month later than first (if neither NA)
#' \item intervals do not overlap
#' }
#'
#' @inheritParams chk_values_categories
#' @param x A list of Date vectors,
#' each of which has length 2.
#'
#' @examples
#' x <- list(as.Date(c("2000-01-01", "2000-02-01")),
#' as.Date(c(NA, "2000-01-01")),
#' as.Date(c(NA, NA)))
#' chk_values_months(x = x, name = "x")
#' @export
chk_values_months <- function(x, name) {
val <- chk_values_pairs(x = x,
name = name)
if (!isTRUE(val))
return(val)
## all items in list are Date
val <- chk_items_date(x = x,
name = name)
if (!isTRUE(val))
return(val)
for (i in seq_along(x)) {
item <- x[[i]]
## both elements are first day of month
for (j in 1:2) {
el <- item[[j]]
if (!is.na(el)) {
day <- format(el, "%d")
day_valid <- identical(day, "01")
if (!day_valid)
return(gettextf(paste("problem with item %d of '%s' : element %d [\"%s\"]",
"is not first day of month"),
i, name, j, el))
}
}
## second element is one month later than first
first <- item[[1L]]
second <- item[[2L]]
if (!is.na(first) && !is.na(second)) {
second_expected <- seq.Date(from = first,
by = "month",
length.out = 2L)[[2L]]
if (!identical(second, second_expected))
return(gettextf(paste("problem with item %d of '%s' : second element [\"%s\"]",
"not one month later than first element [\"%s\"]"),
i, name, second, first))
}
}
TRUE
}
## HAS_TESTS
#' Check values for DateRanges labels
#'
#' Checks:
#' \itemize{
#' \item is list of date vectors of length 2
#' \item second element is later than first (if neither NA)
#' \item intervals do not overlap
#' }
#'
#' @inheritParams chk_values_categories
#' @param x A list of Date vectors,
#' each of which has length 2.
#'
#' @examples
#' x <- list(as.Date(c("2000-01-03", "2000-01-03")),
#' as.Date(c(NA, "2000-01-02")),
#' as.Date(c(NA, NA)))
#' chk_values_dateranges(x = x, name = "x")
#' @export
chk_values_dateranges <- function(x, name) {
val <- chk_values_pairs(x = x,
name = name)
if (!isTRUE(val))
return(val)
## all items in list are Date
val <- chk_items_date(x = x,
name = name)
if (!isTRUE(val))
return(val)
TRUE
}
## DatePoints -----------------------------------------------------------------
## HAS_TESTS
#' Check values for DatePoints labels
#'
#' Checks:
#' \itemize{
#' \item is Date vector
#' \item no duplicates
#' }
#'
#' @inheritParams chk_values_categories
#' @param x A vector of class \code{\link[base]{Date}}.
#'
#' @examples
#' x <- as.Date(c("2000-05-01", NA, "2000-02-01"))
#' chk_values_datepoints(x = x, name = "x")
#' @export
chk_values_datepoints <- function(x, name) {
## is date
val <- chk_is_date(x = x,
name = name)
if (!isTRUE(val))
return(val)
## at most one NA
val <- chk_at_most_one_na_vector(x = x,
name = name)
if (!isTRUE(val))
return(val)
## no duplicates
val <- chk_no_duplicates(x = x,
name = name)
if (!isTRUE(val))
return(val)
TRUE
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.