R/validate.R

In hongyuanjia/eplusr: A Toolkit for Using Whole Building Simulation Program 'EnergyPlus'

#' @importFrom cli cat_bullet cat_line cat_rule symbol
#' @importFrom data.table copy data.table setattr
#' @include idd.R
#' @include idf.R
NULL

# empty_validity {{{
# An empty IDF Validity report
empty_validity <- function() {
    validity <- vector("list", 13L)

    chks <- c("missing_object", "duplicate_object", "conflict_name",
        "incomplete_extensible", "missing_value", "invalid_autosize",
        "invalid_autocalculate", "invalid_character", "invalid_numeric",
        "invalid_integer", "invalid_choice", "invalid_range",
        "invalid_reference"
    )

    setattr(validity, "names", chks)

    validity$missing_object <- character()

    empty_check <- data.table(
        object_id = integer(0),
        object_name = character(0),
        class_id = integer(0),
        class_name = character(0),
        field_id = integer(0),
        field_index = integer(0),
        field_name = character(0),
        units = character(0),
        ip_units = character(0),
        type_enum = integer(0),
        value_id = character(0),
        value_chr = character(0),
        value_num = character(0)
    )

    for (chk in setdiff(chks, "missing_object")) {
        validity[[chk]] <- empty_check
    }

    setattr(validity, "class", c("IdfValidity", "list"))

    validity
}
# }}}
# add_validity {{{
# Add a single check result into IdfValidity
# @param env_in An environment that contains IdfValidity in `validity` element
#               and input value data in `value` element.
# @param check A data.table that contains objects invalid value data that can
#        be used to extract full info from IDF value table.
# @param type A valid IdfValidity type name.
# @param on Passed to `[.data.table` in order to extract value data.
# @return NULL
add_validity <- function(idd_env, idf_env, env_in, check, type, on) {
    env_in[["validity"]][[type]] <- env_in$object[, .SD, .SDcols = c("object_id", "object_name")][
        env_in$value, on = "object_id"][check, on = on][,
        .SD, .SDcols = names(env_in[["validity"]][[type]])]
    env_in[["validity"]][[type]]
}
# }}}
# exclude_invalid {{{
# Exclude invalid value data from input
# @param env_in An environment that contains input value data in `value` element.
# @param invalid A data.table that contains objects invalid value data that can
#        be used to extract full info from IDF value table.
# @param on Passed to `[.data.table` in order to exclude invalid value data.
# @return NULL
exclude_invalid <- function(env_in, invalid, on) {
    env_in[["value"]] <- env_in[["value"]][!invalid, on = on]
}
# }}}

#' Customize validation components
#'
#' `custom_validate()` makes it easy to customize what validation components
#' should be included during IDF object modifications using `$dup()`, `$add()`,
#' `$set()` and other methods in [Idf] class.
#'
#' There are 10 different validation check components in total. Three predefined
#' validation level are included, i.e. `"none"`, `"draft"` and `"final"`. To get
#' what validation components those levels contain, see [level_checks()].
#'
#' @param required_object Check if required objects are missing in current
#' model. Default: `FALSE`.
#' @param unique_object Check if there are multiple objects in one unique-object
#' class. Default: `FALSE`.
#' @param unique_name Check if all objects in every class have unique names.
#' Default: `FALSE`.
#' @param extensible Check if all fields in an extensible group have values.
#' Default: `FALSE`.
#' @param required_field Check if all required fields have values. Default:
#' `FALSE`.
#' @param auto_field Check if all fields with value `"Autosize"` and
#' `"Autocalculate"` are valid or not. Default: `FALSE`.
#' @param type Check if all fields have values with valid types, i.e. 
#' character, numeric and integer fields should be filled with corresponding
#' type of values. Default: `FALSE`.
#' @param choice Check if all choice fields have valid choice values. Default:
#' `FALSE`.
#' @param range Check if all numeric fields have values within defined ranges.
#' Default: `FALSE`.
#' @param reference Check if all fields whose values refer to other fields are
#' valid. Default: `FALSE`.
#'
#' @return A named list with 10 elements.
#' @export
#' @examples
#' custom_validate(unique_object = TRUE)
#'
#' # only check unique name during validation
#' eplusr_option(validate_level = custom_validate(unique_name = TRUE))
#' @importFrom checkmate assert_flag
# custom_validate {{{
custom_validate <- function(
    required_object = FALSE, unique_object = FALSE, unique_name = FALSE,
    extensible = FALSE, required_field = FALSE, auto_field = FALSE,
    type = FALSE, choice = FALSE, range = FALSE, reference = FALSE
)
{
    assert_flag(required_object)
    assert_flag(unique_object)
    assert_flag(unique_name)
    assert_flag(extensible)
    assert_flag(required_field)
    assert_flag(auto_field)
    assert_flag(type)
    assert_flag(choice)
    assert_flag(range)
    assert_flag(reference)

    list(
        required_object = required_object,
        unique_object = unique_object,
        unique_name = unique_name,
        extensible = extensible,
        required_field = required_field,
        auto_field = auto_field,
        type = type,
        choice = choice,
        range = range,
        reference = reference
    )
}
# }}}

