R/chk-composite.R

In johnrbryant/demcheck: Checking for Demographic Packages

## Checks of composite conditions
##
## Functions to check for conditions that involve
## several attributes. For instance, \code{chk_integer_consec}
## checks whether \code{x} has type integer, whether \code{x}
## has no \code{NA}s, and whether \code{all(diff(x)) == 1L}.


#' Check that all intervals fall within limits
#' imposed by 'break_min' or 'break_max'
#'
#' All age groups are assumed to be closed.
#'
#' @param labels A vector of interval labels.
#' @param int_low An integer vector. The lower
#' breaks for the intervals.
#' @param int_up An integer vector. The upper
#' breaks for the intervals.
#' @param break_min Integer. Lower limit for all intervals,
#' expect for left open interval if present.
#' @param break_max Integer. Upper limit for all intervals,
#' except for right open interval if preseent.
#'
#' @examples
#' chk_interval_label_ge_break_min(labels = c("15-19", "20", "100-104"),
#'                                 int_low = c(15, 20, 100, NA),
#'                                 break_min = 15)
#' chk_interval_label_le_break_max(labels = c("20-24", "45-49", NA),
#'                                 int_up = c(25, 50, NA),
#'                                 break_max = 50)
#' @name chk_interval_label_ge_break_min
NULL

#' @export
#' @rdname chk_interval_label_ge_break_min
chk_interval_label_ge_break_min <- function(labels, int_low, break_min) {
    is_too_low <- !is.na(int_low) & (int_low < break_min)
    i_too_low <- match(TRUE, is_too_low, nomatch = 0L)
    if (i_too_low > 0L)
        return(gettextf("interval \"%s\" below '%s' [%d]",
                        labels[[i_too_low]],
                        "break_min",
                        break_min))
    TRUE
}

#' @export
#' @rdname chk_interval_label_ge_break_min
chk_interval_label_le_break_max <- function(labels, int_up, break_max) {
    is_too_high <- !is.na(int_up) & (int_up > break_max)
    i_too_high <- match(TRUE, is_too_high, nomatch = 0L)
    if (i_too_high > 0L)
        return(gettextf("interval \"%s\" above '%s' [%d]",
                        labels[[i_too_high]],
                        "break_max",
                        break_max))
    TRUE
}


## HAS_TESTS
#' Check that difference between upper and lower limits of
#' interval greater than or equal to 1
#'
#' Check applies to intervals with labels that have
#' a "low-up" format, ie not single-year age groups,
#' not open age groups or cohorts, and not missing.
#'
#' @inheritParams chk_interval_label_ge_break_min
#' @param is_low_up Logical. Whether label
#' has "low-up" format, eg "15-19".
#'
#' @examples
#' chk_interval_diff_gt_one(int_low = c(0, 1, 5, 10),
#'                          int_up = c(1, 5, 10, NA),
#'                          is_low_up = c(TRUE, TRUE, TRUE, FALSE),
#'                          labels = c("0", "1-4", "5-9", "10+"))
#' @name chk_interval_diff_ge_one
NULL

#' @rdname chk_interval_diff_ge_one
#' @export
chk_interval_diff_ge_one <- function(int_low, int_up, is_low_up, labels) {
    is_diff_lt <- int_up[is_low_up] - int_low[is_low_up] < 1L
    i_diff_lt <- match(TRUE, is_diff_lt, nomatch = 0L)
    if (i_diff_lt > 0L)
        return(gettextf("\"%s\" not a valid interval label : difference between upper and lower limits less than 1",
                        labels[is_low_up][[i_diff_lt]]))
    TRUE
}

#' @rdname chk_interval_diff_ge_one
#' @export
chk_interval_diff_gt_one <- function(int_low, int_up, is_low_up, labels) {
    is_diff_le <- int_up[is_low_up] - int_low[is_low_up] <= 1L
    i_diff_le <- match(TRUE, is_diff_le, nomatch = 0L)
    if (i_diff_le > 0L)
        return(gettextf("\"%s\" not a valid interval label : difference between upper and lower limits less than or equal to 1",
                        labels[is_low_up][[i_diff_le]]))
    TRUE
}


## HAS_TESTS
#' Check whether all elements of 'x1' are in 'x2'
#'
#' Check \code{x1} is contained in \code{x2}, potentially
#' after excluding \code{0}s from \code{x1}.
#'
#' The error message for \code{chk_all_x1_in_x2} does not
#' have quotes around the arguments, since these arguments
#' are often expressions.
#'
#' @param x1 A vector, typically integers.
#' @param x2 A vector, typically integers.
#' @param name1 The name for \code{x1} that
#' will be used in error messages.
#' @param name2 The name for \code{x2} that
#' will be used in error messages.
#' @param exclude_zero Whether to exclude zeros
#' from \code{x1} before testing.
#' 
#' @examples
#' x1 <- c(0L, 1L, 2L, 0L)
#' x2 <- 1:3
#' chk_all_x1_in_x2(x1 = x2,
#'                  x2 = x2,
#'                  name1 = "x1",
#'                  name2 = "x2",
#'                  exclude_zero = TRUE)
#' @export
chk_all_x1_in_x2 <- function(x1, x2, name1, name2, exclude_zero) {
    if (exclude_zero)
        x1 <- x1[x1 != 0L]
    i_x2 <- match(x1, x2)
    i_miss <- match(NA_integer_, i_x2, nomatch = 0L)
    if (i_miss > 0L)
        return(gettextf("element from %s not found in %s : %d",
                        name1, name2, x1[[i_miss]]))
    TRUE    
}


## HAS_TESTS
#' Check that an array has complete metadata
#'
#' Check it is possible to uniquely identify every cell
#' in an array, using the array's dimnames and the
#' the names of the dimnames.
#'
#' @param x An array.
#' @param name The name for \code{x} that
#' will be used in error messages.
#' 
#' @examples
#' x <- array(1:6,
#'            dim = 3:2,
#'            dimnames = list(region = c("a", "b", "c"),
#'                            sex = c("Female", "Male")))
#' chk_array_metadata_complete(x, name = "x")
#' @export
chk_array_metadata_complete <- function(x, name) {
    val <- chk_has_dimnames(x = x,
                            name = name)
    if (!isTRUE(val))
        return(val)
    val <- chk_has_names_dimnames(x = x,
                                  name = name)
    if (!isTRUE(val))
        return(val)
    val <- chk_names_dimnames_complete(x = x,
                                       name = name)
    if (!isTRUE(val))
        return(val)
    val <- chk_dimnames_complete(x = x,
                                 name = name)
    if (!isTRUE(val))
        return(val)
    TRUE
}


## HAS_TESTS
#' Check that a character vector has no
#' NAs, blanks, or duplicates
#'
#' @inheritParams chk_array_metadata_complete
#' @param x A character vector.
#'
#' @examples
#' x <- c("A", "B", "C")
#' chk_character_complete(x, name = "x")
#' @export
chk_character_complete <- function(x, name) {
    if (anyNA(x))
        return(gettextf("'%s' has NAs",
                        name))
    if (!all(nzchar(x)))
        return(gettextf("'%s' has blanks",
                        name))
    is_duplicated <- duplicated(x)
    if (any(is_duplicated)) {
        i <- match(TRUE, is_duplicated)
        return(gettextf("'%s' has duplicate [\"%s\"]",
                        name, x[[i]]))
    }
    TRUE
}


## HAS_TESTS
#' Check that differences between two variables
#' is divisible by a third variable
#'
#' @inheritParams chk_all_x1_in_x2
#' @param x1 The larger variable.
#' @param x2 The smaller variable.
#' @param y The third variable
#' @param name_y The name for \code{y} that will
#' be used in error messages.
#'
#' @examples
#' chk_difference_divisible(x1 = 50,
#'                          x2 = 15,
#'                          y = 5,
#'                          name1 = "x1",
#'                          name2 = "x2",
#'                          name_y = "y")
#' @export
chk_difference_divisible <- function(x1, x2, y, name1, name2, name_y) {
    if ((x1 - x2) %% y != 0L)
        return(gettextf("difference between '%s' [%d] and '%s' [%d] not divisible by '%s' [%d]",
                        name1, x1, name2, x2, name_y, y))
    TRUE
}


## HAS_TESTS
#' Check that a dimension equals or exceeeds a minimum length
#'
#' @param length_actual The actual length of the dimension.
#' @param length_min The minimum length of the dimension.
#' @param name The name of the dimension
#'
#' @examples
#' chk_dim_min_length(length_actual = 5L,
#'                    length_min = 2L,
#'                    name = "age")
#' @export
chk_dim_min_length <- function(length_actual, length_min, name) {
    if (length_actual < length_min)
        return(gettextf("length of %s dimension [%d] less than minimum [%d]",
                        name, length_actual, length_min))
    TRUE
}