#' Show components of validation strictness level
#'
#' `level_checks()` takes input of a built in validation level or a custom
#' validation level and returns a list with all validation components that level
#' contains.
#'
#' @param level Should be one of `"none"`, `"draft"`, `"final"` or an output of
#' [custom_validate()].
#' @return A named list with 10 elements, e.g. `required_object`,
#' `unique_object`, `unique_name`, `extensible`, `required_field`, `auto_field`,
#' `type`, `choice`, `range` and `reference`. For the meaning of each validation
#' component, see[custom_validate()].
#' @export
#' @examples
#' level_checks("draft")
#' level_checks("final")
#' level_checks(custom_validate(auto_field = TRUE))
#' level_checks(eplusr_option("validate_level"))
#' @export
#' @importFrom checkmate test_string assert_choice test_list
# level_checks {{{
level_checks <- function(level = eplusr_option("validate_level")) {
    if (test_string(level)) {
        level <- assert_choice(level, c("none", "draft", "final"))
        if (level == "none") {
            custom_validate()
        } else if (level == "draft") {
            custom_validate(
                auto_field = TRUE, type = TRUE, unique_name = TRUE, choice = TRUE,
                range = TRUE
            )
        } else if (level == "final"){
            custom_validate(
                required_object = TRUE, unique_object = TRUE, unique_name = TRUE,
                extensible = TRUE, required_field = TRUE, auto_field = TRUE,
                type = TRUE, choice = TRUE, range = TRUE, reference = TRUE
            )
        }
    } else if (test_list(level)) {
        assert_names(names(level), permutation.of = names(custom_validate()))
        custom_validate(
            required_object = level$required_object,
            unique_object = level$unique_object,
            unique_name = level$unique_name,
            extensible = level$extensible,
            required_field = level$required_field,
            auto_field = level$auto_field,
            type = level$type,
            choice = level$choice,
            range = level$range,
            reference = level$reference
        )
    } else {
        abort("'level' must be a string or a list")
    }
}
# }}}
# validate_on_level {{{
# Validate input IDF data on different level
# @param idd_env An environment that contains IDD data
# @param idf_env An environment that contains IDF data
# @param dt_object A data.table that contains object data to validate
# @param dt_value A data.table that contains value data to validate
# @param level Strictness level to validate. Should be one of `"none"`,
#        `"draft"` and `"final"`.
# @return An IdfValidity object.
validate_on_level <- function(idd_env, idf_env, dt_object = NULL, dt_value = NULL, level) {

    level <- level_checks(level)

    validate_objects(idd_env, idf_env, dt_object, dt_value,
        required_object = level$required_object,
        unique_object = level$unique_object,
        unique_name = level$unique_name,
        extensible = level$extensible,
        required_field = level$required_field,
        auto_field = level$auto_field,
        type = level$type,
        choice = level$choice,
        range = level$range,
        reference = level$reference
    )
}
# }}}
# validate_objects {{{
#' Validate input IDF data in terms of various aspects
#' @param idd_env An environment that contains IDD data
#' @param idf_env An environment that contains IDF data
#' @param dt_object A data.table that contains object data to validate. If
#'        `NULL`, the object data from `idf_env` will be used, which means to
#'        validate the whole IDF.
#' @param dt_value A data.table that contains value data to validate. If
#'        `NULL`, the value data from `idf_env` will be used, which means to
#'        validate the whole IDF.
#' @param required_object Whether to check if required objects are missing. This
#'        will only be applied when checking the whole IDF.
#' @param unique_object Whether to check if there are multiple instances of
#'        unique object.
#' @param unique_name Whether to check if there are objects having the same name
#'        in same class.
#' @param extensible Whether to check if there are incomplete extensible.
#' @param required_field Whether to check if there are missing value for
#'        required fields.
#' @param auto_field Whether to check if there are non-autosizable or
#'        non-autocalculatable fields that are assigned "autosize" or
#'        "autocalculate".
#' @param type Whether to check if there are input values whose type are not
#'        consistent with definitions in IDD.
#' @param choice Whether to check if there are invalid choice values.
#' @param range Whether to check if there are numeric values that are out of
#'        ranges specified in IDD.
#' @param reference Whether to check if there are values that have invalid
#'        references.
#' @return An IdfValidity object.
#' @keywords internal
#' @export
validate_objects <- function
(
    idd_env, idf_env, dt_object = NULL, dt_value = NULL,
    required_object = FALSE, unique_object = FALSE, unique_name = FALSE,
    extensible = FALSE, required_field = FALSE, auto_field = FALSE,
    type = FALSE, choice = FALSE, range = FALSE, reference = FALSE
)
{

    # if object and value dt are not provided, then this means to validate the
    # whole IDF
    if (is.null(dt_object) && is.null(dt_value)) {
        dt_object <- idf_env$object
        # add class name
        dt_object <- add_class_name(idd_env, dt_object)
        on.exit(set(dt_object, NULL, "class_name", NULL), add = TRUE)

        dt_value <- idf_env$value
        # add class id and name
        add_joined_cols(dt_object, dt_value, "object_id", c("class_id", "class_name", "object_name"))
        # add field index
        add_joined_cols(idd_env$field, dt_value, "field_id", c("field_index", "field_name", "type_enum", "ip_units", "units"))
        on.exit(
            set(dt_value, NULL,
                c("class_id", "class_name", "object_name", "field_name",
                  "field_index", "type_enum", "units", "ip_units"),
            NULL),
            add = TRUE
        )

        check_whole <- TRUE
    } else {
        check_whole <- FALSE
    }

    # add field attributes used for validating {{{
    # add field index
    cols_add <- c("type_enum", "ip_units", "units")
    if (isTRUE(extensible)) cols_add <- c(cols_add, "extensible_group")
    if (isTRUE(required_field)) cols_add <- c(cols_add, "required_field")
    if (isTRUE(auto_field)) cols_add <- c(cols_add, "autosizable", "autocalculatable")
    if (isTRUE(choice)) cols_add <- c(cols_add, "choice")
    if (isTRUE(range)) cols_add <- c(cols_add, "has_range", "maximum", "minimum", "lower_incbounds", "upper_incbounds")
    # to exclude empty fields
    if (isTRUE(auto_field) || isTRUE(type) || isTRUE(choice) || isTRUE(range) || isTRUE(reference)) {
        cols_add <- c(cols_add, "required_field")
    }
    # to exclude auto fields
    if (isTRUE(type) || isTRUE(choice) || isTRUE(range) || isTRUE(reference)) {
        cols_add <- c(cols_add, "autosizable", "autocalculatable", "type_enum")
    }
    # to check reference
    if (isTRUE(reference)) cols_add <- c(cols_add, "src_enum")

    cols_add <- setdiff(cols_add, names(dt_value))
    if (length(cols_add)) {
        dt_value <- add_field_property(idd_env, dt_value, cols_add)
        on.exit(set(dt_value, NULL, cols_add, NULL), add = TRUE)
    }
    # }}}

    # add lower-case value
    set(dt_value, NULL, "value_lower", stri_trans_tolower(dt_value$value_chr))
    on.exit(set(dt_value, NULL, "value_lower", NULL), add = TRUE)

    # put all input into an environment
    env_in <- new.env(parent = emptyenv(), size = 4L)
    env_in$check_whole <- check_whole
    env_in$object <- dt_object
    env_in$value <- dt_value
    env_in$validity <- empty_validity()

    if (isTRUE(required_object) && check_whole) check_missing_object(idd_env, idf_env, env_in)
    if (isTRUE(unique_object)) check_duplicate_object(idd_env, idf_env, env_in)
    if (isTRUE(unique_name)) check_conflict_name(idd_env, idf_env, env_in)
    if (isTRUE(extensible)) check_incomplete_extensible(idd_env, idf_env, env_in)
    if (isTRUE(required_field)) check_missing_value(idd_env, idf_env, env_in)

    # exclude unrequired empty fields
    if (isTRUE(auto_field) || isTRUE(type) || isTRUE(choice) || isTRUE(range) || isTRUE(reference)) {
        exclude_empty_field(idd_env, idf_env, env_in)
    }

    if (isTRUE(auto_field)) {
        check_invalid_autosize(idd_env, idf_env, env_in)
        check_invalid_autocalculate(idd_env, idf_env, env_in)
    }

    # exclude autosize and autocalculate fields when checking types, ranges and
    # references
    if (isTRUE(type) || isTRUE(choice) || isTRUE(range) || isTRUE(reference)) {
        exclude_auto_field(idd_env, idf_env, env_in)
    }

    if (isTRUE(type)) {
        check_invalid_character(idd_env, idf_env, env_in)
        check_invalid_numeric(idd_env, idf_env, env_in)
        check_invalid_integer(idd_env, idf_env, env_in)
    }

    if (isTRUE(choice)) check_invalid_choice(idd_env, idf_env, env_in)
    if (isTRUE(range)) check_invalid_range(idd_env, idf_env, env_in)
    if (isTRUE(reference)) check_invalid_reference(idd_env, idf_env, env_in)

    env_in$validity
}
# }}}

# check_missing_object: check missing required objects {{{
check_missing_object <- function(idd_env, idf_env, env_in) {
    required <- idd_env$class[required_object == TRUE, class_id]
    miss <- required[!required %in% unique(env_in$object$class_id)]
    env_in$validity$missing_object <- idd_env$class[J(miss), on = "class_id", class_name]
    env_in
}
# }}}
# check_duplicate_object: check duplicated unique objects {{{
check_duplicate_object <- function(idd_env, idf_env, env_in) {
    dup_uni <- env_in$object[J(idd_env$class[unique_object == TRUE, class_id]),
        on = "class_id", nomatch = 0L, list(num = .N), by = c("class_id")][num > 1L]

    if (nrow(dup_uni)) {
        add_validity(idd_env, idf_env, env_in, dup_uni, "duplicate_object", "class_id")
    }

    env_in
}
# }}}
# check_conflict_name: objects in the same class have exact the same name {{{
check_conflict_name <- function(idd_env, idf_env, env_in) {
    # only check objects that have names
    if (env_in$check_whole) {
        obj <- env_in$object[!is.na(object_name)]
    } else {
        exist <- idf_env$object[J(unique(env_in$object$class_id)), on = "class_id", nomatch = 0L]
        # add existing object
        obj <- append_dt(exist, env_in$object, "object_id")[!is.na(object_name)]
    }

    if (!nrow(obj)) return(env_in)

    conf_id <- obj[, list(num = .N, id_list = list(object_id)),
        by = c("class_id", "object_name_lower")][num > 1L, unlist(id_list, use.names = FALSE)]

    if (is.null(conf_id)) return(env_in)

    # get object name in order to correctly print error messages
    obj <- obj[J(conf_id), on = "object_id", .SD, .SDcols = c("object_id", "object_name")]

    if (env_in$check_whole) {
        env_in$validity$conflict_name <- env_in$value[J(obj$object_id), on = "object_id",
            nomatch = 0L,  .SD, .SDcols = names(env_in$validity$conflict_name)][
            field_index <= 3L]
    } else {
        # conflicted objects in orginal IDF
        old <- idf_env$value[J(obj$object_id), on = "object_id", nomatch = 0L]

        # add necessary columns
        # add class id and name
        add_joined_cols(idf_env$object, old, "object_id", c("class_id", "object_name"))
        # add class name
        add_joined_cols(idd_env$class, old, "class_id", c("class_name"))
        # add field index
        add_joined_cols(idd_env$field, old, "field_id", c("field_index", "field_name", "type_enum", "ip_units", "units"))

        old <- old[field_index <= 3L]

        new <- env_in$value[field_index <= 3L][J(obj$object_id), on = "object_id", nomatch = 0L]
        add_joined_cols(env_in$object, new, "object_id", "object_name")

        env_in$validity$conflict_name <- rbindlist(list(
            new[, .SD, .SDcols = names(env_in$validity$conflict_name)],
            old[, .SD, .SDcols = names(env_in$validity$conflict_name)]
        ))
    }

    env_in
}
# }}}
# check_incomplete_extensible: incomplete extensible group {{{
check_incomplete_extensible <- function(idd_env, idf_env, env_in) {
    # extensible groups in input
    ext <- env_in$value[extensible_group > 0L,
        list(object_id, field_index, field_id, extensible_group, value_chr)]

    if (!nrow(ext)) return(env_in)

    # check incomplete extensible fields
    # check if fields in an extensible group have any NA or are all NAs
    empty_info <- ext[order(object_id, -extensible_group, -field_index),
        list(has_any_na = any(is.na(value_chr)), is_all_na = all(is.na(value_chr))),
        by = list(object_id, extensible_group)]
    # if fields in one extensible group only have some NAs or do not have any
    # NA, then extensible groups below that group cannot have any NA
    empty_info[empty_info[is_all_na == FALSE, .I[1L], by = list(object_id)]$V1, can_be_na := is_all_na]
    empty_info[can_be_na == FALSE | is.na(can_be_na), can_be_na := can_be_na[1L],
        by = list(cumsum(!is.na(can_be_na)), object_id)]
    empty_info[is.na(can_be_na), can_be_na := TRUE]
    incomplete <- empty_info[has_any_na == TRUE & can_be_na == FALSE, list(object_id, extensible_group)]
    setorderv(incomplete, names(incomplete))

    if (nrow(incomplete)) {
        add_validity(idd_env, idf_env, env_in, incomplete, "incomplete_extensible", c("object_id", "extensible_group"))
    }

    env_in
}
# }}}
# check_missing_value: missing required fields {{{
check_missing_value <- function(idd_env, idf_env, env_in) {
    missing_value <- env_in$value[required_field == TRUE & is.na(value_chr)]

    if (!nrow(missing_value)) return(env_in)

    add_validity(idd_env, idf_env, env_in, missing_value, "missing_value", "value_id")
    exclude_invalid(env_in, missing_value, on = "value_id")
    env_in
}
# }}}
# check_invalid_autosize: invalid autosize fields {{{
check_invalid_autosize <- function(idd_env, idf_env, env_in) {
    invalid_autosize <- env_in$value[value_lower == "autosize" & autosizable == FALSE]

    if (!nrow(invalid_autosize)) return(env_in)

    add_validity(idd_env, idf_env, env_in, invalid_autosize, "invalid_autosize", "value_id")
    exclude_invalid(env_in, invalid_autosize, "value_id")
    env_in
}
# }}}
# check_invalid_autocalculate: invalid autocalculate fields {{{
check_invalid_autocalculate <- function(idd_env, idf_env, env_in) {
    invalid_autocalculate <- env_in$value[value_lower == "autocalculate" & autocalculatable == FALSE]

    if (!nrow(invalid_autocalculate)) return(env_in)

    add_validity(idd_env, idf_env, env_in, invalid_autocalculate, "invalid_autocalculate", "value_id")
    exclude_invalid(env_in, invalid_autocalculate, "value_id")
    env_in
}
# }}}
# check_invalid_character: invalid numeric fields {{{
check_invalid_character <- function(idd_env, idf_env, env_in) {
    invalid_character <- env_in$value[type_enum > IDDFIELD_TYPE$real & !is.na(value_num)]

    if (!nrow(invalid_character)) return(env_in)

    add_validity(idd_env, idf_env, env_in, invalid_character, "invalid_character", "value_id")
    exclude_invalid(env_in, invalid_character, "value_id")
    env_in
}
# }}}
# check_invalid_numeric: invalid numeric fields {{{
check_invalid_numeric <- function(idd_env, idf_env, env_in) {
    invalid_numeric <- env_in$value[type_enum <= IDDFIELD_TYPE$real & is.na(value_num)]

    if (!nrow(invalid_numeric)) return(env_in)

    add_validity(idd_env, idf_env, env_in, invalid_numeric, "invalid_numeric", "value_id")
    exclude_invalid(env_in, invalid_numeric, "value_id")
    env_in
}
# }}}
# check_invalid_integer: invalid integer fields {{{
check_invalid_integer <- function(idd_env, idf_env, env_in) {
    invalid_integer <- env_in$value[type_enum == IDDFIELD_TYPE$integer & (is.na(value_num) | value_num != trunc(value_num))]

    if (!nrow(invalid_integer)) return(env_in)

    add_validity(idd_env, idf_env, env_in, invalid_integer, "invalid_integer", "value_id")
    exclude_invalid(env_in, invalid_integer, "value_id")
    env_in
}
# }}}
# check_invalid_choice: invalid choice fields {{{
check_invalid_choice <- function(idd_env, idf_env, env_in) {
    cho <- env_in$value[type_enum == IDDFIELD_TYPE$choice]

    if (!nrow(cho)) return(env_in)

    # have to handle class "Schedule:Week:Compact" seperately
    cho[class_name == "Schedule:Week:Compact",
        `:=`(value_lower = gsub("^for\\s*[:]{0,1}\\s*", "", value_lower))]

    set(cho, NULL, "choice", list(lapply(cho$choice, stri_trans_tolower)))
    invalid_choice <- cho[!apply2_lgl(value_lower, choice, "%chin%")]

    if (!nrow(invalid_choice)) return(env_in)

    add_validity(idd_env, idf_env, env_in, invalid_choice, "invalid_choice", "value_id")
    exclude_invalid(env_in, invalid_choice, "value_id")
    env_in
}
# }}}
# check_invalid_range: invalid range fields {{{
check_invalid_range <- function(idd_env, idf_env, env_in) {
    val <- env_in$value[type_enum <= IDDFIELD_TYPE$real & has_range == TRUE]

    if (!nrow(val)) return(env_in)

    invalid_range <- val[
        lower_incbounds == TRUE,  check_lower := value_num >= minimum][
        lower_incbounds == FALSE, check_lower := value_num > minimum][
        upper_incbounds == TRUE,  check_upper := value_num <= maximum][
        upper_incbounds == FALSE, check_upper := value_num < maximum][
        check_lower == FALSE | check_upper == FALSE]

    if (!nrow(invalid_range)) return(env_in)

    add_validity(idd_env, idf_env, env_in, invalid_range, "invalid_range", "value_id")
    exclude_invalid(env_in, invalid_range, "value_id")
    env_in
}
# }}}
# check_invalid_reference: invalid reference fields {{{
check_invalid_reference <- function(idd_env, idf_env, env_in) {
    val <- env_in$value[J(IDDFIELD_TYPE$object_list), on = "type_enum", nomatch = 0L,
        list(object_id, value_id, value_chr, field_id, type_enum)]

    if (!nrow(val)) return(env_in)

    if (env_in$check_whole) {
        ref_map <- idf_env$reference[J(val$value_id), on = "value_id"]
    } else {
        # add necessary columns used for getting references
        add_field_property(idd_env, idf_env$value, "src_enum")
        add_joined_cols(idf_env$object, idf_env$value, "object_id", "class_id")
        add_class_name(idd_env, idf_env$value)

        ref_map <- get_value_reference_map(idd_env,
            src = append_dt(idf_env$value, env_in$value, "value_id"), value = val)

        set(idf_env$value, NULL, c("src_enum", "class_id", "class_name"), NULL)
    }

    invalid_ref <- ref_map[val, on = "value_id"][J(NA_integer_), on = "src_value_id", nomatch = 0L]

    if (!nrow(invalid_ref)) {
        # if check new objects, update reference map
        if (!env_in$check_whole) {
            idf_env$reference <- append_dt(idf_env$reference, ref_map, "value_id")
        }
        return(env_in)
    }

    # use input object ID instead of IDs the reference map
    set(invalid_ref, NULL, "object_id", NULL)
    setnames(invalid_ref, "i.object_id", "object_id")

    add_validity(idd_env, idf_env, env_in, invalid_ref, "invalid_reference", "value_id")
    exclude_invalid(env_in, invalid_ref, "value_id")
    env_in
}
# }}}