## HAS_TESTS
#' Check that invervals defined by 'int_low' and 'int_high'
#' fall within intervals defined by 'breaks'
#'
#' @inheritParams chk_interval_label_ge_break_min
#' @param breaks Vector of strictly increasing integers.
#'
#' @examples
#' chk_intervals_inside_breaks(int_low = c(0, 1, 5, 10),
#'                             int_up = c(1, 5, 10, NA),
#'                             breaks = c(0, 5, 10, 15),
#'                             labels = c("0", "1-4", "5-9", "10+"))
#' @export
chk_intervals_inside_breaks <- function(int_low, int_up, breaks, labels) {
    i_int_low <- findInterval(int_low, breaks)
    i_int_up <- findInterval(int_up, breaks)
    up_is_break <- int_up %in% breaks
    is_valid <- (is.na(int_low)
        | is.na(int_up)
        | (!up_is_break & (i_int_up == i_int_low))
        | (up_is_break & (i_int_up == i_int_low + 1L)))
    i_invalid <- match(FALSE, is_valid, nomatch = 0L)
    if (i_invalid > 0L)
        return(gettextf("\"%s\" intersects two or more intervals",
                        labels[[i_invalid]]))
    TRUE
}


#' Check whether dimension(s) identified by an index are omitted,
#' or not omitted, according to 'map_dim'
#'
#' \code{chk_omitted} checks that a dimension \emph{is} omitted,
#' and \code{chk_not_omitted} checks that a dimension \emph{is not}
#' omitted.
#'
#' @param index An integer vector, identifying dimensions of array \code{self}
#' @param map_dim Integer vector mapping dimensions of array \code{self} to
#' dimensions of array \code{oth}.
#' @param name_index Name of \code{index}.
#' @param name_dim Name of the dimension that should or should not be omitted.
#'
#' @seealso \code{\link{chk_map_dim}}
#' 
#' @examples
#' chk_omitted(index = 2L,
#'               map_dim = c(1L, 0L, 2L),
#'               name_index = "indices_orig_self",
#'               name_dim = "origin")
#' chk_not_omitted(index = 3L,
#'                   map_dim = c(1L, 0L, 2L),
#'                   name_index = "indices_dest_self",
#'                   name_dim = "destination")
#' @name chk_omitted
NULL

#' @rdname chk_omitted
#' @export
chk_omitted <- function(index, map_dim, name_index, name_dim) {
    if (any(map_dim[index] > 0L))
        return(gettextf("%s dimension identified by '%s' is not omitted, according to '%s'",
                        name_dim, name_index, "map_dim"))
    TRUE
}

#' @rdname chk_omitted
#' @export
chk_not_omitted <- function(index, map_dim, name_index, name_dim) {
    if (any(map_dim[index] == 0L))
        return(gettextf("%s dimension identified by '%s' is omitted, according to '%s'",
                        name_dim, name_index, "map_dim"))
    TRUE
}


## HAS_TESTS
#' Check that all dimensions of an array have complete dimnames
#'
#' Check that the dimnames for an array include every
#' dimension, and have no blanks, NAs, or duplicates
#'
#' @param x An array.
#' @param name The name for \code{x} that
#' will be displayed in error messages.
#'
#' @seealso \code{\link{chk_array_metadata_complete}}.
#' 
#' @examples
#' x <- array(1:6,
#'            dim = 3:2,
#'            dimnames = list(region = c("a", "b", "c"),
#'                            sex = c("Female", "Male")))
#' chk_dimnames_complete(x, name = "x")
#' @export
chk_dimnames_complete <- function(x, name) {
    dimnames <- dimnames(x)
    names <- names(dimnames)
    dim <- dim(x)
    for (i in seq_along(dimnames)) {
        if (dim[[i]] > 0L) {
            dimnames_i <- dimnames[[i]]
            names_i <- names[[i]]
            if (is.null(dimnames_i))
                return(gettextf("\"%s\" dimension of '%s' does not have dimnames",
                                names_i, name))
            n_na <- sum(is.na(dimnames_i))
            if (n_na > 1L)
                return(gettextf("dimnames for \"%s\" dimension of '%s' have %d NAs",
                                names_i, name, n_na))
            if (!all(nzchar(dimnames_i)))
                return(gettextf("dimnames for \"%s\" dimension of '%s' have blanks",
                                names_i, name))
            is_duplicated <- duplicated(dimnames_i)
            if (any(is_duplicated)) {
                j <- match(TRUE, is_duplicated)
                return(gettextf("dimnames for \"%s\" dimension of '%s' have duplicate [\"%s\"]",
                                names_i, name, dimnames_i[[j]]))
            }
        }
    }
    TRUE
}

## HAS_TESTS
#' Check that dimtypes obey rules about appearing at most once,
#' or not occurring with other dimtypes
#'
#' @param dimtypes A character vector of dimtypes.
#'
#' @seealso \code{\link{chk_names_pairs_complete}}
#'
#' @examples
#' dimtypes <- c("age", "time", "triangle")
#' chk_dimtypes_mutually_compatible(dimtypes)
#' @export
chk_dimtypes_mutually_compatible <- function(dimtypes) {
    at_most_one <- c("age",
                     "time",
                     "cohort",
                     "triangle",
                     "iteration",
                     "quantile")
    for (dimtype in at_most_one) {
        if (sum(dimtypes == dimtype) > 1L)
            return(gettextf("two dimensions with dimtype \"%s\"",
                            dimtype))
    }
    if (("iteration" %in% dimtypes) && ("quantile" %in% dimtypes))
        return(gettextf("dimension with dimtype \"%s\" and dimension with dimtype \"%s\"",
                        "iteration", "quantile"))
    TRUE
}

## HAS_TESTS
#' Check all elements of an integer vector are
#' within a given range
#'
#' NAs are permitted
#' 
#' @inheritParams chk_array_metadata_complete
#' @param x An integer vector.
#' @param min Minimum permissible value. An integer.
#' @param max Maximum permissible value. An integer.
#'
#' @examples
#' chk_integer_in_range(x = c(1L, 7L, NA),
#'                      min = 1L,
#'                      max = 12L,
#'                      name = "x")
#' @export
chk_integer_in_range <- function(x, min, max, name) {
    x_obs <- x[!is.na(x)]
    if (length(x_obs) > 0L) {
        is_too_low <- x_obs < min
        i_too_low <- match(TRUE, is_too_low, nomatch = 0L)
        if (i_too_low > 0L)
            return(gettextf("element of '%s' [%d] is less than %d",
                            name, x_obs[[i_too_low]], min))
        is_too_high <- x_obs > max
        i_too_high <- match(TRUE, is_too_high, nomatch = 0L)
        if (i_too_high > 0L)
            return(gettextf("element of '%s' [%d] is greater than %d",
                            name, x_obs[[i_too_high]], max))
    }
    TRUE
}

## HAS_TESTS
#' Check that dimensions that should have pairs do
#' in fact have them
#'
#' Function \code{\link{chk_names_pairs_suffix}}
#' should be run before this one.
#'
#' @param names A character vector of dimension names.
#'
#' @examples
#' names <- c("reg_dest", "reg_orig")
#' chk_names_pairs_complete(names)
#' @export
chk_names_pairs_complete <- function(names) {
    vals <- list(c("origin", "_orig$", "destination", "_dest"),
                 c("destination", "_dest$", "origin", "_orig"),
                 c("parent", "_parent$", "child", "_child"),
                 c("child", "_child$", "parent", "_parent"))
    for (val in vals) {
        dimtype <- val[[1L]]
        p_dimtype <- val[[2L]]
        pair <- val[[3L]]
        p_pair <- val[[4L]]
        is_dimtype <- grepl(p_dimtype, names)
        if (any(is_dimtype)) {
            names_pair_implied <- sub(p_dimtype, p_pair, names[is_dimtype])
            is_not_found <- !(names_pair_implied %in% names)
            i_not_found <- match(TRUE, is_not_found, nomatch = 0L)
            if (i_not_found > 0L) {
                return(gettextf(paste("dimension \"%s\" with dimtype \"%s\" does not",
                                      "have paired dimension \"%s\" with dimtype \"%s\""),
                                names[is_dimtype][[i_not_found]],
                                dimtype,
                                names_pair_implied[[i_not_found]],
                                pair))
            }
        }
    }
    TRUE
}


## HAS_TESTS
#' Check that dimension names have pair suffixes if and only if
#' they have the appropriate dimtypes
#'
#' @param dimtypes A character vector of dimtypes.
#' @param names A character vector of names.
#'
#' @seealso Function \code{\link{chk_names_pairs_complete}} should only
#' be called if \code{chk_names_pairs_suffix} has been
#' called first
#'
#' @examples
#' dimtypes <- c("origin", "destination")
#' names <- c("reg_orig", "reg_dest")
#' chk_names_pairs_suffix(dimtypes = dimtypes, names = names)
#' @export
chk_names_pairs_suffix <- function(dimtypes, names) {
    patterns <- c(origin = "_orig",
                  destination = "_dest",
                  parent = "_parent",
                  child = "_child")
    for (i in seq_along(patterns)) {
        dimtype <- names(patterns)[[i]]
        pattern <- patterns[[i]]
        is_dimtype <- grepl(dimtype, dimtypes)
        is_pattern <- grepl(paste0(pattern, "$"), names)
        i_dimtype_not_pattern <- match(TRUE, is_dimtype & !is_pattern, nomatch = 0L)
        if (i_dimtype_not_pattern > 0L)
            return(gettextf("dimension \"%s\" has dimtype \"%s\" but name does not end with \"%s\"",
                            names[[i_dimtype_not_pattern]], dimtype, pattern))
        i_pattern_not_dimtype <- match(TRUE, is_pattern & !is_dimtype, nomatch = 0L)
        if (i_pattern_not_dimtype > 0L)
            return(gettextf("dimension \"%s\" has name ending with \"%s\" but does not have dimtype \"%s\"",
                            names[[i_pattern_not_dimtype]], pattern, dimtype))
    }
    TRUE   
}


## HAS_TESTS
#' Check that implied ages are greater than or equal to 'break_min'
#'
#' @param age Integer. Age, typically in years, but can be other unit.
#' @param break_min Integer or NULL. If non-NULL, lowest permissible value
#' for \code{age}.
#' @param date Date on which event occurred or measurement made.
#' Object of class \code{\link[base:Dates]{Date}}.
#' @param dob Date of birth. Object of class \code{\link[base:Dates]{Date}}.
#' @param unit Measurement units for age, eg \code{"month"}.
#' 
#' @seealso \code{\link{chk_ge_break_min_date}},
#' \code{\link{chk_lt_break_max_age}},
#' \code{\link{chk_lt_break_max_date}}
#'
#' @examples
#' age <- c(20L, 23L)
#' break_min <- 15L
#' date <- as.Date(c("2020-03-17", "2020-03-18"))
#' dob <- as.Date(c("2000-02-01", "1997-01-13"))
#' unit <- "years"
#' chk_ge_break_min_age(age = age,
#'                      break_min = break_min,
#'                      date = date,
#'                      dob = dob,
#'                      unit = unit)
#' @export
chk_ge_break_min_age <- function(age, break_min, date, dob, unit) {
    if (is.null(break_min))
        return(TRUE)
    lt_min <- !is.na(age) & (age < break_min)
    i <- match(TRUE, lt_min, nomatch = 0L)
    if (i > 0L) {
        return(gettextf(paste("'%s' [\"%s\"] and '%s' [\"%s\"] imply an age of %d %ss,",
                              "which is less than '%s' [%d %ss]"),
                        "date",
                        date[[i]],
                        "dob",
                        dob[[i]],
                        age[[i]],
                        unit,
                        "break_min",
                        break_min,
                        unit))
    }
    TRUE
}

## HAS_TESTS
#' Check that dates are greater than or equal to 'break_min'
#'
#' @param break_min Date or NULL. If non-NULL, lowest permissible value
#' for \code{date}.
#' @param date Date on which event occurred or measurement made.
#' Object of class \code{\link[base:Dates]{Date}}.
#' 
#' @seealso \code{\link{chk_ge_break_min_age}},
#' \code{\link{chk_lt_break_max_age}}
#' \code{\link{chk_lt_break_max_date}}
#' 
#' @examples
#' date <- as.Date(c("2020-03-17", "2020-03-18"))
#' break_min <- as.Date("2020-01-01")
#' chk_ge_break_min_date(date = date,
#'                       break_min = break_min)
#' @export
chk_ge_break_min_date <- function(date, break_min) {
    if (is.null(break_min))
        return(TRUE)
    lt_date_min <- !is.na(date) & (date < break_min)
    i <- match(TRUE, lt_date_min, nomatch = 0L)
    if (i > 0L) {
        return(gettextf("'%s' has value [\"%s\"] that is less than '%s' [\"%s\"]",
                        "date",
                        date[[i]],
                        "break_min",
                        break_min))
    }
    TRUE
}


#' Check that object or elements of list inherit
#' from specified class
#'
#' @inheritParams chk_array_metadata_complete
#' @param x An object, or a list of objects
#' @param class Name of a class.
#'
#' @examples
#' x <- "a"
#' class <- "character"
#' chk_is_class_obj(x, name = "x", class = class)
#' x <- list(c("a", "b"), "c")
#' chk_is_class_list(x, name = "x", class = class)
#' @name chk_is_class
NULL

## HAS_TESTS
#' @export
#' @rdname chk_is_class
chk_is_class_obj <- function(x, name, class) {
    if (!methods::is(x, class)) {
        return(gettextf(paste("'%s' has class \"%s\" :",
                              "should instead inherit from class \"%s\""),
                        name, class(x), class))
    }
    TRUE
}

## HAS_TESTS
#' @export
#' @rdname chk_is_class
chk_is_class_list <- function(x, name, class) {
    for (i in seq_along(x)) {
        if (!methods::is(x[[i]], class))
            return(gettextf(paste("element %d of '%s' has class \"%s\" :",
                                  "should instead inherit from class \"%s\""),
                            i, name, class(x[[i]]), class))
    }
    TRUE
}



#' Check dates are the first day of the specified unit
#'
#' If \code{unit} is \code{"months"},
#' then \code{"2000-03-01"} is the first day of the specified
#' unit, but \code{"2000-03-02"} is not.
#'
#' \code{chk_first_day_unit_consec} adds the requirement
#' that the dates be consecutive.
#'
#' @inheritParams chk_array_metadata_complete
#' @param x A scalar or vector of dates, or values
#' that can be coerced to dates.
#' @param unit Measurement units for time, eg \code{"month"}.
#'
#' @seealso \code{\link{chk_is_date_equiv}}
#'
#' @examples
#' x <- "2020-01-01"
#' chk_first_day_unit_scalar(x, name = "x", unit = "year")
#' x <- c("2020-01-01", "2020-02-01")
#' chk_first_day_unit_vector(x, name = "x", unit = "month")
#' chk_first_day_unit_consec(x, name = "x", unit = "month")
#' @name chk_first_day_unit_scalar
NULL

## HAS_TESTS
#' @export
#' @rdname chk_first_day_unit_scalar
chk_first_day_unit_scalar <- function(x, name, unit) {
    val <- chk_length_1(x = x,
                        name = name)
    if (!isTRUE(val))
        return(val)
    val <- chk_not_na_scalar(x = x,
                             name = name)
    if (!isTRUE(val))
        return(val)
    val <- chk_is_date_equiv_scalar(x = x,
                                    name = name)
    if (!isTRUE(val))
        return(val)
    x <- as.Date(x)
    val <- chk_member_unit(x = unit,
                           name = "unit")
    if (!isTRUE(val))
        return(val)
    year <- as.integer(format(x, "%Y"))
    unit_is_year <- identical(unit, "year")
    if (unit_is_year) {
        month <- format(x, "%m")
        from <- as.Date(sprintf("%d-%s-01", year, month))
        to <- as.Date(sprintf("%d-%s-01", year + 1L, month))
    }
    else {
        from <- as.Date(sprintf("%d-01-01", year))
        to <- as.Date(sprintf("%d-01-01", year + 1L))
    }
    seq_expected <- seq.Date(from = from,
                             to = to,
                             by = unit)
    is_not_in_seq <- !(x %in% seq_expected)
    if (is_not_in_seq) {
        msg <- gettextf("'%s' [\"%s\"] is not the first day of the %s",
                        name, format(x, "%Y-%m-%d"), unit)
        if (unit_is_year)
            msg <- paste(msg,
                         gettextf("(years assumed to start on the first day of %s)",
                                  format(x, "%B")))
        return(msg)        
    }
    TRUE
}

## HAS_TESTS
#' @export
#' @rdname chk_first_day_unit_scalar
chk_first_day_unit_vector <- function(x, name, unit) {
    n <- sum(!is.na(x))
    if (n == 0L)
        return(TRUE)
    val <- chk_is_date_equiv_vector(x = x,
                                    name = name)
    if (!isTRUE(val))
        return(val)
    x <- as.Date(x)
    val <- chk_member_unit(x = unit,
                           name = "unit")
    if (!isTRUE(val))
        return(val)
    year <- as.integer(format(x, "%Y"))
    unit_is_year <- identical(unit, "year")
    year_min <- min(year, na.rm = TRUE)
    year_max <- max(year, na.rm = TRUE)
    if (unit_is_year) {
        month_start <- format(x[!is.na(x)][[1L]], "%m")
        from <- as.Date(sprintf("%d-%s-01", year_min, month_start))
        to <- as.Date(sprintf("%d-%s-01", year_max + 1L, month_start))
    }
    else {
        from <- as.Date(sprintf("%d-01-01", year_min))
        to <- as.Date(sprintf("%d-01-01", year_max + 1L))
    }
    seq_expected <- seq.Date(from = from,
                             to = to,
                             by = unit)
    is_in_seq <- is.na(x) | (x %in% seq_expected)
    i_not_in_seq <- match(FALSE, is_in_seq, nomatch = 0L)
    if (i_not_in_seq > 0L) {
        msg <- gettextf("element %d [\"%s\"] of '%s' is not the first day of the %s",
                        i_not_in_seq,
                        format(x[[i_not_in_seq]], "%Y-%m-%d"),
                        name,
                        unit)
        if (unit_is_year)
            msg <- paste(msg,
                         gettextf("(years assumed to start on the first day of %s)",
                                  format(x[[1L]], "%B")))
        return(msg)        
    }
    TRUE
}

## HAS_TESTS
#' @export
#' @rdname chk_first_day_unit_scalar
chk_first_day_unit_consec <- function(x, name, unit) {
    n <- length(x)
    if (n == 0L)
        return(TRUE)
    val <- chk_first_day_unit_vector(x = x,
                                     name = name,
                                     unit = unit)
    if (!isTRUE(val))
        return(val)
    x_date <- as.Date(x)
    if (n >= 2L) {
        from <- x_date[[1L]]
        seq_expected <- seq.Date(from = from,     # Calculation using 'seq.Date' relies
                                 by = unit,       # on each date being the first day
                                 length.out = n)  # of the month
        is_not_equal_to_seq <- x_date != seq_expected
        if (any(is_not_equal_to_seq)) {
            i <- match(TRUE, is_not_equal_to_seq)
            return(gettextf("dates \"%s\" and \"%s\" in '%s' do not belong to consecutive %ss",
                            format(x[[i - 1L]], "%Y-%m-%d"),
                            format(x[[i]], "%Y-%m-%d"),
                            name,
                            unit))
        }
    }
    TRUE
}


#' Check that 'x1' is greater than or equal to 'x2'
#'
#' @inheritParams chk_all_x1_in_x2
#' @param x1 A scalar or vector.
#' @param x2 A scalar or vector the same length as \code{x1},
#' or length 1.
#'
#' @seealso \code{\link{chk_gt}}, \code{\link{chk_le}},
#' \code{\link{chk_lt}}
#'
#' @examples
#' x1 <- 3.1
#' x2 <- 3.1
#' chk_ge_scalar(x1 = x1, x2 = x2, name1 = "x1", name2 = "x2")
#' x1 <- c(3.1, 4.2, 5.7)
#' x2 <- c(3.1, 4.0, 4.2)
#' chk_ge_vector(x1 = x1, x2 = x2, name1 = "x1", name2 = "x2")
#' x1 <- c(3.1, 4.2, 5.7)
#' x2 <- 3.1
#' chk_ge_vector(x1 = x1, x2 = x2, name1 = "x1", name2 = "x2")
#' @name chk_ge
NULL

## HAS_TESTS
#' @export
#' @rdname chk_ge
chk_ge_scalar <- function(x1, x2, name1, name2) {
    if (!is.na(x1) && !is.na(x2) && (x1 < x2))
        return(gettextf("'%s' [%s] is less than '%s' [%s]",
                        name1, x1, name2, x2))
    TRUE
}

## HAS_TESTS
#' @export
#' @rdname chk_ge
chk_ge_vector <- function(x1, x2, name1, name2) {
    n1 <- length(x1)
    n2 <- length(x2)
    if ((n2 != n1) && (n2 != 1L))
        return(gettextf("'%s' has length %d and '%s' has length %d",
                        name1, n1, name2, n2))
    is_lt <- !is.na(x1) & !is.na(x2) & (x1 < x2)
    if (any(is_lt)) {
        i <- match(TRUE, is_lt)
        if (n2 > 1L)
            return(gettextf("element %d of '%s' [%s] is less than element %d of '%s' [%s]",
                            i, name1, x1[[i]], i, name2, x2[[i]]))
        else
            return(gettextf("element %d of '%s' [%s] is less than '%s' [%s]",
                            i, name1, x1[[i]], name2, x2))
    }
    TRUE
}


#' Check that 'x1' is greater than 'x2'
#'
#' @inheritParams chk_all_x1_in_x2
#' @param x1 A scalar or vector.
#' @param x2 A scalar or vector the same length as \code{x1},
#' or length 1.
#'
#' @seealso \code{\link{chk_ge}},  \code{\link{chk_le}},
#' \code{\link{chk_lt}}
#'
#' @examples
#' x1 <- 3.2
#' x2 <- 3.1
#' chk_gt_scalar(x1 = x1, x2 = x2, name1 = "x1", name2 = "x2")
#' x1 <- c(3.2, 4.2, 5.7)
#' x2 <- c(3.1, 4.0, 4.2)
#' chk_gt_vector(x1 = x1, x2 = x2, name1 = "x1", name2 = "x2")
#' x1 <- c(3.2, 4.2, 5.7)
#' x2 <- 3.1
#' chk_gt_vector(x1 = x1, x2 = x2, name1 = "x1", name2 = "x2")
#' @name chk_gt
NULL

## HAS_TESTS
#' @export
#' @rdname chk_gt
chk_gt_scalar <- function(x1, x2, name1, name2) {
    if (!is.na(x1) && !is.na(x2) && !(x1 > x2))
        return(gettextf("'%s' [%s] is less than or equal to '%s' [%s]",
                        name1, x1, name2, x2))
    TRUE
}

## HAS_TESTS
#' @export
#' @rdname chk_gt
chk_gt_vector <- function(x1, x2, name1, name2) {
    n1 <- length(x1)
    n2 <- length(x2)
    if ((n2 != n1) && (n2 != 1L))
        return(gettextf("'%s' has length %d and '%s' has length %d",
                        name1, n1, name2, n2))
    is_lt <- !is.na(x1) & !is.na(x2) & !(x1 > x2)
    i <- match(TRUE, is_lt, nomatch = 0L)    
    if (i > 0L) {
        if (n2 > 1L)
            return(gettextf("element %d of '%s' [%s] is less than or equal to element %d of '%s' [%s]",
                            i, name1, x1[[i]], i, name2, x2[[i]]))
        else
            return(gettextf("element %d of '%s' [%s] is less than or equal to '%s' [%s]",
                            i, name1, x1[[i]], name2, x2))            
    }
    TRUE
}


#' Check that 'x' is a non-NA logical vector of length 1
#'
#' @inheritParams chk_array_metadata_complete
#' @param x A scalar.
#'
#' @examples
#' x <- TRUE
#' chk_is_logical_flag(x, name = "x")
#' @export
chk_is_logical_flag <- function(x, name) {
    val <- chk_is_logical(x = x, name = name)
    if (!isTRUE(val))
        return(val)
    val <- chk_length_1(x = x, name = name)
    if (!isTRUE(val))
        return(val)
    val <- chk_not_na_scalar(x = x, name = name)
    if (!isTRUE(val))
        return(val)
    TRUE
}


#' Check that 'x1' is less than or equal to 'x2'
#'
#' @inheritParams chk_all_x1_in_x2
#' @param x1 A scalar or vector.
#' @param x2 A scalar or vector the same length as \code{x1},
#' or length 1.
#'
#' @seealso \code{\link{chk_lt}}, \code{\link{chk_ge}},
#' \code{\link{chk_gt}}
#'
#' @examples
#' x1 <- 2.2
#' x2 <- 3.1
#' chk_le_scalar(x1 = x1, x2 = x2, name1 = "x1", name2 = "x2")
#' x1 <- c(3.3, 4.2, 5.7)
#' x2 <- c(3.3, 4.6, 6.2)
#' chk_le_vector(x1 = x1, x2 = x2, name1 = "x1", name2 = "x2")
#' x1 <- c(3.3, 4.2, 5.7)
#' x2 <- 3.3
#' chk_le_vector(x1 = x1, x2 = x2, name1 = "x1", name2 = "x2")
#' @name chk_le
NULL

## HAS_TESTS
#' @export
#' @rdname chk_le
chk_le_scalar <- function(x1, x2, name1, name2) {
    if (!is.na(x1) && !is.na(x2) && (x1 > x2))
        return(gettextf("'%s' [%s] is greater than '%s' [%s]",
                        name1, x1, name2, x2))
    TRUE
}

## HAS_TESTS
#' @export
#' @rdname chk_le
chk_le_vector <- function(x1, x2, name1, name2) {
    n1 <- length(x1)
    n2 <- length(x2)
    if ((n2 != n1) && (n2 != 1L))
        return(gettextf("'%s' has length %d and '%s' has length %d",
                        name1, n1, name2, n2))
    is_ge <- !is.na(x1) & !is.na(x2) & (x1 > x2)
    i <- match(TRUE, is_ge, nomatch = 0L)    
    if (i > 0L) {
        if (n2 > 1L)
            return(gettextf("element %d of '%s' [%s] is greater than element %d of '%s' [%s]",
                            i, name1, x1[[i]], i, name2, x2[[i]]))
        else
            return(gettextf("element %d of '%s' [%s] is greater than '%s' [%s]",
                            i, name1, x1[[i]], name2, x2))
    }
    TRUE
}


#' Check that 'x1' is less than 'x2'
#'
#' @inheritParams chk_all_x1_in_x2
#' @param x1 A scalar or vector.
#' @param x2 A scalar or vector the same length as \code{x1},
#' or length 1.
#'
#' @seealso \code{\link{chk_le}}, \code{\link{chk_ge}},
#' \code{\link{chk_gt}}
#'
#' @examples
#' x1 <- 2.2
#' x2 <- 3.1
#' chk_lt_scalar(x1 = x1, x2 = x2, name1 = "x1", name2 = "x2")
#' x1 <- c(3.2, 4.2, 5.7)
#' x2 <- c(3.3, 4.6, 6.2)
#' chk_lt_vector(x1 = x1, x2 = x2, name1 = "x1", name2 = "x2")
#' x1 <- c(3.2, 4.2, 5.7)
#' x2 <- 3.3
#' chk_lt_vector(x1 = x1, x2 = x2, name1 = "x1", name2 = "x2")
#' @name chk_lt
NULL

## HAS_TESTS
#' @export
#' @rdname chk_lt
chk_lt_scalar <- function(x1, x2, name1, name2) {
    if (!is.na(x1) && !is.na(x2) && !(x1 < x2))
        return(gettextf("'%s' [%s] is greater than or equal to '%s' [%s]",
                        name1, x1, name2, x2))
    TRUE
}

## HAS_TESTS
#' @export
#' @rdname chk_lt
chk_lt_vector <- function(x1, x2, name1, name2) {
    n1 <- length(x1)
    n2 <- length(x2)
    if ((n2 != n1) && (n2 != 1L))
        return(gettextf("'%s' has length %d and '%s' has length %d",
                        name1, n1, name2, n2))
    is_ge <- !is.na(x1) & !is.na(x2) & !(x1 < x2)
    i <- match(TRUE, is_ge, nomatch = 0L)    
    if (i > 0L) {
        if (n2 > 1L)
            return(gettextf("element %d of '%s' [%s] is greater than or equal to element %d of '%s' [%s]",
                            i, name1, x1[[i]], i, name2, x2[[i]]))
        else
            return(gettextf("element %d of '%s' [%s] is greater than or equal to '%s' [%s]",
                            i, name1, x1[[i]], name2, x2))
    }
    TRUE
}


#' Check that 'x1' is a multiple of 'x2'
#'
#' If \code{null_ok} is \code{TRUE} and \code{x1}
#' is \code{NULL} then the test succeeds.
#' 
#' @inheritParams chk_all_x1_in_x2
#' @param x1 A scalar.
#' @param x2 A scalar.
#' 
#' @seealso \code{\link{chk_multiple_of_n}}
#'
#' @examples
#' x1 <- 10L
#' x2 <- 2L
#' chk_multiple_of(x1 = x1,
#'                 x2 = x2,
#'                 name1 = "x1",
#'                 name2 = "x2")
#' @export
chk_multiple_of <- function(x1, x2, name1, name2) {
    if (is.null(x1)) {
        return(gettextf("'%s' is %s",
                        name1, "NULL"))
    }
    else {
        if (x1 %% x2 != 0L)
            return(gettextf("'%s' [%s] is not a multiple of '%s' [%s]",
                            name1, x1, name2, x2))
    }
    TRUE
}


#' Check that 'x1' is a multiple of 'n'
#'
#' \code{chk_multiple_of_n} differs from
#' \code{\link{chk_multiple_of}} only in the
#' error message. \code{chk_multiple_of_n} refers
#' to the value of \code{n}, rather than to the
#' variable \code{"n"}.
#' 
#' @inheritParams chk_array_metadata_complete
#' @param x A scalar.
#' @param n A scalar.
#' 
#' @examples
#' x <- 10L
#' n <- 2L
#' chk_multiple_of_n(x = x, n = n, name = "x")
#' @export
chk_multiple_of_n <- function(x, name, n) {
    if (is.null(x)) {
        return(gettextf("'%s' is %s",
                        name, "NULL"))
    }
    else {
        if (x %% n != 0L)
            return(gettextf("'%s' [%s] is not a multiple of %d",
                            name, x, n))
    }
    TRUE
}


#' Check that elements of a scalar or vector are non-negative
#'
#' NAs are ignored.
#'
#' @inheritParams chk_array_metadata_complete
#' @param x A scalar or vector.
#'
#' @seealso \code{\link{chk_positive_scalar}}
#'
#' @examples
#' x <- 0.1
#' chk_non_negative_scalar(x, name = "x")
#' x <- NA_integer_
#' chk_non_negative_scalar(x, name = "x")
#' x <- c(0.1, 0, NA)
#' chk_non_negative_vector(x, name = "x")
#' @name chk_non_negative
NULL

## HAS_TESTS
#' @export
#' @rdname chk_non_negative
chk_non_negative_scalar <- function(x, name) {
    val <- chk_length_1(x = x,
                        name = name)
    if (!isTRUE(val))
        return(val)
    val <- chk_is_numeric(x = x,
                          name = name)
    if (!isTRUE(val))
        return(val)
    if (!is.na(x) & (x < 0L))
        return(gettextf("'%s' [%s] is negative",
                        name, x))
    TRUE
}

## HAS_TESTS
#' @export
#' @rdname chk_non_negative
chk_non_negative_vector <- function(x, name) {
    val <- chk_is_numeric(x = x,
                          name = name)
    if (!isTRUE(val))
        return(val)
    is_neg <- !is.na(x) & (x < 0L)
    if (any(is_neg)) {
        i <- match(TRUE, is_neg)
        return(gettextf("element %d of '%s' [%s] is negative",
                        i, name, x[[i]]))
    }
    TRUE
}


#' Check that integers 'x1' and 'x2' are not equal
#'
#' @inheritParams chk_all_x1_in_x2
#' @param x1 An integer scalar.
#' @param x2 An integer scalar.
#'
#' @seealso \code{\link{chk_le}},
#' \code{\link{chk_lt}}, \code{\link{chk_ge}},
#' \code{\link{chk_gt}}
#'
#' @examples
#' x1 <- 2L
#' x2 <- 3L
#' chk_not_equal_integer_scalar(x1 = x1, x2 = x2, name1 = "x1", name2 = "x2")
#' @export
chk_not_equal_integer_scalar <- function(x1, x2, name1, name2) {
    if (!is.na(x1) && !is.na(x2) && (x1 == x2))
        return(gettextf("'%s' [%d] is equal to '%s' [%d]",
                        name1, x1, name2, x2))
    TRUE
}


#' Check NULL status of 'x1' given NULL status of 'x2'
#'
#' \code{chk_null_if_null} checks that \code{x1} is \code{NULL},
#' given that \code{x2} is \code{NULL}.
#'
#' \code{chk_null_onlyif_null} checks that \code{x1} is only
#' \code{NULL} when \code{x2} is \code{NULL}.
#'
#' \code{chk_null_ifonlyif_null} checks that \code{x1} and
#' \code{x2} are both \code{NULL} or are both non-\code{NULL}.
#' 
#' @inheritParams chk_all_x1_in_x2
#' @param x1 An argument that could be \code{NULL}.
#' @param x2 An argument that could be \code{NULL}.
#'
#' @seealso \code{\link{chk_zero}}
#'
#' @examples
#' x1 <- NULL
#' x2 <- 2
#' chk_null_if_null(x1 = x1, x2 = x2, name1 = "x1", name2 = "x2")
#' x1 <- NULL
#' x2 <- NULL
#' chk_null_if_null(x1 = x1, x2 = x2, name1 = "x1", name2 = "x2")
#' x1 <- 1
#' x2 <- NULL
#' chk_null_onlyif_null(x1 = x1, x2 = x2, name1 = "x1", name2 = "x2")
#' x1 <- NULL
#' x2 <- NULL
#' chk_null_onlyif_null(x1 = x1, x2 = x2, name1 = "x1", name2 = "x2")
#' x1 <- 1
#' x2 <- 2
#' chk_null_ifonlyif_null(x1 = x1, x2 = x2, name1 = "x1", name2 = "x2")
#' x1 <- NULL
#' x2 <- NULL
#' chk_null_ifonlyif_null(x1 = x1, x2 = x2, name1 = "x1", name2 = "x2")
#' @name chk_null
NULL

#' @rdname chk_null
#' @export
chk_null_if_null <- function(x1, x2, name1, name2) {
    if (!is.null(x1) && is.null(x2))
        return(gettextf("'%s' is %s [%s] but '%s' is %s",
                        name1, "non-NULL", x1, name2, "NULL"))
    TRUE
}

#' @rdname chk_null
#' @export
chk_null_onlyif_null <- function(x1, x2, name1, name2) {
    if (is.null(x1) && !is.null(x2))
        return(gettextf("'%s' is %s but '%s' is %s [%s]",
                        name1, "NULL", name2, "non-NULL", x2))
    TRUE
}

#' @rdname chk_null
#' @export
chk_null_ifonlyif_null <- function(x1, x2, name1, name2) {
    val <- chk_null_if_null(x1 = x1,
                            x2 = x2,
                            name1 = name1,
                            name2 = name2)
    if (!isTRUE(val))
        return(val)
    val <- chk_null_onlyif_null(x1 = x1,
                                x2 = x2,
                                name1 = name1,
                                name2 = name2)
    if (!isTRUE(val))
        return(val)
    TRUE
}

#' Check that elements of a scalar or vector are positive
#'
#' NAs are ignored.
#'
#' @inheritParams chk_array_metadata_complete
#' @param x A scalar or vector.
#'
#' @seealso \code{\link{chk_non_negative_scalar}}
#'
#' @examples
#' x <- 0.1
#' chk_positive_scalar(x, name = "x")
#' x <- NA_integer_
#' chk_positive_scalar(x, name = "x")
#' x <- c(0.1, 0.0001, 100, NA)
#' chk_positive_vector(x, name = "x")
#' @name chk_positive
NULL

## HAS_TESTS
#' @export
#' @rdname chk_positive
chk_positive_scalar <- function(x, name) {
    val <- chk_length_1(x = x,
                        name = name)
    if (!isTRUE(val))
        return(val)
    val <- chk_is_numeric(x = x,
                          name = name)
    if (!isTRUE(val))
        return(val)
    if (!is.na(x) & (x <= 0L))
        return(gettextf("'%s' [%s] is non-positive",
                        name, x))
    TRUE
}

## HAS_TESTS
#' @export
#' @rdname chk_positive
chk_positive_vector <- function(x, name) {
    val <- chk_is_numeric(x = x,
                          name = name)
    if (!isTRUE(val))
        return(val)
    is_non_pos <- !is.na(x) & (x <= 0L)
    if (any(is_non_pos)) {
        i <- match(TRUE, is_non_pos)
        return(gettextf("element %d of '%s' [%s] is non-positive",
                        i, name, x[[i]]))
    }
    TRUE
}


## HAS_TESTS
#' Check that an object is a non-NA character
#' vector of length 1
#'
#' @inheritParams chk_array_metadata_complete
#' @param x An object.
#'
#' @examples
#' x <- "hello"
#' chk_is_string(x, name = "x")
#' @export
chk_is_string <- function(x, name) {
    val <- chk_is_character(x = x, name = name)
    if (!isTRUE(val))
        return(val)
    val <- chk_length_1(x = x, name = name)
    if (!isTRUE(val))
        return(val)
    val <- chk_not_na_scalar(x = x, name = name)
    if (!isTRUE(val))
        return(val)
    TRUE
}


## HAS_TESTS
#' Check that elements in a vector of
#' numbers or dates are increasing
#' or strictly increasing
#'
#' \code{chk_increasing} checks that each value is equal to
#' or greater than the one before it;
#' \code{chk_strictly_increasing} checks that each value is
#' greater than the one before it.
#'
#' @inheritParams chk_array_metadata_complete
#' @param x A vector of dates or numbers.
#'
#' @examples
#' x <- c(1:4, 4)
#' chk_increasing(x, name = "x")
#' x <- 1:5
#' chk_strictly_increasing(x, name = "x")
#' @name chk_increasing
NULL

#' @rdname chk_increasing
#' @export
chk_increasing <- function(x, name) {
    val <- chk_is_date_or_numeric(x = x, name = name)
    if (!isTRUE(val))
        return(val)
    val <- chk_not_na_vector(x = x, name = name)
    if (!isTRUE(val))
        return(val)
    if (length(x) >= 2L) {
        is_not_incr <- diff(x) < 0L
        i_not_incr <- match(TRUE, is_not_incr, nomatch = 0L)
        if (i_not_incr > 0L) {
            return(gettextf("'%s' is not increasing : element %d [%s] is greater than element %d [%s]",
                            name,
                            i_not_incr,
                            x[[i_not_incr]],
                            i_not_incr + 1L,
                            x[[i_not_incr + 1L]]))
        }
    }
    TRUE
}

#' @rdname chk_increasing
#' @export
chk_strictly_increasing <- function(x, name) {
    val <- chk_is_date_or_numeric(x = x, name = name)
    if (!isTRUE(val))
        return(val)
    val <- chk_not_na_vector(x = x, name = name)
    if (!isTRUE(val))
        return(val)
    if (length(x) >= 2L) {
        is_not_incr <- diff(x) <= 0L
        i_not_incr <- match(TRUE, is_not_incr, nomatch = 0L)
        if (i_not_incr > 0L) {
            return(gettextf("'%s' is not strictly increasing : element %d [%s] is greater than or equal to element %d [%s]",
                            name,
                            i_not_incr,
                            x[[i_not_incr]],
                            i_not_incr + 1L,
                            x[[i_not_incr + 1L]]))
        }
    }
    TRUE
}




#' Check that an array has dimnames
#'
#' Check that an array has dimnames, and that
#' those dimnames have names.
#'
#' @inheritParams chk_all_0_1
#' @param x An array.
#'
#' @seealso \code{\link{chk_no_dimnames}},
#' \code{\link{chk_array_metadata_complete}}
#' 
#' @examples
#' x <- array(1:6,
#'            dim = 3:2,
#'            dimnames = list(age = c("0-4", "5-9", "10+"),
#'                            sex = c("Female", "Male")))
#' chk_has_dimnames(x, name = "x")
#' chk_has_names_dimnames(x, name = "x")
#' @name chk_has_dimnames
NULL

#' @export
#' @rdname chk_has_dimnames
chk_has_dimnames <- function(x, name) {
    if (is.null(dimnames(x)))
        return(gettextf("'%s' does not have dimnames",
                        name))
    TRUE
}

#' @export
#' @rdname chk_has_dimnames
chk_has_names_dimnames <- function(x, name) {
    if (is.null(names(dimnames(x))))
        return(gettextf("dimnames for '%s' do not have names",
                        name))
    TRUE
}


#' Check that dimension indices all refer
#' to different dimensions
#'
#' @param indices A list of integer vectors
#' (typically of length 1).
#' @param names A character vector with the names
#' of the indices.
#' @param exclude_zero Logical. Whether to
#' exclude zeros in \code{indices} before
#' testing for uniqueness.
#'
#' @examples
#' indices <- list(3L, 1:2, 0L, 6:5)
#' names <- c("i_time", "i_orig", "i_age", "i_dest")
#' exclude_zero <- TRUE
#' chk_indices_distinct(indices = indices,
#'                      names = names,
#'                      exclude_zero = exclude_zero)
#' @export
chk_indices_distinct <- function(indices, names, exclude_zero) {
    indices_all <- unlist(indices)
    if (exclude_zero)
        indices_all <- indices_all[indices_all != 0L]
    has_duplicates <- any(duplicated(indices_all))
    if (has_duplicates) {
        names <- sprintf("'%s'", names)
        indices <- vapply(indices, paste, character(1L), collapse = ",")
        indices <- sprintf("[%s]", indices)
        names_indices <- paste(names, indices)
        names_indices <- paste(names, indices, collapse = ", ")
        return(gettextf("indices %s overlap",
                        names_indices))
    }
    TRUE
}


#' Check that a label has the correct format for a
#' single quarter or month
#' 
#' @inheritParams chk_all_0_1
#' @param x A string.
#'
#' @examples
#' chk_valid_label_single_month("2001 Jan", name = "x")
#' chk_valid_label_single_quarter("2001 Q1", name = "x")
#' @name chk_valid_label_single_month
NULL

#' @rdname chk_valid_label_single_month
#' @export
chk_valid_label_single_month <- function(x, name) {
    p <- paste(sprintf("^[0-9]+ %s$", base::month.abb), collapse = "|")
    val <- chk_is_string(x = x,
                         name = name)
    if (!isTRUE(val))
        return(val)
    if (!grepl(p, x))
        return(gettextf("invalid value for '%s' [\"%s\"]",
                        name, x))
    TRUE
}

#' @rdname chk_valid_label_single_month
#' @export
chk_valid_label_single_quarter <- function(x, name) {
    p <- "^[0-9]+ Q[1-4]$"
    val <- chk_is_string(x = x,
                         name = name)
    if (!isTRUE(val))
        return(val)
    if (!grepl(p, x))
        return(gettextf("invalid value for '%s' [\"%s\"]",
                        name, x))
    TRUE
}




#' Check that 'x1' has length specified by 'x2'
#' 
#' @inheritParams chk_all_x1_in_x2
#' @param x1 An object.
#' @param x2 A positive integer.
#'
#' @seealso \code{\link{chk_length_same_or_1}},
#' \code{\link{chk_length_same}}
#'
#' @examples
#' chk_length_equals(x1 = c(1L, 3L, 2L),
#'                   x2 = 3L,
#'                   name1 = "x1",
#'                   name2 = "x2")
#'@export
chk_length_equals <- function(x1, x2, name1, name2) {
    n1 <- length(x1)
    if (!identical(n1, x2))
        return(gettextf("length of '%s' [%d] not equal to '%s' [%d]",
                        name1, n1, name2, x2))
    TRUE
}


#' Check that 'x1' and 'x2' have same length
#'
#' @inheritParams chk_all_x1_in_x2
#' @param x1 An object.
#' @param x2 An object.
#' 
#' @seealso \code{\link{chk_length_equals}},
#' \code{\link{chk_length_same_or_1}}
#'
#' @examples
#' x1 <- 1:5
#' x2 <- 2:6
#' chk_length_same(x1 = x1, x2 = x2,
#'                 name1 = "x1", name2 = "x2")
#' @export
chk_length_same <- function(x1, x2, name1, name2) {
    n1 <- length(x1)
    n2 <- length(x2)
    if (n1 != n2)
        return(gettextf("length of '%s' [%d] not equal to length of '%s' [%d]",
                        name1, n1, name2, n2))
    TRUE
}


#' Check that 'x1' and 'x2' have same
#' (non-zero) length or has length 1
#'
#' @inheritParams chk_all_x1_in_x2
#' @param x1 An object.
#' @param x2 An object.
#' 
#' @seealso \code{\link{chk_length_equals}},
                                        # '\code{\link{chk_length_same}}
#'
#' @examples
#' x1 <- 1:5
#' x2 <- 2:6
#' chk_length_same_or_1(x1 = x1, x2 = x2,
#'                      name1 = "x1", name2 = "x2")
#' x2 <- 1L
#' chk_length_same_or_1(x1 = x1, x2 = x2,
#'                      name1 = "x1", name2 = "x2")
#' @export
chk_length_same_or_1 <- function(x1, x2, name1, name2) {
    n1 <- length(x1)
    n2 <- length(x2)
    if (n1 == 0L)
        return(gettextf("'%s' has length %d",
                        name1, 0L))
    if (n2 == 0L)
        return(gettextf("'%s' has length %d",
                        name2, 0L))
    if (n1 == n2)
        return(TRUE)
    if ((n1 == 1L) || (n2 == 1L))
        return(TRUE)
    gettextf("'%s' has length %d and '%s' has length %d : should have same lengths, or one should have length %d",
             name1, n1, name2, n2, 1L)
}


## HAS TESTS
#' Check that 'x2' gives the lengths of the elements of 'x1'
#'
#' @inheritParams chk_all_x1_in_x2
#' @param x1 A list.
#' @param x2 An integer vector, the same length as \code{x1}.
#'
#' @examples
#' x1 <- list(1:4, 1:2, 1:3)
#' x2 <- c(4L, 2L, 3L)
#' chk_lengths_elements_equal_vec(x1 = x1, x2 = x2,
#'                                name1 = "x1", name2 = "x2")
#' @export
chk_lengths_elements_equal_vec <- function(x1, x2, name1, name2) {
    for (i in seq_along(x1)) {
        n1 <- length(x1[[i]])
        n2 <- x2[[i]]
        if (!identical(n1, n2)) {
            return(gettextf("length of element %d of '%s' [%d] not equal to element %d of '%s' [%d]",
                            i, name1, n1, i, name2, n2))
        }
    }
    TRUE
}    


## HAS_TESTS
#' Check that implied ages are less than 'break_max'
#'
#' @inheritParams chk_ge_break_min_age
#' @param break_max Integer or NULL. If non-NULL, upper limit
#' for \code{age}.
#' @param date Date on which event occurred or measurement made.
#' Object of class \code{\link[base:Dates]{Date}}.
#' @param dob Date of birth. Object of class \code{\link[base:Dates]{Date}}.
#' @param unit Measurement units for age, eg \code{"month"}.
#' 
#' @seealso \code{\link{chk_ge_break_min_age}},
#' \code{\link{chk_ge_break_min_date}},
#' \code{\link{chk_lt_break_max_date}}
#'
#' @examples
#' age <- c(80L, 83L)
#' break_max <- 85L
#' date <- as.Date(c("2020-03-17", "2020-03-18"))
#' dob <- as.Date(c("1940-02-01", "1937-01-13"))
#' unit <- "years"
#' chk_lt_break_max_age(age = age,
#'                      break_max = break_max,
#'                      date = date,
#'                      dob = dob,
#'                      unit = unit)
#' @export
chk_lt_break_max_age <- function(age, break_max, date, dob, unit) {
    if (is.null(break_max))
        return(TRUE)
    ge_max <- !is.na(age) & (age >= break_max)
    i <- match(TRUE, ge_max, nomatch = 0L)
    if (i > 0L) {
        return(gettextf(paste("'%s' [\"%s\"] and '%s' [\"%s\"] imply an age of %d %ss,",
                              "which is greater than or equal to '%s' [%d %ss]"),
                        "date",
                        date[[i]],
                        "dob",
                        dob[[i]],
                        age[[i]],
                        unit,
                        "break_max",
                        break_max,
                        unit))
    }
    TRUE
}


## HAS_TESTS
#' Check that dates are less than 'break_max'
#'
#' @inheritParams chk_ge_break_min_date
#' @param break_max Date or NULL. If non-NULL, upper limit
#' for \code{date}.
#' 
#' @seealso \code{\link{chk_ge_break_min_age}},
#' \code{\link{chk_ge_break_min_date}},
#' \code{\link{chk_lt_break_max_age}}
#'
#' @examples
#' date <- as.Date(c("2020-03-17", "2020-03-18"))
#' break_max <- as.Date("2020-06-01")
#' chk_lt_break_max_date(date = date, break_max = break_max)
#' @export
chk_lt_break_max_date <- function(date, break_max) {
    if (is.null(break_max))
        return(TRUE)
    ge_date_max <- !is.na(date) & (date >= break_max)
    i <- match(TRUE, ge_date_max, nomatch = 0L)
    if (i > 0L) {
        return(gettextf("'%s' has value [\"%s\"] that is greater than or equal to '%s' [\"%s\"]",
                        "date",
                        date[[i]],
                        "break_max",
                        break_max))
    }
    TRUE
}


## HAS_TESTS
#' Check that an object has a complete set of names
#'
#' @inheritParams chk_array_metadata_complete
#' @param x An object, typically a vector.
#'
#' @seealso \code{\link{chk_names_dimnames_complete}},
#' \code{\link{chk_has_dimnames}},
#' \code{\link{chk_array_metadata_complete}}
#'
#' @examples
#' x <- c(a = 1, b = 1.2)
#' chk_names_complete(x = x, name = "x")#' 
#' @export
chk_names_complete <- function(x, name) {
    nms <- names(x)
    if ((length(x) > 0L) && is.null(nms))
        return(gettextf("'%s' does not have names",
                        name))
    if (anyNA(nms))
        return(gettextf("names for '%s' have NAs",
                        name))
    if (!all(nzchar(nms)))
        return(gettextf("names for '%s' have blanks",
                        name))
    is_duplicated <- duplicated(nms)
    if (any(is_duplicated)) {
        i <- match(TRUE, is_duplicated)
        return(gettextf("names for '%s' have duplicate [\"%s\"]",
                        name, nms[[i]]))
    }
    TRUE
}


## HAS_TESTS
#' Check that names for an
#' array are complete
#'
#' @inheritParams chk_array_metadata_complete
#' @param x An array.
#' 
#' @seealso \code{\link{chk_names_complete}},
#' \code{\link{chk_has_dimnames}},
#' \code{\link{chk_array_metadata_complete}}
#'
#' @examples
#' x <- array(1:6,
#'            dim = 2:3,
#'            dimnames = list(sex = c("Female", "Male"),
#'                            region = c("A", "B", "C")))
#' chk_names_dimnames_complete(x = x, name = "x")
#' @export
chk_names_dimnames_complete <- function(x, name) {
    nms <- names(dimnames(x))
    if (anyNA(nms))
        return(gettextf("names for dimnames of '%s' have NAs",
                        name))
    if (!all(nzchar(nms)))
        return(gettextf("names for dimnames of '%s' have blanks",
                        name))
    is_duplicated <- duplicated(nms)
    if (any(is_duplicated)) {
        i <- match(TRUE, is_duplicated)
        return(gettextf("names for dimnames of '%s' have duplicate [\"%s\"]",
                        name, nms[[i]]))
    }
    TRUE
}


#' Check that an initial 'pos' argument
#'
#' Check if \code{x} consists entirely of \code{1}s
#' (when \code{zero_ok} is \code{FALSE}), or of
#' \code{1}s and \code{0}s (when \code{zero_ok}
#' is \code{TRUE}).
#'
#' @inheritParams chk_array_metadata_complete
#' @param x An integer vector with positive length
#' @param zero_ok Whether \code{code} can
#' contain 0s.
#'
#' @seealso \code{\link{chk_positive_dim}}
#'
#' @examples
#' chk_pos_initial(x = c(1L, 1L, 1L),
#'                 name = "pos",
#'                 zero_ok = FALSE)
#' chk_pos_initial(x = c(1L, 0L, 1L),
#'                 name = "pos",
#'                 zero_ok = TRUE)
#' @export
chk_pos_initial <- function(x, name, zero_ok) {
    val <- chk_is_integer(x = x,
                          name = name)
    if (!isTRUE(val))
        return(val)
    val <- chk_not_na_vector(x = x,
                             name = name)
    if (!isTRUE(val))
        return(val)
    val <- chk_positive_length(x = x,
                               name = name)
    if (!isTRUE(val))
        return(val)
    if (zero_ok) {
        val <- chk_non_negative_vector(x = x,
                                       name = name)
        if (!isTRUE(val))
            return(val)
        is_not_zero_one <- !(x %in% c(0L, 1L))
        i_not_zero_one <- match(TRUE, is_not_zero_one, nomatch = 0L)
        if (i_not_zero_one > 0L)
            return(gettextf("element %d of '%s' [%d] is not equal to %d or %d",
                            i_not_zero_one, name, x[[i_not_zero_one]], 0L, 1L))
    }
    else {
        val <- chk_positive_vector(x = x,
                                   name = name)
        if (!isTRUE(val))
            return(val)
        is_not_one <- x != 1L
        i_not_one <- match(TRUE, is_not_one, nomatch = 0L)
        if (i_not_one > 0L)
            return(gettextf("element %d of '%s' [%d] is not equal to %d",
                            i_not_one, name, x[[i_not_one]], 1L))
    }
    TRUE
}


#' Check a 'dim' argument for an array with
#' positive length
#'
#' Check that \code{x} is a valid \code{dim}
#' argument for an array in which all dimensions
#' have length greater than 0.
#'
#' @inheritParams chk_array_metadata_complete
#' @param x An integer vector.
#'
#' @seealso \code{\link{chk_pos_initial}}
#'
#' @examples
#' chk_positive_dim(x = c(2L, 1L, 3L),
#'                  name = "x")
#' @export
chk_positive_dim <- function(x, name) {
    val <- chk_is_integer(x = x,
                          name = name)
    if (!isTRUE(val))
        return(val)
    val <- chk_positive_length(x = x,
                               name = name)
    if (!isTRUE(val))
        return(val)
    val <- chk_not_na_vector(x = x,
                             name = name)
    if (!isTRUE(val))
        return(val)
    val <- chk_positive_vector(x = x,
                               name = name)
    if (!isTRUE(val))
        return(val)
    TRUE
}

## HAS_TESTS
#' Check that a vector is a valid quantile
#'
#' \code{chk_valid_quantile} checks that the elements
#' of \code{x} conform to R conventions about
#' formatting quantiles. \code{chk_quantile_increasing}
#' assumes that \code{x} is correctly formatted,
#' and checks that the elements are strictly increasing.
#'
#' @inheritParams chk_array_metadata_complete
#' @param x A character vector.
#'
#' @examples
#' x <- c("2.5%", "50%", "97.5")
#' chk_valid_quantile(x, name = "x")
#' chk_quantile_increasing(x, name = "x")
#' @name chk_valid_quantile
NULL

#' @name chk_valid_quantile
#' @export
chk_valid_quantile <- function(x, name) {
    p <- "^[0-9.]+%$" # excludes negative numbers
    is_na <- is.na(x)
    is_invalid <- !is_na & !grepl(p, x)
    i_invalid <- match(TRUE, is_invalid, nomatch = 0L)
    if (i_invalid > 0L)
        return(gettextf("\"%s\" is not a valid quantile",
                        x[[i_invalid]]))
    x_num <- sub("%$", "", x)
    x_num <- suppressWarnings(as.numeric(x_num))
    is_invalid <- !is_na & is.na(x_num)
    i_invalid <- match(TRUE, is_invalid, nomatch = 0L)
    if (i_invalid > 0L)
        return(gettextf("\"%s\" is not a valid quantile",
                        x[[i_invalid]]))
    is_gt_100 <- !is_na & (x_num > 100)
    i_gt_100 <- match(TRUE, is_gt_100, nomatch = 0L)
    if (i_gt_100 > 0L)
        return(gettextf("\"%s\" is not a valid quantile : greater than %s",
                        x[[i_gt_100]], "100%"))
    TRUE
}

#' @rdname chk_valid_quantile
#' @export
chk_quantile_increasing <- function(x, name) {
    p <- "%$"
    numbers <- sub(p, "", x)
    numbers <- as.numeric(numbers)
    if (length(x) >= 2L) {
        is_not_incr <- diff(numbers) <= 0L
        i_not_incr <- match(TRUE, is_not_incr, nomatch = 0L)
        if (i_not_incr > 0L) {
            return(gettextf(paste("'%s' is not strictly increasing : element %d [%s]",
                                  "is greater than or equal to element %d [%s]"),
                            name,
                            i_not_incr,
                            x[[i_not_incr]],
                            i_not_incr + 1L,
                            x[[i_not_incr + 1L]]))
        }
    }
    TRUE
}


#' Check if 'x1' is zero, conditional on whether 'x2' is zero
#'
#' \code{chk_zero_if_zero} checks that \code{x1} is \code{0},
#' given that \code{x2} is \code{0}.
#'
#' \code{chk_zero_onlyif_zero} checks that \code{x1} is only
#' \code{0} when \code{x2} is \code{0}.
#'
#' \code{chk_zero_ifonlyif_zero} checks that \code{x1} and
#' \code{x2} are both \code{0} or are both non-\code{0}.
#' 
#' @inheritParams chk_all_x1_in_x2
#' @param x1 An argument that could be \code{0}.
#' @param x2 An argument that could be \code{0}.
#'
#' @seealso \code{\link{chk_zero}}
#'
#' @examples
#' x1 <- 0
#' x2 <- 2
#' chk_zero_if_zero(x1 = x1, x2 = x2, name1 = "x1", name2 = "x2")
#' x1 <- 0
#' x2 <- 0
#' chk_zero_if_zero(x1 = x1, x2 = x2, name1 = "x1", name2 = "x2")
#' x1 <- 1
#' x2 <- 0
#' chk_zero_onlyif_zero(x1 = x1, x2 = x2, name1 = "x1", name2 = "x2")
#' x1 <- 0
#' x2 <- 0
#' chk_zero_onlyif_zero(x1 = x1, x2 = x2, name1 = "x1", name2 = "x2")
#' x1 <- 1
#' x2 <- 2
#' chk_zero_ifonlyif_zero(x1 = x1, x2 = x2, name1 = "x1", name2 = "x2")
#' x1 <- 0
#' x2 <- 0
#' chk_zero_ifonlyif_zero(x1 = x1, x2 = x2, name1 = "x1", name2 = "x2")
#' @name chk_zero
NULL

#' @rdname chk_zero
#' @export
chk_zero_if_zero <- function(x1, x2, name1, name2) {
    if (!isTRUE(all.equal(x1, 0L)) && isTRUE(all.equal(x2, 0L)))
        return(gettextf("'%s' [%s] does not equal %d but '%s' equals %s",
                        name1, x1, 0L, name2, 0L))
    TRUE
}

#' @rdname chk_zero
#' @export
chk_zero_onlyif_zero <- function(x1, x2, name1, name2) {
    if (isTRUE(all.equal(x1, 0L)) && !isTRUE(all.equal(x2, 0L)))
        return(gettextf("'%s' equals %d but '%s' [%s] does not equal %d",
                        name1, 0L, name2, x2, 0L))
    TRUE
}

#' @rdname chk_zero
#' @export
chk_zero_ifonlyif_zero <- function(x1, x2, name1, name2) {
    val <- chk_zero_if_zero(x1 = x1,
                            x2 = x2,
                            name1 = name1,
                            name2 = name2)
    if (!isTRUE(val))
        return(val)
    val <- chk_zero_onlyif_zero(x1 = x1,
                                x2 = x2,
                                name1 = name1,
                                name2 = name2)
    if (!isTRUE(val))
        return(val)
    TRUE
}