# exclude_empty_field: exclude non-required empty fields {{{
exclude_empty_field <- function(idd_env, idf_env, env_in) {
    env_in$value <- env_in$value[!is.na(value_chr)]
    env_in
}
# }}}
# exclude_auto_field: exclude valid autosize and autocalculate fields {{{
exclude_auto_field <- function(idd_env, idf_env, env_in) {
    env_in$value <- env_in$value[
        !(value_lower == "autosize" & autosizable == TRUE) &
        !(value_lower == "autocalculate" & autocalculatable == TRUE)
    ]
    env_in
}
# }}}

# count_check_type_error {{{
# Count total error in a single validity type
count_check_type_error <- function(validity, type) {
    if (identical(type, "missing_object"))
        return(length(validity[[type]]))

    if (identical(type, "duplicate_object") || identical(type, "conflict_name"))
        return(length(unique(validity[[type]]$object_id)))

    if (identical(type, "incomplete_extensible"))
        return(validity[[type]][is.na(value_chr), .N])

    nrow(validity[[type]])
}
# }}}
# count_check_error {{{
# Count total error in validity
count_check_error <- function(validity) {
    sum(vapply(names(validity), count_check_type_error, integer(1L), validity = validity, USE.NAMES = FALSE))

}
# }}}
# format_validity: print all validity results {{{
format_validity <- function(validity, epw = FALSE) {
    error_num_per <- vapply(names(validity), count_check_type_error,
        integer(1L), validity = validity)

    error_num <- sum(error_num_per)
    error_type <- names(which(error_num_per > 0L))

    if (error_num == 0L) {
        return(paste0(" ", cli::symbol$tick, " ", "No error found."))
    }

    header <- c(
        paste0(" ", cli::symbol$cross, " [", error_num, "] ",
            "Errors found during validation."),
        cli::rule(line = 2, width = cli::console_width() - 2L)
    )

    detail <- mapply(format_single_validity, type = error_type,
        MoreArgs = list(single_validity = validity[error_type], epw = epw),
        SIMPLIFY = FALSE, USE.NAMES = FALSE
    )

    c(header, unlist(detail, FALSE, FALSE))
}
# }}}
# format_single_validity: print a single validity result {{{
format_single_validity <- function(single_validity, type, epw = FALSE) {
    error_num <- count_check_type_error(single_validity, type)

    obj <- if (epw) "Header" else "Object"

    title <- switch(type,
        missing_object = paste("Missing Required", obj),
        duplicate_object = paste("Duplicated Unique", obj),
        conflict_name = paste("Conflicted", obj, "Names"),
        incomplete_extensible = "Incomplete Extensible Group",
        missing_value = "Missing Required Field",
        invalid_autosize = "Invalid Autosize Field",
        invalid_autocalculate = "Invalid Autocalculate Field",
        invalid_numeric = "Invalid Number",
        invalid_character = "Invalid Character",
        invalid_integer = "Invalid Integer",
        invalid_choice = "Invalid Choice",
        invalid_range = "Range Exceeding",
        invalid_reference = "Invalid Reference",
        stringi::stri_trans_totitle(stri_replace_all_fixed(type, "_", " "))
    )

    bullet <- switch(type,
        missing_object = paste(obj, "below are required but not exist:"),
        duplicate_object = paste(obj, "should be unique but have multiple instances:"),
        conflict_name = paste(obj, "below have the same name:"),
        incomplete_extensible = "Fields in each extensible group cannot contain any empty:",
        missing_value = "Fields below are required but values are not given:",
        invalid_autosize = "Fields below cannot be `autosize`:",
        invalid_autocalculate = "Fields below cannot be `autocalculate`:",
        invalid_numeric = "Fields below should be numbers but are not:",
        invalid_character = "Fields below should be characters but are not:",
        invalid_integer = "Fields below are not or cannot be coerced into integers:",
        invalid_choice = "Fields below are not one of prescribed choices:",
        invalid_range = "Fields below exceed prescribed ranges:",
        invalid_reference = "Fields below are not one of valid references:",
        "Fields below are not valid:"
    )

    if (!is.null(attr(single_validity[[type]], "bullet"))) {
        bullet <- attr(single_validity[[type]], "bullet")
    }

    out <- c("",
        cli::rule(paste0("[", error_num, "] ", title), width = cli::console_width() - 2L),
        paste0("   ", bullet),
        ""
    )

    if (type == "missing_object") {
        return(c(out, paste0("   * ", surround(single_validity[[type]]))))
    }

    fmt <- unlist(
        format_objects(single_validity[[type]],
            c("class", "object", "value"), brief = FALSE)$out,
        use.names = FALSE
    )

    # change class to header
    if (epw) fmt <- stri_replace_all_fixed(fmt, "Class: <", "Header: <")

    c(out, paste0("    ", fmt))
}
# }}}

#' @export
# print.IdfValidity {{{
print.IdfValidity <- function(x, ...) {
    cli::cat_line(format_validity(x))
    invisible(x)
}
# }}}
#' @export
# print.EpwValidity {{{
print.EpwValidity <- function(x, ...) {
    cli::cat_line(format_validity(x, epw = TRUE))
    invisible(x)
}
# }}}

# vim: set fdm=marker: