From f482de39c7e24b895161c260de815a126b5eb944 Mon Sep 17 00:00:00 2001 From: Hongyuan Jia Date: Thu, 9 Apr 2020 23:49:53 +0800 Subject: [PATCH 01/43] [refactor] Clean 'assign_defaultLvalue()' interface --- R/idd_object.R | 2 +- R/idf_object.R | 4 +--- R/impl-idd.R | 20 +++++++++++++++++--- R/impl-iddobj.R | 2 +- R/impl-idf.R | 22 ++++++++-------------- R/impl-idfobj.R | 2 +- R/parse.R | 12 ++++++++++-- R/transition.R | 2 +- 8 files changed, 40 insertions(+), 26 deletions(-) diff --git a/R/idd_object.R b/R/idd_object.R index a71207331..0582564d4 100644 --- a/R/idd_object.R +++ b/R/idd_object.R @@ -1599,7 +1599,7 @@ iddobj_field_default <- function (self, private, which = NULL, in_ip = eplusr_op c("default_chr", "default_num", "units", "ip_units", "type_enum") ) - if (in_ip) fld <- field_default_to_unit(fld, "si", "ip") + if (in_ip) fld <- field_default_to_unit(private$idd_env(), fld, "si", "ip") setnames(fld, c("default_chr", "default_num"), c("value_chr", "value_num")) get_value_list(fld) diff --git a/R/idf_object.R b/R/idf_object.R index e237b491f..9c67a92a1 100644 --- a/R/idf_object.R +++ b/R/idf_object.R @@ -1505,7 +1505,7 @@ idf_object <- function (parent, object = NULL, class = NULL) { ) # assign default values - val <- assign_default_value(val) + val <- assign_default_value(idd_env, idf_env, val) # validate assert_valid(idd_env, idf_env, obj, val, action = "add") @@ -1795,8 +1795,6 @@ idfobj_ref_to_node <- function (self, private, which = NULL, object = NULL, clas return(invisible()) } else { rel <- rel[, list(object_id = unique(object_id)), by = "src_object_id"] - verbose_info("Target object has node(s) referring to ", nrow(rel), " object(s) [ID:", - collapse(rel$object_id), "].\n") res <- apply2( rel$object_id, private$idf_env()$object[J(rel$object_id), on = "object_id", class_id], diff --git a/R/impl-idd.R b/R/impl-idd.R index d5ac5ee83..35ab7972e 100644 --- a/R/impl-idd.R +++ b/R/impl-idd.R @@ -745,13 +745,27 @@ add_field_property <- function (idd_env, dt, property) { # }}} # field_default_to_unit {{{ -field_default_to_unit <- function (dt_field, from, to) { +field_default_to_unit <- function (idd_env, dt_field, from, to) { + if (has_name(dt_field, "value_id")) { + value_id <- dt_field$value_id + } else { + value_id <- NULL + } set(dt_field, NULL, "value_id", seq_along(dt_field$field_id)) + + if (!has_name(dt_field, "default_chr")) { + add_field_property(idd_env, dt_field, "default_chr") + } + + if (!has_name(dt_field, "default_num")) { + add_field_property(idd_env, dt_field, "default_num") + } + setnames(dt_field, c("default_chr", "default_num"), c("value_chr", "value_num")) - dt_field <- convert_value_unit(dt_field, from, to) + dt_field <- convert_value_unit(idd_env, dt_field, from, to) - set(dt_field, NULL, "value_id", NULL) + set(dt_field, NULL, "value_id", value_id) setnames(dt_field, c("value_chr", "value_num"), c("default_chr", "default_num")) dt_field } diff --git a/R/impl-iddobj.R b/R/impl-iddobj.R index 27f427432..752ede1f1 100644 --- a/R/impl-iddobj.R +++ b/R/impl-iddobj.R @@ -54,7 +54,7 @@ get_iddobj_possible <- function (idd_env, class_id, field_id = NULL) { fld[J(TRUE), on = "autocalculatable", `:=`(auto = "Autocalculate")] # default - fld <- field_default_to_unit(fld, "si", if (in_ip_mode()) "ip" else "si") + fld <- field_default_to_unit(idd_env, fld, "si", if (in_ip_mode()) "ip" else "si") setnames(fld, c("default_chr", "default_num"), c("value_chr", "value_num")) # make sure default is a list if (nrow(fld) == 1L) { diff --git a/R/impl-idf.R b/R/impl-idf.R index 354753c0c..6b91f90eb 100644 --- a/R/impl-idf.R +++ b/R/impl-idf.R @@ -1297,12 +1297,6 @@ get_idf_value <- function (idd_env, idf_env, class = NULL, object = NULL, field } # }}} -# get_idf_value_all_node {{{ -get_idf_value_all_node <- function (idf_env) { - idf_env$value[type_enum == IDDFIELD_TYPE$node & !is.na(value_chr), unique(value_chr)] -} -# }}} - # ASSERT # FOR BACK COMPATIBILITY # SHOULD BE REMOVED IN NEXT RELEASE @@ -1748,7 +1742,7 @@ add_idf_object <- function (idd_env, idf_env, ..., .default = TRUE, .all = FALSE setorderv(val, c("rleid", "field_index")) # assign default values if needed - if (.default) val <- assign_default_value(val) + if (.default) val <- assign_default_value(idd_env, idf_env, val) set(val, NULL, c("default_chr", "default_num"), NULL) # assign new value id @@ -1826,7 +1820,7 @@ set_idf_object <- function (idd_env, idf_env, ..., .default = TRUE, .empty = FAL # assign default values if needed if (.default) { - val <- assign_default_value(val) + val <- assign_default_value(idd_env, idf_env, val) } else { # remove val[defaulted == TRUE, `:=`(value_chr = NA_character_, value_num = NA_real_)] @@ -2436,7 +2430,7 @@ insert_idf_object <- function (idd_env, idf_env, version, ..., .unique = TRUE, . # set newly added fields to default value if possible set(val, NULL, "defaulted", FALSE) val[value_id < 0L, defaulted := TRUE] - val <- assign_default_value(val) + val <- assign_default_value(idd_env, idf_env, val) # update object id obj <- assign_new_id(idf_env, obj, "object") @@ -2525,7 +2519,7 @@ paste_idf_object <- function (idd_env, idf_env, version, in_ip = FALSE, unique = if (default) { parsed$value[is.na(value_chr), defaulted := TRUE] add_field_property(idd_env, parsed$value, c("default_chr", "default_num", "units", "ip_units")) - parsed$value <- assign_default_value(parsed$value) + parsed$value <- assign_default_value(idd_env, idf_env, parsed$value) } # validate @@ -2675,7 +2669,7 @@ load_idf_object <- function (idd_env, idf_env, version, ..., .unique = TRUE, .de obj <- update_object_name(obj, val) # assign default - if (.default) val <- assign_default_value(val) + if (.default) val <- assign_default_value(idd_env, idf_env, val) # remove duplicated objects if (.unique) { @@ -2927,7 +2921,7 @@ update_idf_object <- function (idd_env, idf_env, version, ..., .default = TRUE, # assign default values if needed if (.default) { - val <- assign_default_value(val) + val <- assign_default_value(idd_env, idf_env, val) set(val, NULL, c("default_chr", "default_num"), NULL) } else { # remove @@ -4096,9 +4090,9 @@ correct_obj_id <- function (dt_object, dt_value) { } # }}} # assign_default_value {{{ -assign_default_value <- function (dt_value) { +assign_default_value <- function (idd_env, idf_env, dt_value) { if (in_ip_mode()) { - dt_value <- field_default_to_unit(dt_value, "si", "ip") + dt_value <- field_default_to_unit(idd_env, dt_value, "si", "ip") } dt_value[defaulted == TRUE, `:=`(value_chr = default_chr, value_num = default_num)] dt_value diff --git a/R/impl-idfobj.R b/R/impl-idfobj.R index 427ce40bb..92277d96a 100644 --- a/R/impl-idfobj.R +++ b/R/impl-idfobj.R @@ -177,7 +177,7 @@ get_idfobj_possible <- function (idd_env, idf_env, object, field, setnames(val, c("value_id", "value_chr", "value_num"), c("ori_value_id", "ori_value_chr", "ori_value_num")) - val <- field_default_to_unit(val, "si", if (in_ip_mode()) "ip" else "si") + val <- field_default_to_unit(idd_env, val, "si", if (in_ip_mode()) "ip" else "si") setnames(val, c("default_chr", "default_num"), c("value_chr", "value_num")) # make sure default is a list if (nrow(val) == 1L) { diff --git a/R/parse.R b/R/parse.R index c0e7bbe72..070871a5a 100644 --- a/R/parse.R +++ b/R/parse.R @@ -229,7 +229,7 @@ parse_idf_file <- function (path, idd = NULL, ref = TRUE) { # IP - SI conversion from <- if(options$view_in_ip) "ip" else "si" to <- if(.options$view_in_ip) "ip" else "si" - dt_value <- convert_value_unit(dt_value, from, to) + dt_value <- convert_value_unit(idd_env, dt_value, from, to) # value reference map if (ref) { @@ -1427,12 +1427,20 @@ update_object_name <- function (dt_object, dt_value) { # }}} # convert_value_unit {{{ -convert_value_unit <- function (dt_value, from, to, type = "value") { +convert_value_unit <- function (idd_env, dt_value, from, to, type = "value") { from <- match.arg(from, c("si", "ip")) to <- match.arg(to, c("si", "ip")) if (identical(from, to)) return(dt_value) + if (!has_name(dt_value, "units")) { + add_field_property(idd_env, dt_value, "units") + on.exit(set(dt_value, NULL, "units", NULL), add = TRUE) + } + if (!has_name(dt_value, "ip_units")) { + add_field_property(idd_env, dt_value, "ip_units") + on.exit(set(dt_value, NULL, "ip_units", NULL), add = TRUE) + } val <- dt_value[!is.na(value_num) & !is.na(units), list(value_id, value_num, units, ip_units)] if (!nrow(val)) return(dt_value) diff --git a/R/transition.R b/R/transition.R index 7f0f1e634..38ca65c17 100644 --- a/R/transition.R +++ b/R/transition.R @@ -2911,7 +2911,7 @@ trans_preprocess <- function (idf, version, class = NULL) { ) set(val, NULL, "defaulted", TRUE) # assign default values - val <- assign_default_value(val) + val <- assign_default_value(priv$idd_env(), priv$idf_env(), val) # assign old object id val[obj, on = "rleid", object_id := i.object_id] From 1093038fa17bf4d0caa723943cfcb1365d5ba80d Mon Sep 17 00:00:00 2001 From: Hongyuan Jia Date: Fri, 10 Apr 2020 11:51:19 +0800 Subject: [PATCH 02/43] [refactor] Refactor utils.R --- DESCRIPTION | 2 +- NAMESPACE | 1 + R/utils.R | 129 +++++------------------------------- tests/testthat/test_utils.R | 124 +++++++++++++++++++++++++++++----- 4 files changed, 127 insertions(+), 129 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 81dfb58eb..dd9bf53cb 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -39,7 +39,7 @@ Suggests: rgl, rmarkdown, testthat -VignetteBuilder: +VignetteBuilder: knitr Encoding: UTF-8 LazyData: true diff --git a/NAMESPACE b/NAMESPACE index 6345058de..6a7b52ca8 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -149,6 +149,7 @@ importFrom(cli,cat_boxx) importFrom(cli,cat_bullet) importFrom(cli,cat_line) importFrom(cli,cat_rule) +importFrom(cli,console_width) importFrom(cli,rule) importFrom(cli,symbol) importFrom(crayon,bold) diff --git a/R/utils.R b/R/utils.R index e0f770241..b7a9f305e 100644 --- a/R/utils.R +++ b/R/utils.R @@ -14,7 +14,7 @@ NULL # collapse {{{ collapse <- function (x, out = "'", or = FALSE) { if (is.null(out)) { - s <- x + s <- as.character(x) } else { out <- as.character(out) if (is_scalar(out)) { @@ -26,7 +26,9 @@ collapse <- function (x, out = "'", or = FALSE) { b <- paste0(s[-length(s)], collapse = ", ") e <- s[length(s)] - if (or) { + if (is.null(or)) { + paste0(b, ", ", e) + } else if (or) { paste0(b, " or ", e) } else { paste0(b, " and ", e) @@ -36,7 +38,7 @@ collapse <- function (x, out = "'", or = FALSE) { # surround {{{ surround <- function (x, out = "'") { - if (is.null(out)) return(x) + if (is.null(out)) return(as.character(x)) out <- as.character(out) if (is_scalar(out)) { out <- c(out, out) @@ -73,40 +75,11 @@ lpad <- function(x, char = " ", width = NULL) { } # }}} -# clone_generator {{{ -clone_generator <- function (x) { - # create a new environment with the R6:::capsule environment being its - # parent - new <- new.env(parent = parent.env(x)) - - # set enclosing environments of all generator funs to the new environment - new_funs <- lapply(as.list.environment(x, all.names = TRUE), function(x) { - if (is.function(x)) environment(x) <- new - x - }) - - # add generator funs to the new environment - list2env(new_funs, new) - # set self ref - new$self <- new - - # add attributes - class(new) <- "R6ClassGenerator" - attr(new, "name") <- paste0(deparse(substitute(x)), "_generator") - - new -} -# }}} - # read_lines {{{ read_lines <- function(input, trim = TRUE, ...) { dt <- tryCatch( fread(input = input, sep = NULL, header = FALSE, col.names = "string", ...), - error = function (e) { - abort("error_read_file", - paste0("Failed to read input file. ", conditionMessage(e)) - ) - } + error = function (e) stop("Failed to read input file. ", conditionMessage(e)) ) if (!nrow(dt)) return(data.table(string = character(0L), line = integer(0L))) set(dt, j = "line", value = seq_along(dt[["string"]])) @@ -142,7 +115,7 @@ write_lines <- function (x, file = "", append = FALSE) { assert(has_name(x, "string")) fwrite(x[, list(string)], file = file, col.names = FALSE, quote = FALSE, append = append) } else { - assert(is.character(x)) + checkmate::assert_character(x) fwrite(data.table(x), file = file, col.names = FALSE, quote = FALSE, append = append) } } @@ -180,26 +153,18 @@ standardize_ver <- function (ver, strict = FALSE, complete = TRUE) { ver[has_trail] <- ver[has_trail, 1L:3L] # complete patch version to 0 if not exist - if (complete && any(!is.na(ver) & is.na(ver[, 3L]))) { - ver[!is.na(ver) & is.na(ver[, 3L]), 3L] <- 0L + if (complete && any(!is.na(ver) & suppressWarnings(is.na(ver[, 3L])))) { + ver[!is.na(ver) & suppressWarnings(is.na(ver[, 3L])), 3L] <- 0L } ver } # }}} -# complete_patch_ver {{{ -complete_patch_ver <- function (ver) { - if (any(!is.na(ver) & is.na(ver[, 3L]))) { - ver[!is.na(ver) & is.na(ver[, 3L]), 3L] <- 0L - } - ver -} -# }}} - # match_minor_ver {{{ match_minor_ver <- function (ver, all_ver, type = c("idd", "eplus"), verbose = TRUE) { - assert(is_scalar(ver)) + checkmate::assert_class(ver, "numeric_version") + checkmate::assert_vector(ver, len = 1L) if (!length(all_ver)) return(numeric_version(NA, strict = FALSE)) all_ver <- unique(all_ver) ori_ver <- ver @@ -230,12 +195,6 @@ match_minor_ver <- function (ver, all_ver, type = c("idd", "eplus"), verbose = T } # }}} -# is_normal_list {{{ -is_normal_list <- function (x) { - is.list(x) && vec_depth(x) == 2L && all(vapply(x, not_empty, logical(1))) -} -# }}} - # vec_depth {{{ vec_depth <- function (x) { if (is.null(x)) { @@ -246,7 +205,7 @@ vec_depth <- function (x) { depths <- vapply(x, vec_depth, integer(1)) 1L + max(depths, 0L) } else { - stop("`x` must be a vector") + stop("'x' must be a vector") } } # }}} @@ -380,7 +339,7 @@ names2 <- function (x, default = NA_character_) { # each_length {{{ each_length <- function (x) { - vapply(x, length, integer(1L)) + viapply(x, length) } # }}} @@ -398,9 +357,6 @@ ranger <- function (minimum = -Inf, lower_incbounds = FALSE, maximum = Inf, uppe "class", c("Range", "list") ) } -# as_Range.character <- function (x) { -# "([\\(\\[])\\s*(\\d+)\\s*,\\s*(\\d+|Inf)\\s*([\\)\\]])" -# } # }}} # append_dt {{{ @@ -416,20 +372,11 @@ append_dt <- function (dt, new_dt, base_col = NULL) { # }}} # unique_id {{{ +# nocov start unique_id <- function () { - paste0("id-", stri_rand_strings(1, 15L)) -} -# }}} - -# as_integer {{{ -as_integer <- function (x) { - x <- as.double(x) - if (any(x[!is.na(x)] != trunc(x[!is.na(x)]))) { - x[!is.na(x) & x != trunc(x)] <- NA_integer_ - warning("NAs introduced by coercion") - } - x + paste0("id-", stri_rand_strings(1, 15L), "-", Sys.time()) } +# nocov end # }}} # fmt_* {{{ @@ -443,50 +390,8 @@ wday <- function (x, label = FALSE) { } # }}} -# .deprecated_fun {{{ -# adopted from tidyverse/lubridate/R/deprecated.R -.deprecated_fun <- function(name, replacement, class = NULL, version) { - class <- if (is.null(class)) "" else paste0(" in ", class, " class") - msg <- paste0(sprintf("`%s` is deprecated%s in eplusr version `%s`. Please use `%s` instead.", - name, class, version, replacement) - ) - .deprecated(msg, version) -} -# }}} - -# .deprecated_arg {{{ -.deprecated_arg <- function(arg, version, class = NULL, n_call = 1) { - name <- paste0(as.character(sys.call(-n_call)[[1]]), "()") - if (!is.null(class)) { - name <- sub(".*?_", "$", name) - cls <- paste0(" in class '", class, "'") - } else { - cls <- "" - } - mes <- sprintf("Parameter `%s` of `%s`%s has been deprecated in eplusr version %s.", - arg, name, cls, version) - .deprecated(mes, version) -} -# }}} - -# .deprecated {{{ -.deprecated <- function(msg, version) { - v <- as.package_version(version) - cv <- utils::packageVersion("eplusr") - - # If current major number is greater than last-good major number, or if - # current minor number is more than 2 greater than last-good minor number, - # give error. - if (cv[[1, 1]] > v[[1, 1]] || cv[[1, 2]] > v[[1, 2]] + 2) { - abort("error_eplusr_deprecated", msg) - } else { - warn("warning_eplusr_deprecated", msg) - } - invisible() -} -# }}} - # str_trunc {{{ +#' @importFrom cli console_width str_trunc <- function (x, width = cli::console_width()) { # in case invalid UTF-8 character in IDF x <- stringi::stri_encode(x) diff --git a/tests/testthat/test_utils.R b/tests/testthat/test_utils.R index 994708b0a..c1a056de6 100644 --- a/tests/testthat/test_utils.R +++ b/tests/testthat/test_utils.R @@ -1,17 +1,109 @@ -test_that("list checking", { - expect_true(is_normal_list(list(1, 2))) - expect_true(is_normal_list(list(1, NA))) - expect_true(is_normal_list(list(1, list(NULL)))) - expect_false(is_normal_list(list(character(0)))) - expect_false(is_normal_list(list(NULL))) - expect_false(is_normal_list(list(1, NULL))) - expect_false(is_normal_list(list(1, character(0)))) - expect_false(is_normal_list(list(1, list()))) - expect_false(is_normal_list(list(1, list(1)))) - - expect_equal(standardize_ver(1)[, 2], numeric_version(0)) - expect_equal(standardize_ver("a"), numeric_version(NA, strict = FALSE)) - expect_equal(standardize_ver("1.1.1.1"), numeric_version("1.1.1", strict = FALSE)) - expect_equal(standardize_ver("1.1.1.1", complete = TRUE), numeric_version("1.1.1", strict = FALSE)) - expect_equal(standardize_ver("1.1", complete = TRUE), numeric_version("1.1.0")) +test_that("Utility functions", { + expect_equal(NULL %||% 1, 1) + expect_equal(1 %||% 2, 1) + + expect_equal(collapse(1:3), "'1', '2' and '3'") + expect_equal(collapse(1:3, out = NULL), "1, 2 and 3") + expect_equal(collapse(1, out = NULL), "1") + expect_equal(collapse(1:3, or = NULL), "'1', '2', '3'") + expect_equal(collapse(1:3, or = TRUE), "'1', '2' or '3'") + + expect_equal(surround(1:3), c("'1'", "'2'", "'3'")) + expect_equal(surround(1:3, out = NULL), as.character(1:3)) + + expect_null(rpad(NULL)) + expect_equal(rpad(c(1, 10)), c("1 ", "10")) + expect_equal(rpad(c(1, 10), width = 3), c("1 ", "10 ")) + + expect_null(lpad(NULL)) + expect_equal(lpad(c(1, 10)), c(" 1", "10")) + expect_equal(lpad(c(1, 10), width = 3), c(" 1", " 10")) + + expect_error(read_lines(NULL), "Failed to read input file") + expect_equal(read_lines("a\n b \n c \n"), data.table(line = 1:3, string = c("a", "b", "c"))) + + f <- tempfile() + expect_silent(write_lines(read_lines("a\nb"), f)) + expect_equal(read_lines(f), data.table(line = 1:2, string = c("a", "b"))) + expect_silent(write_lines(c("a", "b"), f)) + expect_equal(read_lines(f), data.table(line = 1:2, string = c("a", "b"))) + expect_silent(write_lines(c("c", "d"), f, append = TRUE)) + expect_equal(read_lines(f), data.table(line = 1:4, string = c("a", "b", "c", "d"))) + expect_error(write_lines(1:3, f), "Must be of type 'character'") + + expect_equal(standardize_ver("latest"), numeric_version("9.2.0")) + expect_equal(standardize_ver("latest", strict = TRUE), numeric_version(NA, strict = FALSE)) + expect_equal(standardize_ver(c(1, 1.1)), numeric_version(c("1.0.0", "1.1.0"))) + expect_equal(standardize_ver(c(1, 1.1), complete = FALSE), numeric_version(c("1.0", "1.1"))) + expect_equal(standardize_ver(c("1.0", "1.1.0.01")), numeric_version(c("1.0.0", "1.1.0"))) + expect_equal(standardize_ver(c("1.0", "1.1.0.01"), complete = FALSE), numeric_version(c("1.0", "1.1.0"))) + + expect_error(match_minor_ver(1), "numeric_version") + expect_error(match_minor_ver(numeric_version(1:2)), "length 1") + expect_equal(match_minor_ver(numeric_version("0.0"), ALL_IDD_VER), numeric_version(NA, strict = FALSE)) + expect_equal(match_minor_ver(numeric_version("9.1"), ALL_IDD_VER), numeric_version("9.1.0")) + expect_equal(match_minor_ver(numeric_version("9.0"), ALL_IDD_VER), numeric_version("9.0.1")) + + expect_equal(vec_depth(NULL), 0L) + expect_equal(vec_depth(character()), 1L) + expect_equal(vec_depth(list()), 1L) + expect_equal(vec_depth(list(list())), 2L) + expect_equal(vec_depth(list(list(NULL))), 2L) + expect_equal(vec_depth(list(list(1))), 3L) + expect_error(vec_depth(environment()), "must be a vector") + + expect_equal(vlapply(1:3, is.integer), rep(TRUE, 3L)) + expect_equal(vlapply(setNames(1:3, c("a", "b", "c")), is.integer), setNames(rep(TRUE, 3L), c("a", "b", "c"))) + expect_equal(vlapply(setNames(1:3, c("a", "b", "c")), is.integer, use.names = FALSE), rep(TRUE, 3L)) + + expect_equal(viapply(1:3, length), rep(1L, 3L)) + expect_equal(viapply(setNames(1:3, c("a", "b", "c")), length), setNames(rep(1L, 3L), c("a", "b", "c"))) + expect_equal(viapply(setNames(1:3, c("a", "b", "c")), length, use.names = FALSE), rep(1L, 3L)) + + expect_equal(vcapply(1:3, paste), as.character(1:3)) + expect_equal(vcapply(setNames(1:3, c("a", "b", "c")), paste), setNames(as.character(1:3), c("a", "b", "c"))) + expect_equal(vcapply(setNames(1:3, c("a", "b", "c")), paste, use.names = FALSE), as.character(1:3)) + + expect_equal(apply2(1:3, 4:6, "+"), list(5L, 7L, 9L)) + expect_equal(apply2_int(1:3, 4:6, "+"), c(5L, 7L, 9L)) + expect_equal(apply2_lgl(1:3, 4:6, ">"), rep(FALSE, 3L)) + expect_equal(apply2_chr(1:3, 4:6, paste0), c("14", "25", "36")) + + expect_equal(underscore_name("Class Name"), "Class_Name") + expect_equal(underscore_name("Class:Name"), "Class_Name") + expect_equal(lower_name("Class:Name"), "class_name") + expect_equal(lower_name("Class Name"), "class_name") + + expect_equal(make_filename(c("", "")), c("_a____", "_a_____1")) + expect_equal(make_filename(c("", ""), unique = FALSE), c("_a____", "_a____")) + + expect_equal(names2(1:3), rep(NA_character_, 3)) + expect_equal(names2(c(a = 1, 2)), c("a", NA_character_)) + + expect_equal(each_length(list(1, 2:3)), c(1L, 2L)) + + expect_equal(ranger()[], list(minimum = -Inf, lower_incbounds = FALSE, maximum = Inf, upper_incbounds = FALSE)) + expect_equal(format(ranger()), "(-Inf, Inf)") + expect_equal(ranger(1, TRUE)[], list(minimum = 1, lower_incbounds = TRUE, maximum = Inf, upper_incbounds = FALSE)) + expect_equal(format(ranger(1, TRUE)), "[1, Inf)") + + expect_error(append_dt(data.table(a = 1), data.table())) + expect_equal(append_dt(data.table(), data.table()), data.table()) + expect_equal(append_dt(data.table(a = 1), data.table(a = 2, b = 1)), data.table(a = c(1, 2))) + expect_equal(append_dt(data.table(a = 1, b = 1), data.table(a = c(1, 2), b = c(3, 4)), "a"), data.table(a = c(1, 2), b = c(3, 4))) + + expect_equal(fmt_dbl(1.111), "1.11") + expect_equal(fmt_dbl(1.111, 1), "1.1") + expect_equal(fmt_int(1), "1.0") + expect_equal(fmt_int(1, 0), "1") + + expect_equal(wday(as.Date("2020-01-01")), 3L) + expect_equal(as.character(wday(as.Date("2020-01-01"), label = TRUE)), "Wednesday") + + expect_equal(str_trunc("abcdefghij", 10), "abcde...") + + expect_equal(match_in_vec("a", LETTERS), 1L) + expect_equal(match_in_vec("a", LETTERS, "aa"), 1L) + expect_equal(match_in_vec("a", LETTERS, "aa", label = TRUE), "A") + expect_equal(match_in_vec("aa", LETTERS, "aa", label = TRUE), "A") }) From a7dc177e62f9b3f760ec413ea2d49993d6e547f0 Mon Sep 17 00:00:00 2001 From: Hongyuan Jia Date: Fri, 10 Apr 2020 15:18:12 +0800 Subject: [PATCH 03/43] [refactor] Clean up units.R --- R/impl-idfobj.R | 2 +- R/parse.R | 4 +- R/units.R | 449 +----------------------------------- tests/testthat/test_units.R | 124 ++++++++++ 4 files changed, 132 insertions(+), 447 deletions(-) create mode 100644 tests/testthat/test_units.R diff --git a/R/impl-idfobj.R b/R/impl-idfobj.R index 92277d96a..c1684bfae 100644 --- a/R/impl-idfobj.R +++ b/R/impl-idfobj.R @@ -91,7 +91,7 @@ get_value_list <- function (dt_value, unit = FALSE) { if (any(u)) { col <- paste0(prefix, "_standard_name") - unit <- UNIT_CONV_TABLE[J(dt_value[[input]][u]), on = c(paste0(prefix, "_name")), + unit <- FIELD_UNIT_TABLE[J(dt_value[[input]][u]), on = c(paste0(prefix, "_name")), mult = "first", .SD, .SDcols = c(col)] res[u] <- apply2(res[u], unit[[col]], function (val, unit) { diff --git a/R/parse.R b/R/parse.R index 070871a5a..8939d2100 100644 --- a/R/parse.R +++ b/R/parse.R @@ -978,7 +978,7 @@ parse_field_property_name <- function (dt) { ] # fill missing ip units - unit_dt <- UNIT_CONV_TABLE[UNIT_CONV_TABLE[, .I[1], by = si_name]$V1, + unit_dt <- FIELD_UNIT_TABLE[FIELD_UNIT_TABLE[, .I[1], by = si_name]$V1, .SD, .SDcols = c("si_name", "ip_name") ] dt <- unit_dt[dt, on = list(si_name = units)][is.na(ip_units), `:=`(ip_units = ip_name)] @@ -1445,7 +1445,7 @@ convert_value_unit <- function (idd_env, dt_value, from, to, type = "value") { if (!nrow(val)) return(dt_value) - val <- UNIT_CONV_TABLE[val, on = c(si_name = "units", ip_name = "ip_units")] + val <- FIELD_UNIT_TABLE[val, on = c(si_name = "units", ip_name = "ip_units")] set(val, NULL, c("si_name", "ip_name"), NULL) setnames(val, c("si_standard_name", "ip_standard_name"), c("si", "ip")) diff --git a/R/units.R b/R/units.R index ac03500e5..a9940765e 100644 --- a/R/units.R +++ b/R/units.R @@ -1,4 +1,4 @@ -#' @importFrom data.table data.table +#' @importFrom data.table fread #' @importFrom units install_symbolic_unit install_conversion_constant NULL @@ -17,8 +17,9 @@ reg_custom_units <- function () { } # }}} -# UNIT_CONV_TABLE {{{ -UNIT_CONV_TABLE <- fread( +# FIELD_UNIT_TABLE {{{ +# nocov start +FIELD_UNIT_TABLE <- fread( " si_name si_standard_name ip_name ip_standard_name m m ft ft @@ -177,445 +178,5 @@ UNIT_CONV_TABLE <- fread( W/((m3/s)-Pa) W/((m3/s)*Pa) W/((ft3/min)-inH2O) W/((ft^3/min)*inH2O) " ) -# }}} - -# tablular_units_record {{{ -# SI names {{{ -si_name <- character(length = 115) -si_name[1] <- "%" -si_name[2] <- "?C" -si_name[3] <- "0=OFF 1=ON" -si_name[4] <- "0-NO 1-YES" -si_name[5] <- "1-YES 0-NO" -si_name[6] <- "A" -si_name[7] <- "ACH" -si_name[8] <- "ACH" -si_name[9] <- "BASE 10C" -si_name[10] <- "BASE 18C" -si_name[11] <- "C" -si_name[12] <- "CD/M2" -si_name[13] <- "DEG" -si_name[14] <- "FRAC" -si_name[15] <- "HOUR" -si_name[16] <- "HOURS" -si_name[17] <- "HR" -si_name[18] <- "HRS" -si_name[19] <- "J" -si_name[20] <- "J" -si_name[21] <- "J" -si_name[22] <- "J" -si_name[23] <- "J" -si_name[24] <- "J" -si_name[25] <- "J/KG" -si_name[26] <- "J/KG H2O" -si_name[27] <- "J/M2" -si_name[28] <- "K/M" -si_name[29] <- "KG" -si_name[30] <- "KG/KG" -si_name[31] <- "KG/M3" -si_name[32] <- "KG/S" -si_name[33] <- "KGWATER/KGAIR" -si_name[34] <- "KGWATER/SEC" -si_name[35] <- "KMOL/S" -si_name[36] <- "KMOL/SEC" -si_name[37] <- "KWH" -si_name[38] <- "L" -si_name[39] <- "L" -si_name[40] <- "LUM/W" -si_name[41] <- "LUX" -si_name[42] <- "M" -si_name[43] <- "M" -si_name[44] <- "M/S" -si_name[45] <- "M/S" -si_name[46] <- "M2" -si_name[47] <- "M2/PERSON" -si_name[48] <- "M3" -si_name[49] <- "M3" -si_name[50] <- "M3/M2" -si_name[51] <- "M3/S" -si_name[52] <- "M3/S" -si_name[53] <- "M3/S-M2" -si_name[54] <- "M3/S-PERSON" -si_name[55] <- "M3/S-PERSON" -si_name[56] <- "PA" -si_name[57] <- "PA" -si_name[58] <- "PA" -si_name[59] <- "PA" -si_name[60] <- "PA" -si_name[61] <- "PA" -si_name[62] <- "PA" -si_name[63] <- "PA" -si_name[64] <- "S" -si_name[65] <- "V" -si_name[66] <- "W" -si_name[67] <- "W" -si_name[68] <- "W" -si_name[69] <- "W" -si_name[70] <- "W" -si_name[71] <- "W/KG" -si_name[72] <- "W/KG H2O" -si_name[73] <- "W/K" -si_name[74] <- "W/M2" -si_name[75] <- "W/M2" -si_name[76] <- "W/M2-C" -si_name[77] <- "W/M2-K" -si_name[78] <- "W/W" -si_name[79] <- "deltaC" -si_name[80] <- "KJ/KG" -si_name[81] <- "W-S/M3" -si_name[82] <- "W-S/M3" -si_name[83] <- "~~$~~/m2" -si_name[84] <- "GJ" -si_name[85] <- "GJ" -si_name[86] <- "GJ" -si_name[87] <- "GJ" -si_name[88] <- "GJ" -si_name[89] <- "GJ" -si_name[90] <- "GJ" -si_name[91] <- "MJ/m2" -si_name[92] <- "MJ/m2" -si_name[93] <- "MJ/m2" -si_name[94] <- "MJ/m2" -si_name[95] <- "Invalid/Undefined" -si_name[96] <- "" -si_name[97] <- "W/C" -si_name[98] <- "DAY" -si_name[99] <- "MIN" -si_name[100] <- "HR/WK" -si_name[101] <- "$" -si_name[102] <- "$/UNIT ENERGY" -si_name[103] <- "KW" -si_name[104] <- "KGWATER/KGDRYAIR" -si_name[105] <- " " -si_name[106] <- "AH" -si_name[107] <- "CLO" -si_name[108] <- "J/KG-K" -si_name[109] <- "J/KGWATER" -si_name[110] <- "KGWATER/S" -si_name[111] <- "PPM" -si_name[112] <- "RAD" -si_name[113] <- "REV/MIN" -si_name[114] <- "NM" -si_name[115] <- "BTU/W-H" -# }}} - -# IP names {{{ -ip_name <- character(length = 115) -ip_name[1] <- "%" -ip_name[2] <- "F" -ip_name[3] <- "0=Off 1=On" -ip_name[4] <- "0-No 1-Yes" -ip_name[5] <- "1-Yes 0-No" -ip_name[6] <- "A" -ip_name[7] <- "ACH" -ip_name[8] <- "ach" -ip_name[9] <- "base 50F" -ip_name[10] <- "base 65F" -ip_name[11] <- "F" -ip_name[12] <- "cd/in2" -ip_name[13] <- "deg" -ip_name[14] <- "Frac" -ip_name[15] <- "Hour" -ip_name[16] <- "Hours" -ip_name[17] <- "hr" -ip_name[18] <- "hrs" -ip_name[19] <- "kBtu" -ip_name[20] <- "kWh" -ip_name[21] <- "therm" -ip_name[22] <- "MMBtu" -ip_name[23] <- "Wh" -ip_name[24] <- "ton-hrs" -ip_name[25] <- "Btu/lb" -ip_name[26] <- "Btu/lbWater" -ip_name[27] <- "kBtu/sqft" -ip_name[28] <- "F/ft" -ip_name[29] <- "lb" -ip_name[30] <- "lb/lb" -ip_name[31] <- "lb/ft3" -ip_name[32] <- "lb/s" -ip_name[33] <- "lbWater/lbAir" -ip_name[34] <- "lbWater/s" -ip_name[35] <- "kmol/s" -ip_name[36] <- "kmol/sec" -ip_name[37] <- "kWh" -ip_name[38] <- "gal" -ip_name[39] <- "ft3" -ip_name[40] <- "lum/W" -ip_name[41] <- "foot-candles" -ip_name[42] <- "ft" -ip_name[43] <- "in" -ip_name[44] <- "ft/min" -ip_name[45] <- "miles/hr" -ip_name[46] <- "ft2" -ip_name[47] <- "ft2/person" -ip_name[48] <- "ft3" -ip_name[49] <- "gal" -ip_name[50] <- "f3/f2" -ip_name[51] <- "ft3/min" -ip_name[52] <- "gal/min" -ip_name[53] <- "ft3/min-ft2" -ip_name[54] <- "ft3/min-person" -ip_name[55] <- "gal/min-person" -ip_name[56] <- "psi" -ip_name[57] <- "inHg" -ip_name[58] <- "inH2O" -ip_name[59] <- "ftH2O" -ip_name[60] <- "psi" -ip_name[61] <- "inHg" -ip_name[62] <- "inH2O" -ip_name[63] <- "ftH2O" -ip_name[64] <- "s" -ip_name[65] <- "V" -ip_name[66] <- "Btu/h" -ip_name[67] <- "W" -ip_name[68] <- "kW" -ip_name[69] <- "kBtuh" -ip_name[70] <- "ton" -ip_name[71] <- "kBtuh/lb" -ip_name[72] <- "kBtuh/lb" -ip_name[73] <- "Btu/h-F" -ip_name[74] <- "Btu/h-ft2" -ip_name[75] <- "kBtuh/ft2" -ip_name[76] <- "Btu/h-ft2-F" -ip_name[77] <- "Btu/h-ft2-F" -ip_name[78] <- "Btuh/Btuh" -ip_name[79] <- "deltaF" -ip_name[80] <- "Btu/lb" -ip_name[81] <- "W-min/ft3" -ip_name[82] <- "W-min/gal" -ip_name[83] <- "~~$~~/ft2" -ip_name[84] <- "kBtu" -ip_name[85] <- "kWh" -ip_name[86] <- "kWh" -ip_name[87] <- "therm" -ip_name[88] <- "MMBtu" -ip_name[89] <- "Wh" -ip_name[90] <- "ton-hrs" -ip_name[91] <- "kWh/ft2" -ip_name[92] <- "kBtu/ft2" -ip_name[93] <- "kBtu/ft2" -ip_name[94] <- "kWh/m2" -ip_name[95] <- "Invalid/Undefined" -ip_name[96] <- "" -ip_name[97] <- "Btu/h-F" -ip_name[98] <- "day" -ip_name[99] <- "min" -ip_name[100] <- "hr/wk" -ip_name[101] <- "$" -ip_name[102] <- "$/unit energy" -ip_name[103] <- "kW" -ip_name[104] <- "lbWater/lbDryAir" -ip_name[105] <- " " -ip_name[106] <- "Ah" -ip_name[107] <- "clo" -ip_name[108] <- "Btu/lbm-R" -ip_name[109] <- "Btu/lbWater" -ip_name[110] <- "lbWater/s" -ip_name[111] <- "ppm" -ip_name[112] <- "rad" -ip_name[113] <- "rev/min" -ip_name[114] <- "lbf-ft" -ip_name[115] <- "Btu/W-h" -# }}} - -# mult {{{ -mult <- double(length = 115) -mult[1] <- 1.0 -mult[2] <- 1.8 -mult[3] <- 1.0 -mult[4] <- 1.0 -mult[5] <- 1.0 -mult[6] <- 1.0 -mult[7] <- 1.0 -mult[8] <- 1.0 -mult[9] <- 1.8 -mult[10] <- 1.8 -mult[11] <- 1.8 -mult[12] <- 0.000645160041625726 -mult[13] <- 1.0 -mult[14] <- 1.0 -mult[15] <- 1.0 -mult[16] <- 1.0 -mult[17] <- 1.0 -mult[18] <- 1.0 -mult[19] <- 0.00000094845 -mult[20] <- 0.000000277778 -mult[21] <- 0.0000000094845 -mult[22] <- 0.00000000094845 -mult[23] <- 0.000277777777777778 -mult[24] <- 0.0000000789847 -mult[25] <- 0.00042956 -mult[26] <- 0.0000004302105 -mult[27] <- 0.00000008811404 -mult[28] <- 0.54861322767449 -mult[29] <- 2.2046 -mult[30] <- 1.0 -mult[31] <- 0.062428 -mult[32] <- 2.2046 -mult[33] <- 1.0 -mult[34] <- 2.2046 -mult[35] <- 1.0 -mult[36] <- 1.0 -mult[37] <- 1.0 -mult[38] <- 0.264172037284185 -mult[39] <- 0.0353146624712848 -mult[40] <- 1.0 -mult[41] <- 0.092902267 -mult[42] <- 3.281 -mult[43] <- 39.37 -mult[44] <- 196.86 -mult[45] <- 2.2369 -mult[46] <- 10.764961 -mult[47] <- 10.764961 -mult[48] <- 35.319837041 -mult[49] <- 264.172 -mult[50] <- 3.281 -mult[51] <- 2118.6438 -mult[52] <- 15852.0 -mult[53] <- 196.85 -mult[54] <- 2118.6438 -mult[55] <- 15852.0 -mult[56] <- 0.0001450377 -mult[57] <- 0.00029613 -mult[58] <- 0.00401463 -mult[59] <- 0.00033455 -mult[60] <- 0.0001450377 -mult[61] <- 0.00029613 -mult[62] <- 0.00401463 -mult[63] <- 0.00033455 -mult[64] <- 1.0 -mult[65] <- 1.0 -mult[66] <- 3.412 -mult[67] <- 1.0 -mult[68] <- 0.001 -mult[69] <- 0.00341442 -mult[70] <- 0.0002843333 -mult[71] <- 0.001547673 -mult[72] <- 0.001547673 -mult[73] <- 1.8987 -mult[74] <- 0.316954237 -mult[75] <- 0.000316954237 -mult[76] <- 0.176085687 -mult[77] <- 0.176085687 -mult[78] <- 1.0 -mult[79] <- 1.8 -mult[80] <- 0.42956 -mult[81] <- 1.0 / 2118.6438 -mult[82] <- 1.0 / 15852 -mult[83] <- 1.0 / 10.764961 -mult[84] <- 0.00000094845 * 1000000000 -mult[85] <- 0.000000277778 * 1000000000 -mult[86] <- 0.000000277778 * 1000000000 -mult[87] <- 0.0000000094845 * 1000000000 -mult[88] <- 0.00000000094845 * 1000000000 -mult[89] <- 0.000277777777777778 * 1000000000 -mult[90] <- 0.0000000789847 * 1000000000 -mult[91] <- 0.277777777777778 / 10.764961 -mult[92] <- 0.94708628903179 / 10.764961 -mult[93] <- 0.94708628903179 / 10.764961 -mult[94] <- 0.27777777777778 -mult[95] <- 1.0 -mult[96] <- 1.0 -mult[97] <- 1.8987 -mult[98] <- 1.0 -mult[99] <- 1.0 -mult[100] <- 1.0 -mult[101] <- 1.0 -mult[102] <- 1.0 -mult[103] <- 1.0 -mult[104] <- 1.0 -mult[105] <- 1.0 -mult[106] <- 1.0 -mult[107] <- 1.0 -mult[108] <- 0.000238845896627 -mult[109] <- 0.0000004302105 -mult[110] <- 2.2046 -mult[111] <- 1.0 -mult[112] <- 1.0 -mult[113] <- 1.0 -mult[114] <- 0.737562149277 -mult[115] <- 1.0 -# }}} - -# offset {{{ -offset <- double(length = 115) -offset[2] <- 32.0 -offset[11] <- 32.0 -offset[25] <- 7.6736 -offset[80] <- 7.6736 -# }}} - -# hint {{{ -hint <- character(115) -hint[20] <- "ELEC" -hint[21] <- "GAS" -hint[24] <- "COOL" -hint[38] <- "WATER" -hint[49] <- "WATER" -hint[52] <- "WATER" -hint[67] <- "ELEC" -hint[70] <- "COOL" -hint[82] <- "WATER" -hint[85] <- "CONSUMP" -hint[86] <- "ELEC" -hint[87] <- "GAS" -hint[90] <- "COOL" -hint[91] <- "ELEC" -hint[92] <- "GAS" -hint[92] <- "ADDITIONAL" -# }}} - -# several {{{ -several <- logical(115) -several[19] <- TRUE -several[20] <- TRUE -several[21] <- TRUE -several[22] <- TRUE -several[23] <- TRUE -several[24] <- TRUE -several[38] <- TRUE -several[39] <- TRUE -several[42] <- TRUE -several[43] <- TRUE -several[44] <- TRUE -several[45] <- TRUE -several[48] <- TRUE -several[49] <- TRUE -several[51] <- TRUE -several[52] <- TRUE -several[54] <- TRUE -several[55] <- TRUE -several[56] <- TRUE -several[57] <- TRUE -several[58] <- TRUE -several[59] <- TRUE -several[60] <- TRUE -several[61] <- TRUE -several[62] <- TRUE -several[63] <- TRUE -several[66] <- TRUE -several[67] <- TRUE -several[68] <- TRUE -several[69] <- TRUE -several[70] <- TRUE -several[74] <- TRUE -several[75] <- TRUE -several[81] <- TRUE -several[82] <- TRUE -several[84] <- TRUE -several[85] <- TRUE -several[86] <- TRUE -several[87] <- TRUE -several[88] <- TRUE -several[89] <- TRUE -several[90] <- TRUE -several[91] <- TRUE -several[92] <- TRUE -several[93] <- TRUE -several[94] <- TRUE -# }}} - -tabular_unit_conv_table <- data.table( - si_name, ip_name, mult, offset, hint, several -) +# nocov start # }}} diff --git a/tests/testthat/test_units.R b/tests/testthat/test_units.R new file mode 100644 index 000000000..fc46ea776 --- /dev/null +++ b/tests/testthat/test_units.R @@ -0,0 +1,124 @@ +test_that("Units conversion", { + expect_silent(reg_custom_units()) + + expect_equal(units::set_units(1, "person") + units::set_units(1, "person"), + units::set_units(2, "person") + ) + expect_equal(units::set_units(1, "dollar") + units::set_units(1, "dollar"), + units::set_units(2, "dollar") + ) + expect_equal(units::set_units(1, "Wh") + units::set_units(3600, "J"), + units::set_units(2, "Wh") + ) + expect_equal(units::set_units(units::set_units(1, "inH2O"), "inch_H2O_39F"), + units::set_units(1, "inch_H2O_39F") + ) + + expect_equal(NULL %||% 1, 1) + expect_equal(1 %||% 2, 1) + + expect_equal(collapse(1:3), "'1', '2' and '3'") + expect_equal(collapse(1:3, out = NULL), "1, 2 and 3") + expect_equal(collapse(1, out = NULL), "1") + expect_equal(collapse(1:3, or = NULL), "'1', '2', '3'") + expect_equal(collapse(1:3, or = TRUE), "'1', '2' or '3'") + + expect_equal(surround(1:3), c("'1'", "'2'", "'3'")) + expect_equal(surround(1:3, out = NULL), as.character(1:3)) + + expect_null(rpad(NULL)) + expect_equal(rpad(c(1, 10)), c("1 ", "10")) + expect_equal(rpad(c(1, 10), width = 3), c("1 ", "10 ")) + + expect_null(lpad(NULL)) + expect_equal(lpad(c(1, 10)), c(" 1", "10")) + expect_equal(lpad(c(1, 10), width = 3), c(" 1", " 10")) + + expect_error(read_lines(NULL), "Failed to read input file") + expect_equal(read_lines("a\n b \n c \n"), data.table(line = 1:3, string = c("a", "b", "c"))) + + f <- tempfile() + expect_silent(write_lines(read_lines("a\nb"), f)) + expect_equal(read_lines(f), data.table(line = 1:2, string = c("a", "b"))) + expect_silent(write_lines(c("a", "b"), f)) + expect_equal(read_lines(f), data.table(line = 1:2, string = c("a", "b"))) + expect_silent(write_lines(c("c", "d"), f, append = TRUE)) + expect_equal(read_lines(f), data.table(line = 1:4, string = c("a", "b", "c", "d"))) + expect_error(write_lines(1:3, f), "Must be of type 'character'") + + expect_equal(standardize_ver("latest"), numeric_version("9.2.0")) + expect_equal(standardize_ver("latest", strict = TRUE), numeric_version(NA, strict = FALSE)) + expect_equal(standardize_ver(c(1, 1.1)), numeric_version(c("1.0.0", "1.1.0"))) + expect_equal(standardize_ver(c(1, 1.1), complete = FALSE), numeric_version(c("1.0", "1.1"))) + expect_equal(standardize_ver(c("1.0", "1.1.0.01")), numeric_version(c("1.0.0", "1.1.0"))) + expect_equal(standardize_ver(c("1.0", "1.1.0.01"), complete = FALSE), numeric_version(c("1.0", "1.1.0"))) + + expect_error(match_minor_ver(1), "numeric_version") + expect_error(match_minor_ver(numeric_version(1:2)), "length 1") + expect_equal(match_minor_ver(numeric_version("0.0"), ALL_IDD_VER), numeric_version(NA, strict = FALSE)) + expect_equal(match_minor_ver(numeric_version("9.1"), ALL_IDD_VER), numeric_version("9.1.0")) + expect_equal(match_minor_ver(numeric_version("9.0"), ALL_IDD_VER), numeric_version("9.0.1")) + + expect_equal(vec_depth(NULL), 0L) + expect_equal(vec_depth(character()), 1L) + expect_equal(vec_depth(list()), 1L) + expect_equal(vec_depth(list(list())), 2L) + expect_equal(vec_depth(list(list(NULL))), 2L) + expect_equal(vec_depth(list(list(1))), 3L) + expect_error(vec_depth(environment()), "must be a vector") + + expect_equal(vlapply(1:3, is.integer), rep(TRUE, 3L)) + expect_equal(vlapply(setNames(1:3, c("a", "b", "c")), is.integer), setNames(rep(TRUE, 3L), c("a", "b", "c"))) + expect_equal(vlapply(setNames(1:3, c("a", "b", "c")), is.integer, use.names = FALSE), rep(TRUE, 3L)) + + expect_equal(viapply(1:3, length), rep(1L, 3L)) + expect_equal(viapply(setNames(1:3, c("a", "b", "c")), length), setNames(rep(1L, 3L), c("a", "b", "c"))) + expect_equal(viapply(setNames(1:3, c("a", "b", "c")), length, use.names = FALSE), rep(1L, 3L)) + + expect_equal(vcapply(1:3, paste), as.character(1:3)) + expect_equal(vcapply(setNames(1:3, c("a", "b", "c")), paste), setNames(as.character(1:3), c("a", "b", "c"))) + expect_equal(vcapply(setNames(1:3, c("a", "b", "c")), paste, use.names = FALSE), as.character(1:3)) + + expect_equal(apply2(1:3, 4:6, "+"), list(5L, 7L, 9L)) + expect_equal(apply2_int(1:3, 4:6, "+"), c(5L, 7L, 9L)) + expect_equal(apply2_lgl(1:3, 4:6, ">"), rep(FALSE, 3L)) + expect_equal(apply2_chr(1:3, 4:6, paste0), c("14", "25", "36")) + + expect_equal(underscore_name("Class Name"), "Class_Name") + expect_equal(underscore_name("Class:Name"), "Class_Name") + expect_equal(lower_name("Class:Name"), "class_name") + expect_equal(lower_name("Class Name"), "class_name") + + expect_equal(make_filename(c("", "")), c("_a____", "_a_____1")) + expect_equal(make_filename(c("", ""), unique = FALSE), c("_a____", "_a____")) + + expect_equal(names2(1:3), rep(NA_character_, 3)) + expect_equal(names2(c(a = 1, 2)), c("a", NA_character_)) + + expect_equal(each_length(list(1, 2:3)), c(1L, 2L)) + + expect_equal(ranger()[], list(minimum = -Inf, lower_incbounds = FALSE, maximum = Inf, upper_incbounds = FALSE)) + expect_equal(format(ranger()), "(-Inf, Inf)") + expect_equal(ranger(1, TRUE)[], list(minimum = 1, lower_incbounds = TRUE, maximum = Inf, upper_incbounds = FALSE)) + expect_equal(format(ranger(1, TRUE)), "[1, Inf)") + + expect_error(append_dt(data.table(a = 1), data.table())) + expect_equal(append_dt(data.table(), data.table()), data.table()) + expect_equal(append_dt(data.table(a = 1), data.table(a = 2, b = 1)), data.table(a = c(1, 2))) + expect_equal(append_dt(data.table(a = 1, b = 1), data.table(a = c(1, 2), b = c(3, 4)), "a"), data.table(a = c(1, 2), b = c(3, 4))) + + expect_equal(fmt_dbl(1.111), "1.11") + expect_equal(fmt_dbl(1.111, 1), "1.1") + expect_equal(fmt_int(1), "1.0") + expect_equal(fmt_int(1, 0), "1") + + expect_equal(wday(as.Date("2020-01-01")), 3L) + expect_equal(as.character(wday(as.Date("2020-01-01"), label = TRUE)), "Wednesday") + + expect_equal(str_trunc("abcdefghij", 10), "abcde...") + + expect_equal(match_in_vec("a", LETTERS), 1L) + expect_equal(match_in_vec("a", LETTERS, "aa"), 1L) + expect_equal(match_in_vec("a", LETTERS, "aa", label = TRUE), "A") + expect_equal(match_in_vec("aa", LETTERS, "aa", label = TRUE), "A") +}) From 29b45391676dbd7873b3851f6056b413b1b51b5c Mon Sep 17 00:00:00 2001 From: Hongyuan Jia Date: Sat, 11 Apr 2020 18:00:13 +0800 Subject: [PATCH 04/43] [refactor] Refactor eplusr.R --- R/eplusr.R | 242 ---------------------------------- R/options.R | 213 ++++++++++++++++++++++++++++++ R/utils.R | 22 ++-- R/zzz.R | 2 - man/eplusr_option.Rd | 2 +- man/with_option.Rd | 2 +- tests/testthat/test_install.R | 2 +- tests/testthat/test_options.R | 10 +- 8 files changed, 232 insertions(+), 263 deletions(-) create mode 100644 R/options.R diff --git a/R/eplusr.R b/R/eplusr.R index ec582fbc2..9bdd88f64 100644 --- a/R/eplusr.R +++ b/R/eplusr.R @@ -31,245 +31,3 @@ #' @name eplusr-package #' @author Hongyuan Jia "_PACKAGE" - -# check_color {{{ -check_color <- function () { - (.globals$color <- has_color()) -} -# }}} - -# package level global constant {{{ -.globals <- new.env(parent = emptyenv()) - -# for storing internal data -.globals$eplus_config <- list() -.globals$idd <- list() -# }}} - -# package level mutable global options -.options <- new.env(parent = emptyenv()) -.options$verbose_info <- TRUE -.options$validate_level <- "final" -.options$view_in_ip <- FALSE -.options$save_format <- "asis" -.options$num_parallel <- parallel::detectCores() -.options$autocomplete <- interactive() - -#' Get and Set eplusr options -#' -#' Get and set eplusr options which affect the way in which eplusr computes and -#' displays its results. -#' -#' @param ... Any available options to define, using `name = value`. All -#' available options are shown below. If no options are given, all values of -#' current options are returned. If a single option name, its value is returned. -#' -#' @details -#' * `validate_level`: The strictness level of validation during field value -#' modification and model error checking. Possible value: `"none"`, -#' `"draft"` and `"final"` or a custom validation level using -#' [custom_validate()]. Default: `"final"`. For what validation -#' components each level contains, see [level_checks()]. -#' -#' * `view_in_ip`: Whether models should be presented in IP units. Default: -#' `FALSE`. It is not recommended to set this option to `TRUE` as currently -#' IP-units support in eplusr is not fully tested. -#' -#' * `save_format`: The default format to use when saving Idf objects to `.idf` files. -#' Possible values: `"asis"`, `"sorted"`, `"new_top"` and `"new_bottom"`. -#' The later three have the same effect as `Save Options` settings -#' `"Sorted"`, `"Original with New at Top"` and `"Original with New at -#' Bottom"` in IDF Editor, respectively. For `"asis"`, the saving format -#' will be set according to the header of IDF file. If no header found, -#' `"sorted"` is used. Default: `"asis"`. -#' -#' * `num_parallel`: Maximum number of parallel simulations to run. Default: -#' `parallel::detectCores()`. -#' -#' * `verbose_info`: Whether to show information messages. Default: `TRUE`. -#' -#' * `autocomplete`: Whether to turn on autocompletion on class and field names. -#' Underneath, [makeActiveBinding()] is used to add or move active bindings in -#' [Idf] and [IdfObject]s to directly return objects in class or field values. -#' This will make it possible to dynamically show current class and field -#' names in both RStudio and in the terminal. However, this process does have -#' a penalty on the performance. It can make adding or modifying large mounts -#' of [Idf] and [IdfObject]s extremely slower. Default: `interactive()`. -#' -#' @return If called directly, a named list of input option values. If input is -#' a single option name, a length-one vector whose type is determined by -#' that option. If input is new option values, a named list of newly set -#' option values. -#' @examples -#' # list all current options -#' eplusr_option() # a named list -#' -#' # get a specific option value -#' eplusr_option("verbose_info") -#' -#' # set options -#' eplusr_option(verbose_info = TRUE, view_in_ip = FALSE) -#' @export -#' @author Hongyuan Jia -# eplusr_option {{{ -eplusr_option <- function (...) { - opt <- list(...) - - if (is_empty(opt)) return(as.list.environment(.options, sorted = TRUE)) - - nm <- names(opt) - - if (is_empty(nm)) { - nm <- unlist(opt) - assert(is_string(nm), prefix = "option") - return(.options[[nm]]) - } - - if ("num_digits" %in% nm) { - warn("warning_eplusr_deprecated_opt", - paste0("Option `num_digits` has been deprecated. ", - "The formatting of numeric fields are not handled by R itself." - ) - ) - nm <- nm[nm != "num_digits"] - opt <- opt[nm != "num_digits"] - if (!length(nm)) return(as.list.environment(.options)) - } - - assert(nm %in% names(.options), - msg = paste0("Invalid option name found: ", collapse(nm[!nm %in% names(.options)]), ".") - ) - - choice_opt <- c("save_format") - choice_list <- list( - save_format = c("asis", "sorted", "new_top", "new_bot") - ) - - onoff_opt <- c("view_in_ip", "verbose_info", "autocomplete") - - count_opt <- c("num_parallel") - - # assign_onoff_opt {{{ - assign_onoff_opt <- function (input, name) { - if (length(input[[name]])) { - assert(is_scalar(input[[name]]), prefix = name) - assert(is_flag(input[[name]]), prefix = name) - .options[[name]] <- input[[name]] - } - } - # }}} - # assign_choice_opt {{{ - assign_choice_opt <- function (input, name) { - if (not_empty(input[[name]])) { - assert(is_string(input[[name]]), prefix = name) - assert(input[[name]] %in% choice_list[[name]], - msg = paste0(surround(name), " should be one of ", - collapse(choice_list[[name]]) - ) - ) - - .options[[name]] <- input[[name]] - } - } - # }}} - # assign_count_opt {{{ - assign_count_opt <- function (input, name) { - if (not_empty(input[[name]])) { - assert(is_count(input[[name]]), prefix = name) - .options[[name]] <- as.integer(input[[name]]) - } - } - # }}} - - for (nm_opt in choice_opt) assign_choice_opt(opt, nm_opt) - for (nm_opt in onoff_opt) assign_onoff_opt(opt, nm_opt) - for (nm_opt in count_opt) assign_count_opt(opt, nm_opt) - - # validate level - if ("validate_level" %in% nm) { - level <- opt[["validate_level"]] - if (is_string(level) && level %in% c("none", "draft", "final")) { - .options[["validate_level"]] <- level - } else { - .options[["validate_level"]] <- level_checks(level) - } - } - - as.list.environment(.options)[nm] -} -# }}} - -#' Evaluate an expression with temporary eplusr options -#' -#' These functions evaluate an expression with temporary eplusr options -#' -#' `with_option` evaluates an expression with specified eplusr options. -#' -#' `with_silent` evaluates an expression with no verbose messages. -#' -#' `without_checking` evaluates an expression with no checkings. -#' -#' `with_speed` evaluates an expression with no checkings and autocompletion -#' functionality. -#' -#' @param opts A list of valid input for `eplusr::eplusr_option()`. -#' @param expr An expression to be evaluated. -#' @name with_option -#' @export -#' @examples -#' \dontrun{ -#' path_idf <- system.file("extdata/1ZoneUncontrolled.idf", package = "eplusr") -#' -#' # temporarily disable verbose messages -#' idf <- with_silent(read_idf(path_idf, use_idd(8.8, download = "auto"))) -#' -#' # temporarily disable checkings -#' without_checking(idf$'BuildingSurface:Detailed' <- NULL) -#' # OR -#' with_option(list(validate_level = "none"), idf$'BuildingSurface:Detailed' <- NULL) -#' } -#' -# with_option {{{ -with_option <- function (opts, expr) { - # get options - ori <- eplusr_option() - - if (!is.list(opts) || is.null(names(opts))) { - stop("`opts` should be a named list.") - } - - if (any(!names(opts) %in% names(ori))) { - stop("Invalid eplusr option found: ", sQuote(names(opts)[!names(opts) %in% names(ori)])) - } - - # set new option values - on.exit(do.call(eplusr_option, ori), add = TRUE) - do.call(eplusr_option, opts) - - force(expr) -} -# }}} - -#' @name with_option -#' @export -# with_silent {{{ -with_silent <- function (expr) { - with_option(list(verbose_info = FALSE), expr) -} -# }}} - -#' @name with_option -#' @export -# with_speed {{{ -with_speed <- function (expr) { - with_option(list(validate_level = "none", autocomplete = FALSE), expr) -} -# }}} - -#' @name with_option -#' @export -# without_checking {{{ -without_checking <- function (expr) { - with_option(list(validate_level = "none"), expr) -} -# }}} diff --git a/R/options.R b/R/options.R new file mode 100644 index 000000000..398ab8931 --- /dev/null +++ b/R/options.R @@ -0,0 +1,213 @@ +# package level global constant {{{ +.globals <- new.env(parent = emptyenv()) + +# for storing internal data +.globals$eplus <- list() +.globals$idd <- list() +.globals$color <- has_color() +# }}} + +# package level mutable global options {{{ +.options <- new.env(parent = emptyenv()) +.options$verbose_info <- TRUE +.options$validate_level <- "final" +.options$view_in_ip <- FALSE +.options$save_format <- "asis" +.options$num_parallel <- parallel::detectCores() +.options$autocomplete <- interactive() +# }}} + +#' Get and Set eplusr options +#' +#' Get and set eplusr options which affect the way in which eplusr computes and +#' displays its results. +#' +#' @param ... Any available options to define, using `name = value`. All +#' available options are shown below. If no options are given, all values of +#' current options are returned. If a single option name, its value is returned. +#' +#' @details +#' * `validate_level`: The strictness level of validation during field value +#' modification and model error checking. Possible value: `"none"`, +#' `"draft"` and `"final"` or a custom validation level using +#' [custom_validate()]. Default: `"final"`. For what validation +#' components each level contains, see [level_checks()]. +#' +#' * `view_in_ip`: Whether models should be presented in IP units. Default: +#' `FALSE`. It is not recommended to set this option to `TRUE` as currently +#' IP-units support in eplusr is not fully tested. +#' +#' * `save_format`: The default format to use when saving Idf objects to `.idf` files. +#' Possible values: `"asis"`, `"sorted"`, `"new_top"` and `"new_bottom"`. +#' The later three have the same effect as `Save Options` settings +#' `"Sorted"`, `"Original with New at Top"` and `"Original with New at +#' Bottom"` in IDF Editor, respectively. For `"asis"`, the saving format +#' will be set according to the header of IDF file. If no header found, +#' `"sorted"` is used. Default: `"asis"`. +#' +#' * `num_parallel`: Maximum number of parallel simulations to run. Default: +#' `parallel::detectCores()`. +#' +#' * `verbose_info`: Whether to show information messages. Default: `TRUE`. +#' +#' * `autocomplete`: Whether to turn on autocompletion on class and field names. +#' Underneath, [makeActiveBinding()] is used to add or move active bindings in +#' [Idf] and [IdfObject]s to directly return objects in class or field values. +#' This will make it possible to dynamically show current class and field +#' names in both RStudio and in the terminal. However, this process does have +#' a penalty on the performance. It can make adding or modifying large mounts +#' of [Idf] and [IdfObject]s extremely slower. Default: `interactive()`. +#' +#' @return If called directly, a named list of input option values. If input is +#' a single option name, a length-one vector whose type is determined by +#' that option. If input is new option values, a named list of newly set +#' option values. +#' @examples +#' # list all current options +#' eplusr_option() # a named list +#' +#' # get a specific option value +#' eplusr_option("verbose_info") +#' +#' # set options +#' eplusr_option(verbose_info = TRUE, view_in_ip = FALSE) +#' @importFrom checkmate assert_count assert_choice assert_flag assert_subset +#' @importFrom checkmate assert_string test_choice +#' @export +#' @author Hongyuan Jia +# eplusr_option {{{ +eplusr_option <- function (...) { + opt <- list(...) + + if (!length(opt)) return(as.list.environment(.options, sorted = TRUE)) + + nm <- names(opt) + + if (!length(nm)) { + nm <- unlist(opt) + assert_string(nm, .var.name = "option") + return(.options[[nm]]) + } + + assert_subset(nm, names(.options), FALSE, .var.name = "option") + + choice_opt <- c("save_format") + choice_list <- list( + save_format = c("asis", "sorted", "new_top", "new_bot") + ) + + onoff_opt <- c("view_in_ip", "verbose_info", "autocomplete") + + count_opt <- c("num_parallel") + + # assign_onoff_opt {{{ + assign_onoff_opt <- function (input, name) { + if (length(input[[name]])) { + assert_flag(input[[name]], .var.name = name) + .options[[name]] <- input[[name]] + } + } + # }}} + # assign_choice_opt {{{ + assign_choice_opt <- function (input, name) { + if (length(input[[name]])) { + assert_choice(input[[name]], choice_list[[name]], .var.name = name) + .options[[name]] <- input[[name]] + } + } + # }}} + # assign_count_opt {{{ + assign_count_opt <- function (input, name) { + if (length(input[[name]])) { + assert_count(input[[name]], positive = TRUE, .var.name = name) + .options[[name]] <- as.integer(input[[name]]) + } + } + # }}} + + for (nm_opt in choice_opt) assign_choice_opt(opt, nm_opt) + for (nm_opt in onoff_opt) assign_onoff_opt(opt, nm_opt) + for (nm_opt in count_opt) assign_count_opt(opt, nm_opt) + + # validate level + if ("validate_level" %in% nm) { + level <- opt[["validate_level"]] + if (test_choice(level, c("none", "draft", "final"))) { + .options[["validate_level"]] <- level + } else { + .options[["validate_level"]] <- level_checks(level) + } + } + + as.list.environment(.options)[nm] +} +# }}} + +#' Evaluate an expression with temporary eplusr options +#' +#' These functions evaluate an expression with temporary eplusr options +#' +#' `with_option` evaluates an expression with specified eplusr options. +#' +#' `with_silent` evaluates an expression with no verbose messages. +#' +#' `without_checking` evaluates an expression with no checkings. +#' +#' `with_speed` evaluates an expression with no checkings and autocompletion +#' functionality. +#' +#' @param opts A list of valid input for `eplusr::eplusr_option()`. +#' @param expr An expression to be evaluated. +#' @name with_option +#' @export +#' @examples +#' \dontrun{ +#' path_idf <- system.file("extdata/1ZoneUncontrolled.idf", package = "eplusr") +#' +#' # temporarily disable verbose messages +#' idf <- with_silent(read_idf(path_idf, use_idd(8.8, download = "auto"))) +#' +#' # temporarily disable checkings +#' without_checking(idf$'BuildingSurface:Detailed' <- NULL) +#' # OR +#' with_option(list(validate_level = "none"), idf$'BuildingSurface:Detailed' <- NULL) +#' } +#' +# with_option {{{ +with_option <- function (opts, expr) { + assert_list(opts, names = "named") + # get options + ori <- eplusr_option() + assert_names(names(opts), subset.of = names(ori)) + + # set new option values + on.exit(do.call(eplusr_option, ori), add = TRUE) + do.call(eplusr_option, opts) + + force(expr) +} +# }}} + +#' @name with_option +#' @export +# with_silent {{{ +with_silent <- function (expr) { + with_option(list(verbose_info = FALSE), expr) +} +# }}} + +#' @name with_option +#' @export +# with_speed {{{ +with_speed <- function (expr) { + with_option(list(validate_level = "none", autocomplete = FALSE), expr) +} +# }}} + +#' @name with_option +#' @export +# without_checking {{{ +without_checking <- function (expr) { + with_option(list(validate_level = "none"), expr) +} +# }}} diff --git a/R/utils.R b/R/utils.R index b7a9f305e..6f8c677ad 100644 --- a/R/utils.R +++ b/R/utils.R @@ -17,7 +17,7 @@ collapse <- function (x, out = "'", or = FALSE) { s <- as.character(x) } else { out <- as.character(out) - if (is_scalar(out)) { + if (length(out) == 1L) { out <- c(out, out) } s <- paste0(out[1L], x, out[2L]) @@ -40,7 +40,7 @@ collapse <- function (x, out = "'", or = FALSE) { surround <- function (x, out = "'") { if (is.null(out)) return(as.character(x)) out <- as.character(out) - if (is_scalar(out)) { + if (length(out) == 1L) { out <- c(out, out) } paste0(out[1L], x, out[2L]) @@ -110,12 +110,13 @@ read_lines <- function(input, trim = TRUE, ...) { # write_lines {{{ # NOTE: IDFEditor will crash if a large IDF file was saved with LF eol on # Windows. +#' @importFrom checkmate assert_character assert_names write_lines <- function (x, file = "", append = FALSE) { if (inherits(x, "data.table")) { - assert(has_name(x, "string")) + assert_names(names(x), must.include = "string") fwrite(x[, list(string)], file = file, col.names = FALSE, quote = FALSE, append = append) } else { - checkmate::assert_character(x) + assert_character(x) fwrite(data.table(x), file = file, col.names = FALSE, quote = FALSE, append = append) } } @@ -162,6 +163,7 @@ standardize_ver <- function (ver, strict = FALSE, complete = TRUE) { # }}} # match_minor_ver {{{ +#' @importFrom checkmate assert_class assert_vector match_minor_ver <- function (ver, all_ver, type = c("idd", "eplus"), verbose = TRUE) { checkmate::assert_class(ver, "numeric_version") checkmate::assert_vector(ver, len = 1L) @@ -344,11 +346,12 @@ each_length <- function (x) { # }}} # ranger {{{ +#' @importFrom checkmate assert_number assert_flag ranger <- function (minimum = -Inf, lower_incbounds = FALSE, maximum = Inf, upper_incbounds = FALSE) { - assert(is_scalar(minimum) && is.numeric(minimum), - is_scalar(maximum) && is.numeric(maximum), - is_flag(lower_incbounds), is_flag(upper_incbounds) - ) + assert_number(minimum) + assert_number(maximum) + assert_flag(lower_incbounds) + assert_flag(upper_incbounds) setattr( list( minimum = minimum, lower_incbounds = lower_incbounds, @@ -360,8 +363,9 @@ ranger <- function (minimum = -Inf, lower_incbounds = FALSE, maximum = Inf, uppe # }}} # append_dt {{{ +#' @importFrom checkmate assert_names append_dt <- function (dt, new_dt, base_col = NULL) { - assert(has_name(new_dt, names(dt))) + assert_names(names(new_dt), must.include = names(dt)) if (is.null(base_col)) { rbindlist(list(dt, new_dt[, .SD, .SDcols = names(dt)])) diff --git a/R/zzz.R b/R/zzz.R index 769181ff7..4a63661ee 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -1,11 +1,9 @@ .onLoad <- function(libname, pkgname) { locate_eplus() reg_custom_units() - check_color() } .onAttach <- function(libname, pkgname) { locate_eplus() reg_custom_units() - check_color() } diff --git a/man/eplusr_option.Rd b/man/eplusr_option.Rd index 1812c9524..a5f4cd9df 100644 --- a/man/eplusr_option.Rd +++ b/man/eplusr_option.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/eplusr.R +% Please edit documentation in R/options.R \name{eplusr_option} \alias{eplusr_option} \title{Get and Set eplusr options} diff --git a/man/with_option.Rd b/man/with_option.Rd index 46678eb31..32808e61d 100644 --- a/man/with_option.Rd +++ b/man/with_option.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/eplusr.R +% Please edit documentation in R/options.R \name{with_option} \alias{with_option} \alias{with_silent} diff --git a/tests/testthat/test_install.R b/tests/testthat/test_install.R index 4574aa514..bdad3ace7 100644 --- a/tests/testthat/test_install.R +++ b/tests/testthat/test_install.R @@ -1,6 +1,6 @@ test_that("Install", { skip_on_cran() - expect_equal(as.character(avail_eplus()), names(.globals$eplus_config)) + expect_equal(as.character(avail_eplus()), names(.globals$eplus)) if (is_avail_eplus(8.8)) expect_error(install_eplus(8.8, local = TRUE)) if (is_macos()) expect_error(install_eplus(8.8, local = TRUE)) else install_eplus(8.8, local = TRUE, force = TRUE) diff --git a/tests/testthat/test_options.R b/tests/testthat/test_options.R index d56737080..04b934816 100644 --- a/tests/testthat/test_options.R +++ b/tests/testthat/test_options.R @@ -1,11 +1,7 @@ test_that("eplusr_option()", { - expect_error(eplusr_option(validate = TRUE), class = "error_not_%in%") - - expect_error(eplusr_option(validate_level = "wrong")) - - expect_error(eplusr_option(view_in_ip = 1), class = "error_not_flag") - - expect_warning(eplusr_option(num_digits = "a")) + expect_error(eplusr_option(validate = TRUE), "Must be a subset") + expect_error(eplusr_option(validate_level = "wrong"), "Must be element") + expect_error(eplusr_option(view_in_ip = 1), "Must be of type") expect_equal(eplusr_option(validate_level = custom_validate(required_object = TRUE)), list(validate_level = custom_validate(required_object = TRUE))) From 55f40b2871fce03f75b72c78110335ea071beaa8 Mon Sep 17 00:00:00 2001 From: Hongyuan Jia Date: Sat, 11 Apr 2020 21:13:43 +0800 Subject: [PATCH 05/43] [refactor] Tweak 'standardize_ver()' and 'match_minor_ver()' --- R/utils.R | 27 +++++++++++++++------------ tests/testthat/test_utils.R | 4 ++++ 2 files changed, 19 insertions(+), 12 deletions(-) diff --git a/R/utils.R b/R/utils.R index 6f8c677ad..3fe5cde0b 100644 --- a/R/utils.R +++ b/R/utils.R @@ -147,7 +147,7 @@ standardize_ver <- function (ver, strict = FALSE, complete = TRUE) { if (any(int)) ver[int] <- paste0(ver[int], ".0") } - ver <- numeric_version(ver, strict = FALSE) + if (!test_class(ver, "numeric_version")) ver <- numeric_version(ver, strict = FALSE) # only keep major.minor.patch, and remove others has_trail <- suppressWarnings(!is.na(ver[, 4L])) @@ -164,7 +164,7 @@ standardize_ver <- function (ver, strict = FALSE, complete = TRUE) { # match_minor_ver {{{ #' @importFrom checkmate assert_class assert_vector -match_minor_ver <- function (ver, all_ver, type = c("idd", "eplus"), verbose = TRUE) { +match_minor_ver <- function (ver, all_ver, type = c("idd", "eplus"), max = TRUE, verbose = TRUE) { checkmate::assert_class(ver, "numeric_version") checkmate::assert_vector(ver, len = 1L) if (!length(all_ver)) return(numeric_version(NA, strict = FALSE)) @@ -180,17 +180,20 @@ match_minor_ver <- function (ver, all_ver, type = c("idd", "eplus"), verbose = T if (!length(ver)) { ver <- numeric_version(NA, strict = FALSE) } else if (length(ver) > 1L) { - if (verbose) { - type <- match.arg(type) - key <- switch(type, idd = "IDD", eplus = "EnergyPlus") - - verbose_info("Multiple versions found for ", key, " v", ori_ver, ": ", - collapse(paste0("v", ver)), ". ", - "The last patched version v", max(ver), " will be used. ", - "Please explicitly give the full version if you want to use the other versions." - ) + if (max) { + ver <- max(ver) + + if (verbose) { + type <- match.arg(type) + key <- switch(type, idd = "IDD", eplus = "EnergyPlus") + + verbose_info("Multiple versions found for ", key, " v", ori_ver, ": ", + collapse(paste0("v", ver)), ". ", + "The last patched version v", max(ver), " will be used. ", + "Please explicitly give the full version if you want to use the other versions." + ) + } } - ver <- max(ver) } ver diff --git a/tests/testthat/test_utils.R b/tests/testthat/test_utils.R index c1a056de6..b6d6cd083 100644 --- a/tests/testthat/test_utils.R +++ b/tests/testthat/test_utils.R @@ -40,9 +40,13 @@ test_that("Utility functions", { expect_error(match_minor_ver(1), "numeric_version") expect_error(match_minor_ver(numeric_version(1:2)), "length 1") + expect_equal(match_minor_ver(numeric_version("0.0"), NULL), numeric_version(NA, strict = FALSE)) expect_equal(match_minor_ver(numeric_version("0.0"), ALL_IDD_VER), numeric_version(NA, strict = FALSE)) expect_equal(match_minor_ver(numeric_version("9.1"), ALL_IDD_VER), numeric_version("9.1.0")) expect_equal(match_minor_ver(numeric_version("9.0"), ALL_IDD_VER), numeric_version("9.0.1")) + expect_equal(match_minor_ver(numeric_version("9.0"), ALL_EPLUS_VER, max = FALSE, verbose = FALSE), + numeric_version(c("9.0.0", "9.0.1"))) + expect_equal(match_minor_ver(numeric_version("9.0.1"), ALL_EPLUS_VER), numeric_version("9.0.1")) expect_equal(vec_depth(NULL), 0L) expect_equal(vec_depth(character()), 1L) From e2183972c2f8829fbc80b249bfcbd51f4b5cfea6 Mon Sep 17 00:00:00 2001 From: Hongyuan Jia Date: Sun, 12 Apr 2020 02:32:25 +0800 Subject: [PATCH 06/43] [refactor] Refactor run.R --- NEWS.md | 3 + R/run.R | 457 ++++++++++++++++++-------------------- man/run_model.Rd | 146 ++++++------ tests/testthat/test_run.R | 153 +++++++++++++ 4 files changed, 446 insertions(+), 313 deletions(-) create mode 100644 tests/testthat/test_run.R diff --git a/NEWS.md b/NEWS.md index bdeace9bb..1c10a7eb4 100644 --- a/NEWS.md +++ b/NEWS.md @@ -116,6 +116,9 @@ * `EplusJob`, `EplusGroupJob` and `ParametricJob` will not parse input EPW files, but only validate their existences and store the paths (#215) +* `run_idf()` and `run_multi()` now return additional element/column called +* `version` which contain the versions of EnergyPlus that are called during + simulations ## Bug fixes diff --git a/R/run.R b/R/run.R index 08f66ea76..620aee354 100644 --- a/R/run.R +++ b/R/run.R @@ -44,7 +44,7 @@ NULL #' @author Hongyuan Jia # clean_wd {{{ clean_wd <- function (path) { - + assert_string(path) base <- tools::file_path_sans_ext(basename(path)) without_ext <- tools::file_path_sans_ext(path) wd <- dirname(path) @@ -82,98 +82,113 @@ clean_wd <- function (path) { #' Run simulations of EnergyPlus models. #' -#' `run_idf()` is a wrapper of EnergyPlus command line interface which enables to -#' run EnergyPlus model with different options. -#' -#' `run_multi()` provides the functionality of running multiple models in -#' parallel. -#' #' @param model A path (for `run_idf()`) or a vector of paths (for -#' `run_multi()`) of EnergyPlus IDF or IMF files. +#' `run_multi()`) of EnergyPlus IDF or IMF files. +#' #' @param weather A path (for `run_idf()`) or a vector of paths (for -#' `run_multi()`) of EnergyPlus EPW weather files. For `run_multi()`, -#' `weather` can also be a single EPW file path. In this case, that weather -#' will be used for all simulations; otherwise, `model` and `weather` should -#' have the same length. +#' `run_multi()`) of EnergyPlus EPW weather files. For `run_multi()`, +#' `weather` can also be a single EPW file path. In this case, that +#' weather will be used for all simulations; otherwise, `model` and +#' `weather` should have the same length. +#' #' @param output_dir Output directory path (for `rum_idf()`) or paths (for -#' `run_mult()`). If NULL, the directory of input model is used. For -#' `run_multi()`, `output_dir`, if not `NULL`, should have the same length -#' as `model`. Any duplicated combination of `model` and `output_dir` is -#' prohibited. -#' @param design_day Force design-day-only simulation. Default: `FALSE`. -#' @param annual Force design-day-only simulation. Default: `FALSE`. +#' `run_mult()`). If NULL, the directory of input model is used. For +#' `run_multi()`, `output_dir`, if not `NULL`, should have the same +#' length as `model`. Any duplicated combination of `model` and +#' `output_dir` is prohibited. +#' +#' @param design_day Force design-day-only simulation. For `rum_multi()`, +#' `design_day` can also be a logical vector which has the same length as +#' `model`. Default: `FALSE`. +#' +#' @param annual Force design-day-only simulation. For `rum_multi()`, +#' `annual` can also be a logical vector which has the same length as +#' `model`. Note that `design_day` and `annual` cannot be all `TRUE` at +#' the same time. Default: `FALSE`. +#' #' @param expand_obj Whether to run ExpandObject preprocessor before simulation. -#' Default: `TRUE`. +#' Default: `TRUE`. +#' #' @param echo Only applicable when `wait` is `TRUE`. Whether to show standard -#' output and error from EnergyPlus command line interface for `run_idf()` -#' and simulation status for `run_multi()`.Default: `TRUE`. +#' output and error from EnergyPlus command line interface for +#' `run_idf()` and simulation status for `run_multi()`. Default: `TRUE`. +#' #' @param wait If `TRUE`, R will hang on and wait all EnergyPlus simulations -#' finish. If `FALSE`, all EnergyPlus simulations are run in the background. -#' and a [processx::process] object is returned. Note that, if `FALSE`, R is -#' *not blocked* even when `echo` is `TRUE`. Default: `TRUE`. +#' finish. If `FALSE`, all EnergyPlus simulations are run in the +#' background, and a [process][processx::process] object is returned. +#' #' @param eplus An acceptable input (for `run_idf()`) or inputs (for -#' `run_multi()`) of [use_eplus()] and [eplus_config()]. If -#' `NULL`, which is the default, the version of EnergyPlus to use is -#' determined by the version of input model. For `run_multi()`, `eplus`, if not -#' `NULL`, should have the same length as `model`. +#' `run_multi()`) of [use_eplus()] and [eplus_config()]. If `NULL`, which +#' is the default, the version of EnergyPlus to use is determined by the +#' version of input model. For `run_multi()`, `eplus`, if not `NULL`, +#' should have the same length as `model`. #' #' @details #' +#' `run_idf()` is a wrapper of EnergyPlus command line interface which enables to +#' run EnergyPlus model with different options. +#' +#' `run_multi()` provides the functionality of running multiple models in +#' parallel. +#' #' `run_idf()` and `run_multi()` currently only support EnergyPlus v8.3 and -#' above. This is because eplusr uses EnergyPlus command line interface -#' which is a new feature as of EnergyPlus v8.3. -#' -#' For `run_idf()`, a named list will be returned: -#' -#' * `idf`: The path of IDF file -#' * `epw`: The path of EPW file -#' * `exit_status`: The exit code of the process if it has finished and NULL -#' otherwise. Always being `NULL` if `wait` is FALSE, but you can manually -#' get the exit code using the process object, i.e. -#' `process$get_exit_status()` after simulation *completed*. -#' * `start_time`: When the EnergyPlus process started. -#' * `end_time`: When the EnergyPlus process stopped. All being `NULL` if -#' `wait` is `FALSE`, but you can manually check EnergyPlus `stdout` to get -#' the simulation time -#' * `output_dir`: The simulation output directory -#' * `energyplus`: The path of EnergyPlus executable -#' * `stdout`: All standard output from EnergyPlus. Always being `NULL` if -#' `wait` is `FALSE`, but you can manually get all standard output using -#' `process$get_result()`, where `process` is the [processx::process] -#' object stored in returned element `process`. -#' * `stderr`: All standard error from EnergyPlus. Always being `NULL` if -#' `wait` is `FALSE`, but you can manually get all standard output using -#' `process$get_result()`, where `process` is the [processx::process] -#' object stored in returned element `process`. -#' * `process`: A [processx::process] object of current EnergyPlus simulation -#' -#' For `run_multi()`, if `wait` is `TRUE`, a -#' [data.table][data.table::data.table()] contains all data (excluding -#' `process`) with same column names as above, and also another two columns: -#' -#' * `index`: The index of simulation -#' * `status`: The status of simulation. Should be one of below: -#' - `"completed"`: the simulation job is completed successfully. -#' - `"failed"`: the simulation job ended with error. -#' - `"terminated"`: the simulation job started but was terminated. -#' - `"cancelled"`: the simulation job was cancelled, i.e. did not start -#' at all. -#' -#' For `run_multi()`, if `wait` is `FALSE`, a [r_process][callr::r_bg()] -#' object of background R process which handles all simulation jobs is -#' returned. You can check if the jobs are completed using `$is_alive()` and -#' get the final data.table using `$get_result()`. -#' -#' It is suggested to run simulations using [EplusJob] class and -#' [ParametricJob] class, which provide much more detailed controls -#' on the simulation and also methods to extract simulation outputs. -#' -#' @return A list for `run_idf()`. For `rum_multi()`, a -#' [data.table][data.table::data.table()] if `wait` is `TRUE` or a -#' [process][processx::process] if `wait` is `FALSE`. +#' above. This is because eplusr uses EnergyPlus command line interface which is +#' a new feature as of EnergyPlus v8.3. +#' +#' It is suggested to run simulations using [EplusJob] class and [EplusGroupJob] +#' class, which provide much more detailed controls on the simulation and also +#' methods to extract simulation outputs. +#' +#' @return +#' +#' * For `run_idf()`, a named list of 11 elements: +#' +#' | No. | Column | Type | Description | +#' | ---: | ----- | ----- | ----- | +#' | 1 | `idf` | `character(1)` | Full path of input IDF file | +#' | 2 | `epw` | `character(1)` or `NULL` | Full path of input EPW file | +#' | 3 | `version` | `character(1)` | Version of called EnergyPlus | +#' | 4 | `exit_status` | `integer(1)` or `NULL` | Exit status of EnergyPlus. `NULL` if terminated or `wait` is `FALSE` | +#' | 5 | `start_time` | `POSIXct(1)` | Start of time of simulation | +#' | 6 | `end_time` | `POSIXct(1)` or `NULL` | End of time of simulation. `NULL` if `wait` is `FALSE` | +#' | 7 | `output_dir` | `character(1)` | Full path of simulation output directory | +#' | 8 | `energyplus` | `character(1)` | Full path of called EnergyPlus executable | +#' | 9 | `stdout` | `character(1)` or `NULL` | Standard output of EnergyPlus during simulation | +#' | 10 | `stderr` | `character(1)` or `NULL` | Standard error of EnergyPlus during simulation | +#' | 11 | `process` | [process][processx::process] | A [process][processx::process] object which called EnergyPlus and ran the simulation | +#' +#' * For `rum_multi()`, if `wait` is TRUE, a +#' [data.table][data.table::data.table()] of 12 columns: +#' +#' | No. | Column | Type | Description | +#' | ---: | ----- | ----- | ----- | +#' | 1 | `index` | `integer` | Index of simuation | +#' | 2 | `status` | `character` | Simulation status | +#' | 3 | `idf` | `character` | Full path of input IDF file | +#' | 4 | `epw` | `character` | Full path of input EPW file. `NA` for design-day-only simulation | +#' | 5 | `version` | `character` | Version of EnergyPlus | +#' | 6 | `exit_status` | `integer` | Exit status of EnergyPlus. `NA` if terminated | +#' | 7 | `start_time` | `POSIXct` | Start of time of simulation | +#' | 8 | `end_time` | `POSIXct` | End of time of simulation. | +#' | 9 | `output_dir` | `character` | Full path of simulation output directory | +#' | 10 | `energyplus` | `character` | Full path of called EnergyPlus executable | +#' | 11 | `stdout` | `list` | Standard output of EnergyPlus during simulation | +#' | 12 | `stderr` | `list` | Standard error of EnergyPlus during simulation | +#' +#' For column `status`, there are 4 possible values: +#' - `"completed"`: the simulation job is completed successfully +#' - `"failed"`: the simulation job ended with error +#' - `"terminated"`: the simulation job started but was terminated +#' - `"cancelled"`: the simulation job was cancelled, i.e. did not start at all +#' +#' * For `run_multi()`, if `wait` is `FALSE`, a [r_process][callr::r_bg()] +#' object of background R process which handles all simulation jobs is +#' returned. You can check if the jobs are completed using `$is_alive()` and +#' get the final data.table using `$get_result()` method. #' #' @references #' [Running EnergyPlus from Command Line (EnergyPlus GitHub Repository)](https://github.com/NREL/EnergyPlus/blob/develop/doc/running-energyplus-from-command-line.md) +#' #' @examples #' \dontrun{ #' idf_path <- system.file("extdata/1ZoneUncontrolled.idf", package = "eplusr") @@ -210,22 +225,19 @@ run_idf <- function (model, weather, output_dir, design_day = FALSE, if (!is.null(weather)) weather <- normalizePath(weather, mustWork = TRUE) eplus <- eplus %||% as.character(get_idf_ver(read_lines(model))) - energyplus_exe <- eplus_exe(eplus) - - if (is_empty(eplus)) { + if (!length(eplus)) { stop("Missing version field in input IDF file. Failed to determine the ", "version of EnergyPlus to use.", call. = FALSE) } + energyplus_exe <- eplus_exe(eplus) + # get output directory if (is.null(output_dir)) output_dir <- dirname(model) output_dir <- normalizePath(output_dir, mustWork = FALSE) if (!dir.exists(output_dir)) { tryCatch(dir.create(output_dir, recursive = TRUE), - warning = function (w) { - stop("Failed to create output directory: ", - surround(output_dir), call. = FALSE) - } + warning = function (w) stop("Failed to create output directory: ", surround(output_dir)) ) } @@ -249,38 +261,39 @@ run_idf <- function (model, weather, output_dir, design_day = FALSE, res["epw"] <- list(weather) res$version <- as.character(eplus_config(eplus)$version) - res[c("idf", "epw", "exit_status", "start_time", "end_time", "output_dir", + res[c("idf", "epw", "version", "exit_status", "start_time", "end_time", "output_dir", "energyplus", "stdout", "stderr", "process")] } # }}} #' @export #' @rdname run_model +#' @importFrom checkmate assert_flag assert_logical # run_multi {{{ run_multi <- function (model, weather, output_dir, design_day = FALSE, annual = FALSE, wait = TRUE, echo = TRUE, eplus = NULL) { - assert(is_flag(wait)) - assert(is_flag(echo)) - - if (!is_scalar(model)) { - if (!is.null(weather) && !is_scalar(weather)) { - assert(have_same_len(model, weather)) + assert_flag(wait) + assert_flag(echo) + assert_logical(design_day, any.missing = FALSE) + assert_logical(annual, any.missing = FALSE) + + if (length(model) != 1L) { + if (!is.null(weather) && length(weather) != 1L) { + assert_same_len(model, weather) } - if (!is.null(eplus) && !is_scalar(eplus)) { - assert(have_same_len(model, eplus)) + if (!is.null(eplus) && length(eplus) != 1L) { + assert_same_len(model, eplus) } - if (!is_scalar(design_day)) { - assert(have_same_len(model, design_day)) - assert(is.logical(design_day), no_na(design_day)) + if (length(design_day) != 1L) { + assert_same_len(model, design_day) } - if (!is_scalar(annual)) { - assert(have_same_len(model, annual)) - assert(is.logical(annual), no_na(annual)) + if (length(annual) != 1L) { + assert_same_len(model, annual) } } if (any(annual & design_day)) { - abort("error_run_both_ddy_annual", "Cannot force both design-day and annual simulations.") + stop("Cannot force both design-day-only simulation and annual simulation at the same time") } model <- normalizePath(model, mustWork = TRUE) @@ -298,34 +311,30 @@ run_multi <- function (model, weather, output_dir, design_day = FALSE, } if (is.null(eplus)) { - ver_list <- lapply(model, function (x) { - as.character(get_idf_ver(read_lines(x))) - }) - ver_miss <- vapply(ver_list, is_empty, logical(1)) + ver_list <- lapply(model, function (x) as.character(get_idf_ver(read_lines(x)))) + ver_miss <- viapply(ver_list, length) == 0L if (any(ver_miss)) { - msg <- paste0(" ", seq_along(model)[ver_miss], "| ", surround(model[ver_miss]), + msg <- paste0(" #", lpad(seq_along(model)[ver_miss]), "| ", surround(model[ver_miss]), collapse = "\n") - abort("error_miss_idf_ver", paste0( - "Missing version field in input IDF file. Failed to determine the ", - "version of EnergyPlus to use:\n", msg - )) + stop("Missing version field in input IDF file. Failed to determine the ", + "version of EnergyPlus to use:\n", msg) } - eplus <- unlist(ver_list) + ver <- unlist(ver_list) + energyplus_exe <- vcapply(ver, eplus_exe) + } else { + energyplus_exe <- vcapply(eplus, eplus_exe) } - - energyplus_exe <- vapply(eplus, eplus_exe, FUN.VALUE = character(1)) + ver <- vcapply(ver, function (v) as.character(eplus_config(v)$version)) if (anyDuplicated(model) & is.null(output_dir)) { - abort("error_run_duplicated_model", - "`model` cannot have any duplications when `output_dir` is NULL." - ) + stop("'model' cannot have any duplications when 'output_dir' is NULL.") } if (is.null(output_dir)) { output_dir <- dirname(model) } else { - assert(have_same_len(model, output_dir)) + assert_same_len(model, output_dir) } output_dir <- normalizePath(output_dir, mustWork = FALSE) @@ -333,11 +342,8 @@ run_multi <- function (model, weather, output_dir, design_day = FALSE, jobs <- data.table::data.table(input_model = model, output_dir = output_dir) if (anyDuplicated(jobs)) - abort("error_run_duplicated_job", paste0( - "Duplication found in the combination of `model` and `output_dir`.", - " One model could not be run in the same output directory multiple ", - "times simultaneously." - )) + stop("Duplication found in the combination of 'model' and 'output_dir'. ", + "One model could not be run in the same output directory multiple times simultaneously.") d <- unique(output_dir[!dir.exists(output_dir)]) created <- vapply(d, dir.create, logical(1L), showWarnings = FALSE, recursive = TRUE) @@ -349,11 +355,12 @@ run_multi <- function (model, weather, output_dir, design_day = FALSE, jobs[, `:=`( energyplus = energyplus_exe, - model = copy_run_files(model, output_dir), + model = copy_run_files(model, output_dir), version = ver, index = .I, annual = annual, design_day = design_day )] + if (is.null(weather)) { - jobs[, `:=`(input_weather = NA_character_, weather = list(NULL))] + set(jobs, NULL, c("input_weather", "weather"), list(NA_character_, list(NULL))) } else { if (any(!is.na(input_weather))) { weather[!is.na(input_weather)] <- as.list( @@ -363,7 +370,7 @@ run_multi <- function (model, weather, output_dir, design_day = FALSE, ) ) } - jobs[, `:=`(input_weather = input_weather, weather = weather)] + set(jobs, NULL, c("input_weather", "weather"), list(input_weather, weather)) } options <- list(num_parallel = eplusr_option("num_parallel"), echo = echo) @@ -371,26 +378,12 @@ run_multi <- function (model, weather, output_dir, design_day = FALSE, if (wait) { run_parallel_jobs(jobs, options) } else { - ext_funs <- tempfile("eplusr_run_parallel_jobs_fun", fileext = ".eplusr_temp") - - base::dump(list = c("run_parallel_jobs", "kill_jobs", "schedule_next_sim", - "run_job", "are_all_completed", "handle_events", "sim_status", "clean_wd", - "energyplus", "is_string", "is_flag", "has_ext", "lpad", "surround", "assert", - "is_integer", "is_scalar"), - file = ext_funs - ) - # always echo in order to catch standard output and error options$echo <- TRUE - proc <- callr::r_bg(function (ext_funs, jobs, options) { - requireNamespace("data.table", quietly = TRUE) - source(ext_funs) - run_parallel_jobs(jobs, options) - }, args = list(ext_funs = ext_funs, jobs = jobs, options = options)) - - proc + callr::r_bg(function (jobs, options) { + eplusr:::run_parallel_jobs(jobs, options) + }, args = list(jobs = jobs, options = options)) } - } # }}} @@ -426,15 +419,16 @@ proc_print <- function(p, control = c(TRUE, TRUE)) { # reference: https://github.com/r-lib/revdepcheck/blob/master/R/event-loop.R run_parallel_jobs <- function(jobs, options) { if (nrow(jobs) == 0) return() - assert(is_integer(options$num_parallel)) + assert_count(options$num_parallel, positive = TRUE) ## Kill all child processes if we quit from this function on.exit(kill_jobs(jobs, options), add = TRUE) # initialize job status and worker - jobs[, `:=`(status = "waiting", index_str = lpad(index, "0"), process = list(), - stdout = list(), stderr = list(), exit_status = NA_integer_ - )] + set(jobs, NULL, c("status", "index_str", "process", "stdout", "stderr", "exit_status", "start_time", "end_time"), + list("waiting", lpad(jobs$index, "0"), list(), list(), list(), NA_integer_, as.POSIXct(NA), as.POSIXct(NA)) + ) + setindexv(jobs, "status") # Our global progress bar progress_bar <- progress::progress_bar$new( @@ -450,8 +444,8 @@ run_parallel_jobs <- function(jobs, options) { jobs <- run_job(jobs, options, progress_bar) } - num_head <- num_tail <- 0L - while (1) { + # Run until all simulation complete + while (TRUE) { if (are_all_completed(jobs)) break; progress_bar$tick(0) jobs <- handle_events(jobs, options, progress_bar) @@ -459,47 +453,39 @@ run_parallel_jobs <- function(jobs, options) { jobs <- run_job(jobs, options, progress_bar) } - jobs[, c("model", "weather") := NULL] - data.table::setnames(jobs, c("input_model", "input_weather"), c("idf", "epw")) + set(jobs, NULL, c("model", "weather"), NULL) + setnames(jobs, c("input_model", "input_weather"), c("idf", "epw")) - jobs[, .SD, .SDcols = c("index", "status", "idf", "epw", "exit_status", - "start_time", "end_time", "energyplus", "output_dir", "stdout", "stderr" + jobs[, .SD, .SDcols = c("index", "status", "idf", "epw", "version", "exit_status", + "start_time", "end_time", "output_dir", "energyplus", "stdout", "stderr" )] } # }}} # kill_jobs {{{ kill_jobs <- function(jobs, options) { - jobs[vapply(process, function (x) {!is.null(x) && x$is_alive()}, logical(1)), `:=`( + jobs[vlapply(process, function (x) !is.null(x) && x$is_alive()), `:=`( status = {for (p in process) p$kill(); "terminated"} )] - jobs[status %in% c("waiting", "ready"), `:=`(status = "cancelled")] - + jobs[J(c("waiting", "ready")), on = "status", status := "cancelled"] - if (any(jobs$status == "terminated")) { - jobs[status == "terminated", `:=`( + if (any(is_term <- jobs$status == "terminated")) { + jobs[is_term, `:=`( stdout = lapply(process, function (x) tryCatch(x$read_all_output_lines(), error = function (e) NA_character_)), stderr = lapply(process, function (x) tryCatch(x$read_all_error_lines(), error = function (e) NA_character_)), - exit_status = vapply(process, function (x) x$get_exit_status(), integer(1)) + exit_status = viapply(process, function (x) x$get_exit_status()) )] } if (options$echo) { - - if (any(jobs$status == "terminated")) { - terminated <- jobs[status == "terminated", - sim_status("terminate", index_str, model, weather) - ] - - cli::cat_line(terminated, col = "white", background_col = "red") + if (any(is_term)) { + terminated <- jobs[is_term, sim_status("terminate", index_str, model, weather)] + cat_line(terminated, col = "white", background_col = "red") } - if (any(jobs$status == "cancelled")) { - cancelled <- jobs[status == "cancelled", - sim_status("cancel", index_str, model, weather) - ] - - cli::cat_line(cancelled, col = "white", background_col = "red") + if (any(is_canc <- jobs$status == "cancelled")) { + cancelled <- jobs[is_canc, sim_status("cancel", index_str, model, weather)] + cat_line(cancelled, col = "white", background_col = "red") } } } @@ -512,9 +498,9 @@ schedule_next_sim <- function(jobs, options, progress_bar) { } # waiting -> running - ready <- jobs$status == "waiting" - if (any(ready)) { - jobs[jobs[ready, index[1L]], `:=`(status = "ready")] + # always schedule only one new job + if (any(ready <- jobs$status == "waiting")) { + set(jobs, jobs$index[ready][1L], "status", "ready") } jobs @@ -523,32 +509,27 @@ schedule_next_sim <- function(jobs, options, progress_bar) { # run_job {{{ run_job <- function(jobs, options, progress_bar) { # clean wd - lapply(jobs[status == "ready", model], clean_wd) + ready <- which(jobs$status == "ready") - jobs[status == "ready", `:=`(status = "newly_started", - process = list(energyplus(eplus = energyplus, model = model, - weather = unlist(weather), output_dir = output_dir, annual = annual, - design_day = design_day, wait = FALSE, echo = FALSE)$process) - )] + if (!length(ready)) return(jobs) - if (any(jobs$status == "newly_started")) { - completed <- jobs[status == "newly_started", - sim_status("run", index_str, model, weather) - ] + jobs[ready, c("status", "process", "start_time") := { + clean_wd(model) + + process <- energyplus(eplus = energyplus, model = model, + weather = unlist(weather), output_dir = output_dir, annual = annual, + design_day = design_day, wait = FALSE, echo = FALSE)$process if (options$echo) { - progress_bar$message(paste0(completed, collapse = "\n")) + run <- sim_status("run", index_str, model, weather) + progress_bar$message(paste0(run, collapse = "\n")) } progress_bar$tick(0) - } - jobs[status == "newly_started", `:=`(status = "running", - start_time = do.call("c", lapply(process, - function (x) lubridate::with_tz(x$get_start_time(), Sys.timezone()) - )) - )] + start_time <- lubridate::with_tz(process$get_start_time(), Sys.timezone()) - jobs + list(status = "running", process = list(process), start_time = start_time) + }] } # }}} # are_all_completed {{{ @@ -558,44 +539,39 @@ are_all_completed <- function(jobs) { # }}} # handle_events {{{ handle_events <- function(jobs, options, progress_bar) { - jobs[status == "running" & - vlapply(process, function (x) !is.null(x) && !x$is_alive()), + run <- jobs$status == "running" + if (!any(run)) return(jobs) + + jobs[run & vlapply(process, function (x) !is.null(x) && !x$is_alive()), c("stdout", "stderr", "exit_status", "status", "end_time") := { res <- lapply(process, function (p) p$get_result()) - exit_code <- viapply(process, function (x) x$get_exit_status()) + # somehow get_exit_status() function may return NA after execution # of a (successful) command - # https://github.com/r-lib/processx/issues/220 + # ref: https://github.com/r-lib/processx/issues/220 + exit_code <- viapply(process, function (x) x$get_exit_status()) exit_code[is.na(exit_code)] <- 0L - list(stdout = lapply(res, "[[", "stdout"), - stderr = lapply(res, "[[", "stderr"), - exit_status = exit_code, status = "newly_completed", end_time = Sys.time() - ) - } - ] - if (any(jobs$status == "newly_completed")) { - num <- sum(jobs$status == "newly_completed") + if (options$echo) { + comp <- sim_status("complete", index_str, model, weather, exit_code) + progress_bar$message(paste0(comp, collapse = "\n")) + } + progress_bar$tick(.N) - completed <- jobs[status == "newly_completed", - sim_status("complete", index_str, model, weather, exit_status) - ] + status[exit_code == 0L] <- "completed" + status[exit_code != 0L] <- "failed" - if (options$echo) { - progress_bar$message(paste0(completed, collapse = "\n")) + list(stdout = lapply(res, "[[", "stdout"), stderr = lapply(res, "[[", "stderr"), + exit_status = exit_code, status = status, end_time = Sys.time() + ) } - progress_bar$tick(num) - } - - jobs[status == "newly_completed", `:=`(status = ifelse(exit_status == 0L, "completed", "failed"))] - - jobs + ] } # }}} # sim_status {{{ sim_status <- function (type, index, model, weather, exit_code = NULL) { status <- c("run", "complete", "cancel", "terminate") - if (length(type) ==1L && type %in% status) { + if (length(type) == 1L && type %in% status) { type <- switch(type, run = "RUNNING ", complete = "COMPLETED ", @@ -619,6 +595,7 @@ sim_status <- function (type, index, model, weather, exit_code = NULL) { } # }}} # energyplus {{{ +#' @importFrom checkmate assert_flag assert_file_exists assert_directory_exists energyplus <- function (eplus, model, weather, output_dir, output_prefix = NULL, output_suffix = c("C", "L", "D"), expand_obj = TRUE, readvars = TRUE, annual = FALSE, design_day = FALSE, @@ -626,23 +603,21 @@ energyplus <- function (eplus, model, weather, output_dir, output_prefix = NULL, output_suffix <- match.arg(output_suffix) - assert( - file.exists(eplus), - file.exists(model), - is.null(weather) || file.exists(weather), - is.null(output_dir) || dir.exists(output_dir), - is.null(output_prefix) || is_string(output_prefix), - is_flag(expand_obj), - is_flag(readvars), - is_flag(annual), - is_flag(design_day), - is.null(idd) || file.exists(idd), - is_flag(echo), - is_flag(wait) - ) + assert_file_exists(eplus) + assert_file_exists(model) + assert_flag(expand_obj) + assert_flag(readvars) + assert_flag(annual) + assert_flag(design_day) + assert_flag(echo) + assert_flag(wait) + if (!is.null(weather)) assert_file_exists(weather) + if (!is.null(output_dir)) assert_directory_exists(output_dir, "w") + if (!is.null(output_prefix)) assert_string(output_prefix) + if (!is.null(idd)) assert_file_exists(idd) if (annual && design_day) { - stop("Cannot force both design-day and annual simulations.", call. = FALSE) + stop("Cannot force both design-day and annual simulations") } # argument docs {{{ @@ -771,6 +746,7 @@ energyplus <- function (eplus, model, weather, output_dir, output_prefix = NULL, stderr <- suppressWarnings(read_lines(p_stderr)$string) if (!length(stdout)) stdout <- character(0) if (!length(stderr)) stderr <- character(0) + unlink(c(p_stdout, p_stderr)) list(stdout = stdout, stderr = stderr, end_time = Sys.time()) } } @@ -870,12 +846,10 @@ eplus_exe <- function (eplus) { config <- tryCatch(eplus_config(eplus), warning = function (w) stop(w)) if (config$version < 8.3) { - abort("error_eplus_lower_8.3", paste( - "Currently, eplusr only supports running IDFs of EnergyPlus v8.3 and above. ", - "This is because eplusr uses EnergyPlus command line interface ", - "which is available only in EnergyPlus v8.3 and above. ", - "You can update the version of your model using `version_updater()` and try again." - )) + stop("Currently, eplusr only supports running IDFs of EnergyPlus v8.3 and above. ", + "This is because eplusr uses EnergyPlus command line interface ", + "which is available only in EnergyPlus v8.3 and above. ", + "You can update the version of your model using 'transition()' or 'version_updater()' and try again.") } normalizePath(file.path(config$dir, config$exe), mustWork = TRUE) @@ -889,7 +863,7 @@ copy_run_files <- function (file, dir) { if (all(file == loc)) return(file) - copy <- unique(data.table::data.table(from = file, to = loc)) + copy <- unique(data.table(from = file, to = loc)) flag <- apply2_int(copy$from, copy$to, file.copy, more_args = list(overwrite = TRUE, copy.date = TRUE) ) @@ -898,7 +872,7 @@ copy_run_files <- function (file, dir) { stop("Unable to copy file ", surround(basename(file[!flag])), "into ", "simulation output directory.", call. = FALSE) - return(loc) + loc } # }}} # get_run_time {{{ @@ -906,7 +880,6 @@ get_run_time <- function (stdout) { last <- stdout[length(stdout)] period <- lubridate::hms(last, quiet = TRUE) - if (is.na(period)) return(NULL) - period + if (is.na(period)) NULL else period } # }}} diff --git a/man/run_model.Rd b/man/run_model.Rd index 3a2b9f272..1a447445f 100644 --- a/man/run_model.Rd +++ b/man/run_model.Rd @@ -34,103 +34,107 @@ run_multi( \item{weather}{A path (for \code{run_idf()}) or a vector of paths (for \code{run_multi()}) of EnergyPlus EPW weather files. For \code{run_multi()}, -\code{weather} can also be a single EPW file path. In this case, that weather -will be used for all simulations; otherwise, \code{model} and \code{weather} should -have the same length.} +\code{weather} can also be a single EPW file path. In this case, that +weather will be used for all simulations; otherwise, \code{model} and +\code{weather} should have the same length.} \item{output_dir}{Output directory path (for \code{rum_idf()}) or paths (for \code{run_mult()}). If NULL, the directory of input model is used. For -\code{run_multi()}, \code{output_dir}, if not \code{NULL}, should have the same length -as \code{model}. Any duplicated combination of \code{model} and \code{output_dir} is -prohibited.} +\code{run_multi()}, \code{output_dir}, if not \code{NULL}, should have the same +length as \code{model}. Any duplicated combination of \code{model} and +\code{output_dir} is prohibited.} -\item{design_day}{Force design-day-only simulation. Default: \code{FALSE}.} +\item{design_day}{Force design-day-only simulation. For \code{rum_multi()}, +\code{design_day} can also be a logical vector which has the same length as +\code{model}. Default: \code{FALSE}.} -\item{annual}{Force design-day-only simulation. Default: \code{FALSE}.} +\item{annual}{Force design-day-only simulation. For \code{rum_multi()}, +\code{annual} can also be a logical vector which has the same length as +\code{model}. Note that \code{design_day} and \code{annual} cannot be all \code{TRUE} at +the same time. Default: \code{FALSE}.} \item{expand_obj}{Whether to run ExpandObject preprocessor before simulation. Default: \code{TRUE}.} \item{wait}{If \code{TRUE}, R will hang on and wait all EnergyPlus simulations -finish. If \code{FALSE}, all EnergyPlus simulations are run in the background. -and a \link[processx:process]{processx::process} object is returned. Note that, if \code{FALSE}, R is -\emph{not blocked} even when \code{echo} is \code{TRUE}. Default: \code{TRUE}.} +finish. If \code{FALSE}, all EnergyPlus simulations are run in the +background, and a \link[processx:process]{process} object is returned.} \item{echo}{Only applicable when \code{wait} is \code{TRUE}. Whether to show standard -output and error from EnergyPlus command line interface for \code{run_idf()} -and simulation status for \code{run_multi()}.Default: \code{TRUE}.} +output and error from EnergyPlus command line interface for +\code{run_idf()} and simulation status for \code{run_multi()}. Default: \code{TRUE}.} \item{eplus}{An acceptable input (for \code{run_idf()}) or inputs (for -\code{run_multi()}) of \code{\link[=use_eplus]{use_eplus()}} and \code{\link[=eplus_config]{eplus_config()}}. If -\code{NULL}, which is the default, the version of EnergyPlus to use is -determined by the version of input model. For \code{run_multi()}, \code{eplus}, if not -\code{NULL}, should have the same length as \code{model}.} +\code{run_multi()}) of \code{\link[=use_eplus]{use_eplus()}} and \code{\link[=eplus_config]{eplus_config()}}. If \code{NULL}, which +is the default, the version of EnergyPlus to use is determined by the +version of input model. For \code{run_multi()}, \code{eplus}, if not \code{NULL}, +should have the same length as \code{model}.} } \value{ -A list for \code{run_idf()}. For \code{rum_multi()}, a -\link[data.table:data.table]{data.table} if \code{wait} is \code{TRUE} or a -\link[processx:process]{process} if \code{wait} is \code{FALSE}. +\itemize{ +\item For \code{run_idf()}, a named list of 11 elements:\tabular{rlll}{ + No. \tab Column \tab Type \tab Description \cr + 1 \tab \code{idf} \tab \code{character(1)} \tab Full path of input IDF file \cr + 2 \tab \code{epw} \tab \code{character(1)} or \code{NULL} \tab Full path of input EPW file \cr + 3 \tab \code{version} \tab \code{character(1)} \tab Version of called EnergyPlus \cr + 4 \tab \code{exit_status} \tab \code{integer(1)} or \code{NULL} \tab Exit status of EnergyPlus. \code{NULL} if terminated or \code{wait} is \code{FALSE} \cr + 5 \tab \code{start_time} \tab \code{POSIXct(1)} \tab Start of time of simulation \cr + 6 \tab \code{end_time} \tab \code{POSIXct(1)} or \code{NULL} \tab End of time of simulation. \code{NULL} if \code{wait} is \code{FALSE} \cr + 7 \tab \code{output_dir} \tab \code{character(1)} \tab Full path of simulation output directory \cr + 8 \tab \code{energyplus} \tab \code{character(1)} \tab Full path of called EnergyPlus executable \cr + 9 \tab \code{stdout} \tab \code{character(1)} or \code{NULL} \tab Standard output of EnergyPlus during simulation \cr + 10 \tab \code{stderr} \tab \code{character(1)} or \code{NULL} \tab Standard error of EnergyPlus during simulation \cr + 11 \tab \code{process} \tab \link[processx:process]{process} \tab A \link[processx:process]{process} object which called EnergyPlus and ran the simulation \cr } -\description{ -\code{run_idf()} is a wrapper of EnergyPlus command line interface which enables to -run EnergyPlus model with different options. + +\item For \code{rum_multi()}, if \code{wait} is TRUE, a +\link[data.table:data.table]{data.table} of 12 columns:\tabular{rlll}{ + No. \tab Column \tab Type \tab Description \cr + 1 \tab \code{index} \tab \code{integer} \tab Index of simuation \cr + 2 \tab \code{status} \tab \code{character} \tab Simulation status \cr + 3 \tab \code{idf} \tab \code{character} \tab Full path of input IDF file \cr + 4 \tab \code{epw} \tab \code{character} \tab Full path of input EPW file. \code{NA} for design-day-only simulation \cr + 5 \tab \code{version} \tab \code{character} \tab Version of EnergyPlus \cr + 6 \tab \code{exit_status} \tab \code{integer} \tab Exit status of EnergyPlus. \code{NA} if terminated \cr + 7 \tab \code{start_time} \tab \code{POSIXct} \tab Start of time of simulation \cr + 8 \tab \code{end_time} \tab \code{POSIXct} \tab End of time of simulation. \cr + 9 \tab \code{output_dir} \tab \code{character} \tab Full path of simulation output directory \cr + 10 \tab \code{energyplus} \tab \code{character} \tab Full path of called EnergyPlus executable \cr + 11 \tab \code{stdout} \tab \code{list} \tab Standard output of EnergyPlus during simulation \cr + 12 \tab \code{stderr} \tab \code{list} \tab Standard error of EnergyPlus during simulation \cr } -\details{ -\code{run_multi()} provides the functionality of running multiple models in -parallel. -\code{run_idf()} and \code{run_multi()} currently only support EnergyPlus v8.3 and -above. This is because eplusr uses EnergyPlus command line interface -which is a new feature as of EnergyPlus v8.3. -For \code{run_idf()}, a named list will be returned: +For column \code{status}, there are 4 possible values: \itemize{ -\item \code{idf}: The path of IDF file -\item \code{epw}: The path of EPW file -\item \code{exit_status}: The exit code of the process if it has finished and NULL -otherwise. Always being \code{NULL} if \code{wait} is FALSE, but you can manually -get the exit code using the process object, i.e. -\code{process$get_exit_status()} after simulation \emph{completed}. -\item \code{start_time}: When the EnergyPlus process started. -\item \code{end_time}: When the EnergyPlus process stopped. All being \code{NULL} if -\code{wait} is \code{FALSE}, but you can manually check EnergyPlus \code{stdout} to get -the simulation time -\item \code{output_dir}: The simulation output directory -\item \code{energyplus}: The path of EnergyPlus executable -\item \code{stdout}: All standard output from EnergyPlus. Always being \code{NULL} if -\code{wait} is \code{FALSE}, but you can manually get all standard output using -\code{process$get_result()}, where \code{process} is the \link[processx:process]{processx::process} -object stored in returned element \code{process}. -\item \code{stderr}: All standard error from EnergyPlus. Always being \code{NULL} if -\code{wait} is \code{FALSE}, but you can manually get all standard output using -\code{process$get_result()}, where \code{process} is the \link[processx:process]{processx::process} -object stored in returned element \code{process}. -\item \code{process}: A \link[processx:process]{processx::process} object of current EnergyPlus simulation +\item \code{"completed"}: the simulation job is completed successfully +\item \code{"failed"}: the simulation job ended with error +\item \code{"terminated"}: the simulation job started but was terminated +\item \code{"cancelled"}: the simulation job was cancelled, i.e. did not start at all +} +\item For \code{run_multi()}, if \code{wait} is \code{FALSE}, a \link[callr:r_bg]{r_process} +object of background R process which handles all simulation jobs is +returned. You can check if the jobs are completed using \verb{$is_alive()} and +get the final data.table using \verb{$get_result()} method. } - -For \code{run_multi()}, if \code{wait} is \code{TRUE}, a -\link[data.table:data.table]{data.table} contains all data (excluding -\code{process}) with same column names as above, and also another two columns: -\itemize{ -\item \code{index}: The index of simulation -\item \code{status}: The status of simulation. Should be one of below: -\itemize{ -\item \code{"completed"}: the simulation job is completed successfully. -\item \code{"failed"}: the simulation job ended with error. -\item \code{"terminated"}: the simulation job started but was terminated. -\item \code{"cancelled"}: the simulation job was cancelled, i.e. did not start -at all. } +\description{ +Run simulations of EnergyPlus models. } +\details{ +\code{run_idf()} is a wrapper of EnergyPlus command line interface which enables to +run EnergyPlus model with different options. -For \code{run_multi()}, if \code{wait} is \code{FALSE}, a \link[callr:r_bg]{r_process} -object of background R process which handles all simulation jobs is -returned. You can check if the jobs are completed using \verb{$is_alive()} and -get the final data.table using \verb{$get_result()}. +\code{run_multi()} provides the functionality of running multiple models in +parallel. + +\code{run_idf()} and \code{run_multi()} currently only support EnergyPlus v8.3 and +above. This is because eplusr uses EnergyPlus command line interface which is +a new feature as of EnergyPlus v8.3. -It is suggested to run simulations using \link{EplusJob} class and -\link{ParametricJob} class, which provide much more detailed controls -on the simulation and also methods to extract simulation outputs. +It is suggested to run simulations using \link{EplusJob} class and \link{EplusGroupJob} +class, which provide much more detailed controls on the simulation and also +methods to extract simulation outputs. } \examples{ \dontrun{ diff --git a/tests/testthat/test_run.R b/tests/testthat/test_run.R new file mode 100644 index 000000000..271b0aa02 --- /dev/null +++ b/tests/testthat/test_run.R @@ -0,0 +1,153 @@ +test_that("clean_wd()", { + expect_true(file.create(f <- tempfile())) + expect_true({clean_wd(f); file.exists(f)}) + unlink(f) + + expect_true(file.create(f <- tempfile(fileext = ".idf"))) + expect_silent({clean_wd(f); file.exists(f)}) + unlink(f) + + expect_true(file.create(f <- file.path(tempdir(), "in.idf"))) + expect_silent({clean_wd(f); file.exists(f)}) + unlink(f) +}) + +test_that("run_idf()", { + if (!is_avail_eplus(8.8)) install_eplus(8.8) + + path_idf <- system.file("extdata/1ZoneUncontrolled.idf", package = "eplusr") + path_epw <- file.path(eplus_config(8.8)$dir, "WeatherData", "USA_CA_San.Francisco.Intl.AP.724940_TMY3.epw") + + # can run ddy simulation + expect_silent(res <- run_idf(path_idf, NULL, output_dir = tempdir(), echo = FALSE)) + # can specify EnergyPlus version + expect_silent(res <- run_idf(path_idf, NULL, output_dir = tempdir(), echo = FALSE, eplus = 8.8)) + expect_null(res$epw) + # can stop if failed to find version + expect_error({ + f <- tempfile(fileext = ".idf") + write_lines(read_lines(path_idf)[-91], f) + run_idf(f, NULL, output_dir = tempdir(), echo = FALSE) + }, "Missing version field") + # can use input file directory + expect_silent({ + f <- tempfile(fileext = ".idf") + file.copy(path_idf, f, overwrite = TRUE) + res <- run_idf(f, NULL, output_dir = NULL, echo = FALSE) + }) + # can create output directory if not exists + expect_equal({ + d <- tempfile() + res <- run_idf(path_idf, NULL, output_dir = d, echo = FALSE) + res$output_dir + }, d) + + # can run simulation with weather + expect_silent(res <- run_idf(path_idf, path_epw, output_dir = tempdir(), echo = FALSE)) + + expect_equal(res$idf, normalizePath(path_idf)) + expect_equal(res$epw, normalizePath(path_epw)) + expect_equal(res$version, "8.8.0") + expect_equal(res$exit_status, 0L) + expect_is(res$start_time, "POSIXct") + expect_is(res$end_time, "POSIXct") + expect_equal(res$output_dir, tempdir()) + expect_equal(res$energyplus, normalizePath(file.path(eplus_config(8.8)$dir, eplus_config(8.8)$exe), mustWork = TRUE)) + expect_is(res$stdout, "character") + expect_null(res$stderr) + expect_is(res$process, "process") + expect_true(file.exists(file.path(tempdir(), basename(res$idf)))) + expect_true(file.exists(file.path(tempdir(), basename(res$epw)))) + + # can run in the background + expect_silent(res <- run_idf(path_idf, NULL, output_dir = tempdir(), wait = FALSE)) + expect_equal(res$idf, normalizePath(path_idf)) + expect_null(res$epw) + expect_equal(res$version, "8.8.0") + expect_null(res$exit_status) + expect_is(res$start_time, "POSIXct") + expect_null(res$end_time) + expect_equal(res$output_dir, tempdir()) + expect_equal(res$energyplus, normalizePath(file.path(eplus_config(8.8)$dir, eplus_config(8.8)$exe), mustWork = TRUE)) + expect_null(res$stdout) + expect_null(res$stderr) + expect_is(res$process, "process") + expect_silent(res_post <- res$process$get_result()) + expect_is(res_post$stdout, "character") + expect_is(res_post$stderr, "character") +}) + +test_that("run_multi()", { + if (!is_avail_eplus(8.8)) install_eplus(8.8) + + path_idf <- system.file("extdata/1ZoneUncontrolled.idf", package = "eplusr") + path_epw <- file.path(eplus_config(8.8)$dir, "WeatherData", "USA_CA_San.Francisco.Intl.AP.724940_TMY3.epw") + + # can stop if idf and epw does not have the same length + expect_error(run_multi(rep(path_idf, 2), rep(path_epw, 3)), "Must have same length") + # can stop if idf and eplus does not have the same length + expect_error(run_multi(rep(path_idf, 2), NULL, eplus = rep(8.8, 3)), "Must have same length") + # can stop if idf and design does not have the same length + expect_error(run_multi(rep(path_idf, 2), NULL, design_day = rep(FALSE, 3)), "Must have same length") + # can stop if idf and annual does not have the same length + expect_error(run_multi(rep(path_idf, 2), NULL, annual = rep(FALSE, 3)), "Must have same length") + # can stop if both design and annual is TRUE + expect_error(run_multi(path_idf, NULL, annual = TRUE, design_day = TRUE), "both design-day-only") + # can stop if model does not exist + expect_error(run_multi("", NULL), "No such file or directory") + # can stop if model does not contain version + expect_error({ + f <- tempfile(fileext = ".idf") + write_lines(read_lines(path_idf)[-91], f) + run_multi(f, NULL, output_dir = tempdir()) + }, "Failed to determine the version of EnergyPlus") + # can stop if target EnergyPlus is not found + expect_error(run_multi(path_idf, NULL, eplus = 8.0), "Cannot locate EnergyPlus") + # can stop if input idf contain duplications + expect_error(run_multi(rep(path_idf, 2L), NULL, output_dir = NULL), "Have any duplication") + # can stop if idf and output directory does not have the same length + expect_error(run_multi(rep(path_idf, 2L), NULL, output_dir = tempdir()), "have same length") + # can stop if idf and output directory combines same job + expect_error(run_multi(rep(path_idf, 2L), NULL, output_dir = rep(tempdir(), 2L)), "Duplication found") + + expect_message(res <- run_multi(rep(path_idf, 2L), NULL, output_dir = c(file.path(tempdir(), "a"), file.path(tempdir(), "b"))), + "FAILED" + ) + expect_is(res, "data.table") + expect_equal(names(res), c("index", "status", "idf", "epw", "version", + "exit_status", "start_time", "end_time", "output_dir", "energyplus", + "stdout", "stderr")) + expect_equal(res$index, 1:2) + expect_equal(res$status, rep("failed", 2)) + expect_equal(res$idf, rep(path_idf, 2)) + expect_equal(res$epw, rep(NA_character_, 2)) + expect_equal(res$version, rep("8.8.0", 2)) + expect_equal(res$exit_status > 0, rep(TRUE, 2)) + expect_is(res$start_time, "POSIXct") + expect_is(res$end_time, "POSIXct") + expect_equal(res$output_dir, c(file.path(tempdir(), "a"), file.path(tempdir(), "b"))) + expect_equal(res$energyplus, rep(normalizePath(file.path(eplus_config(8.8)$dir, eplus_config(8.8)$exe), mustWork = TRUE), 2L)) + checkmate::expect_list(res$stdout, "character") + checkmate::expect_list(res$stderr, "character") + + expect_silent(res <- run_multi(rep(path_idf, 2L), NULL, output_dir = c(file.path(tempdir(), "a"), file.path(tempdir(), "b")), wait = FALSE)) + expect_is(res, "r_process") + expect_equal(res$get_exit_status(), 0L) + expect_silent(res <- res$get_result()) + expect_is(res, "data.table") + expect_equal(names(res), c("index", "status", "idf", "epw", "version", + "exit_status", "start_time", "end_time", "output_dir", "energyplus", + "stdout", "stderr")) + expect_equal(res$index, 1:2) + expect_equal(res$status, rep("failed", 2)) + expect_equal(res$idf, rep(path_idf, 2)) + expect_equal(res$epw, rep(NA_character_, 2)) + expect_equal(res$version, rep("8.8.0", 2)) + expect_equal(res$exit_status > 0, rep(TRUE, 2)) + expect_is(res$start_time, "POSIXct") + expect_is(res$end_time, "POSIXct") + expect_equal(res$output_dir, c(file.path(tempdir(), "a"), file.path(tempdir(), "b"))) + expect_equal(res$energyplus, rep(normalizePath(file.path(eplus_config(8.8)$dir, eplus_config(8.8)$exe), mustWork = TRUE), 2L)) + checkmate::expect_list(res$stdout, "character") + checkmate::expect_list(res$stderr, "character") +}) From 753d264e804ad2c49a8b64c0905f04857c8c14d5 Mon Sep 17 00:00:00 2001 From: Hongyuan Jia Date: Sun, 12 Apr 2020 20:57:15 +0800 Subject: [PATCH 07/43] [refactor] Refactor parse.R --- DESCRIPTION | 3 +- NAMESPACE | 2 + R/parse.R | 283 ++++++++++++++++-------------------- tests/testthat/test_parse.R | 88 ++++++----- 4 files changed, 183 insertions(+), 193 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index dd9bf53cb..08135f0e9 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -22,7 +22,7 @@ Imports: callr (>= 2.0.4), cli (>= 1.1.0), crayon, - data.table (>= 1.9.8), + data.table (>= 1.12.4), lubridate, methods, processx (>= 3.2.0), @@ -73,6 +73,7 @@ Collate: 'impl-sql.R' 'install.R' 'job.R' + 'options.R' 'param.R' 'rdd.R' 'reload.R' diff --git a/NAMESPACE b/NAMESPACE index 6a7b52ca8..d0d481d70 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -175,6 +175,7 @@ importFrom(data.table,setDT) importFrom(data.table,setattr) importFrom(data.table,setcolorder) importFrom(data.table,setindexv) +importFrom(data.table,setnafill) importFrom(data.table,setnames) importFrom(data.table,setorder) importFrom(data.table,setorderv) @@ -214,6 +215,7 @@ importFrom(stringi,stri_endswith_fixed) importFrom(stringi,stri_extract_first_regex) importFrom(stringi,stri_isempty) importFrom(stringi,stri_length) +importFrom(stringi,stri_locate_first_charclass) importFrom(stringi,stri_locate_first_fixed) importFrom(stringi,stri_locate_first_regex) importFrom(stringi,stri_match_first_regex) diff --git a/R/parse.R b/R/parse.R index 8939d2100..3ef67be46 100644 --- a/R/parse.R +++ b/R/parse.R @@ -2,18 +2,19 @@ #' @importFrom data.table ":=" "%chin%" #' @importFrom data.table between chmatch data.table dcast.data.table last #' @importFrom data.table rbindlist rowidv rleid set setattr setcolorder -#' @importFrom data.table setnames setorder setindexv +#' @importFrom data.table setnames setorder setindexv setnafill #' @importFrom stringi stri_count_charclass stri_count_fixed stri_detect_fixed #' @importFrom stringi stri_endswith_fixed stri_extract_first_regex stri_isempty #' @importFrom stringi stri_length stri_locate_first_fixed stri_replace_all_fixed #' @importFrom stringi stri_startswith_charclass stri_startswith_fixed #' @importFrom stringi stri_split_charclass stri_split_fixed stri_sub stri_subset_fixed #' @importFrom stringi stri_trans_tolower stri_trans_toupper stri_trim_both -#' @importFrom stringi stri_trim_left stri_trim_right +#' @importFrom stringi stri_trim_left stri_trim_right stri_locate_first_charclass #' @include impl.R NULL # IDD_SLASHKEY {{{ +# nocov start IDD_SLASHKEY <- list ( class = list( flat = c("unique-object", "required-object", "min-fields", "format", @@ -41,20 +42,26 @@ IDD_SLASHKEY <- list ( "reference") ) ) +# nocov end # }}} # IDDFIELD_TYPE {{{ +# nocov start IDDFIELD_TYPE <- list( integer = 1L, real = 2L, choice = 3L, alpha = 4L, object_list = 5L, node = 6L, external_list = 7L ) +# nocov end # }}} # IDDFIELD_SOURCE {{{ +# nocov start IDDFIELD_SOURCE <- list(none = 0L, class = 1L, field = 2L, mixed = 3L) +# nocov end # }}} # CLASS_COLS {{{ +# nocov start # names of class columns, mainly used for cleaning unuseful columns CLASS_COLS <- list( index = c("class_id", "class_name", "class_name_us", "group_id"), @@ -63,9 +70,11 @@ CLASS_COLS <- list( "num_extensible", "first_extensible", "num_extensible_group" ) ) +# nocov end # }}} # FIELD_COLS {{{ +# nocov start # names of field columns FIELD_COLS <- list( index = c("field_id", "class_id", "field_index", "field_name", "field_name_us"), @@ -77,13 +86,14 @@ FIELD_COLS <- list( "default_chr", "default_num", "choice", "note" ) ) - +# nocov end # }}} # parse_idd_file {{{ parse_idd_file <- function(path) { # read idd string, get idd version and build idd_dt <- read_lines(path) + idd_version <- get_idd_ver(idd_dt) idd_build <- get_idd_build(idd_dt) @@ -144,25 +154,25 @@ parse_idd_file <- function(path) { dt_field <- dt$left dt_reference <- dt$reference - # add index - setindexv(dt_group, "group_id") - setindexv(dt_group, "group_name") + # # add index + # setindexv(dt_group, "group_id") + # setindexv(dt_group, "group_name") - setindexv(dt_class, "class_id") - setindexv(dt_class, "class_name") - setindexv(dt_class, "class_name_us") + # setindexv(dt_class, "class_id") + # setindexv(dt_class, "class_name") + # setindexv(dt_class, "class_name_us") - setindexv(dt_field, "field_id") - setindexv(dt_field, "field_name") - setindexv(dt_field, "field_name_us") - setindexv(dt_field, c("class_id", "field_index")) - setindexv(dt_field, c("class_id", "field_name")) - setindexv(dt_field, c("class_id", "field_name_us")) + # setindexv(dt_field, "field_id") + # setindexv(dt_field, "field_name") + # setindexv(dt_field, "field_name_us") + # setindexv(dt_field, c("class_id", "field_index")) + # setindexv(dt_field, c("class_id", "field_name")) + # setindexv(dt_field, c("class_id", "field_name_us")) - setindexv(dt_reference, "class_id") - setindexv(dt_reference, "field_id") - setindexv(dt_reference, "src_class_id") - setindexv(dt_reference, "src_field_id") + # setindexv(dt_reference, "class_id") + # setindexv(dt_reference, "field_id") + # setindexv(dt_reference, "src_class_id") + # setindexv(dt_reference, "src_field_id") list(version = idd_version, build = idd_build, group = dt_group, class = dt_class, field = dt_field, @@ -182,8 +192,7 @@ parse_idf_file <- function (path, idd = NULL, ref = TRUE) { if (has_ext(path, "ddy")) { idd <- withCallingHandlers(get_idd_from_ver(idf_ver, idd), - warning_given_idd_used = function (w) invokeRestart("muffleWarning"), - warning_latest_idd_used = function (w) invokeRestart("muffleWarning") + warning = function (w) invokeRestart("muffleWarning") ) } else { idd <- get_idd_from_ver(idf_ver, idd) @@ -247,28 +256,28 @@ parse_idf_file <- function (path, idd = NULL, ref = TRUE) { c("value_id", "value_chr", "value_num", "object_id", "field_id")), NULL ) - # set index - setindexv(dt_object, "class_id") - setindexv(dt_object, "object_id") - setindexv(dt_object, "object_name") - setindexv(dt_object, "object_name_lower") - setindexv(dt_object, c("class_id", "object_id")) - setindexv(dt_object, c("class_id", "object_name")) - setindexv(dt_object, c("class_id", "object_name_lower")) - - setindexv(dt_value, "field_id") - setindexv(dt_value, "value_id") - setindexv(dt_value, "value_chr") - setindexv(dt_value, c("object_id", "field_id")) - setindexv(dt_value, c("object_id", "value_id")) - setindexv(dt_value, c("object_id", "value_chr")) - - setindexv(dt_reference, "object_id") - setindexv(dt_reference, "value_id") - setindexv(dt_reference, c("object_id", "value_id")) - setindexv(dt_reference, "src_object_id") - setindexv(dt_reference, "src_value_id") - setindexv(dt_reference, c("src_object_id", "src_value_id")) + # # set index + # setindexv(dt_object, "class_id") + # setindexv(dt_object, "object_id") + # setindexv(dt_object, "object_name") + # setindexv(dt_object, "object_name_lower") + # setindexv(dt_object, c("class_id", "object_id")) + # setindexv(dt_object, c("class_id", "object_name")) + # setindexv(dt_object, c("class_id", "object_name_lower")) + + # setindexv(dt_value, "field_id") + # setindexv(dt_value, "value_id") + # setindexv(dt_value, "value_chr") + # setindexv(dt_value, c("object_id", "field_id")) + # setindexv(dt_value, c("object_id", "value_id")) + # setindexv(dt_value, c("object_id", "value_chr")) + + # setindexv(dt_reference, "object_id") + # setindexv(dt_reference, "value_id") + # setindexv(dt_reference, c("object_id", "value_id")) + # setindexv(dt_reference, "src_object_id") + # setindexv(dt_reference, "src_value_id") + # setindexv(dt_reference, c("src_object_id", "src_value_id")) list(version = idd_ver, options = options, object = dt_object, value = dt_value, reference = dt_reference @@ -277,54 +286,38 @@ parse_idf_file <- function (path, idd = NULL, ref = TRUE) { # }}} # get_idd_ver {{{ +#' @importFrom checkmate assert_data_table assert_names get_idd_ver <- function (idd_dt) { - assert(inherits(idd_dt, "data.table"), has_name(idd_dt, c("line", "string"))) + ver_line <- idd_dt$string[[1L]] - ver_line <- idd_dt[stri_startswith_fixed(string, "!IDD_Version")] - - if (!nrow(ver_line)) { - abort("error_miss_idd_ver", "No version found in input IDD.") - } else if (nrow(ver_line) == 1L) { - ver <- tryCatch(standardize_ver(stri_sub(ver_line$string, 14L)), - error = function (e) { - m <- conditionMessage(e) - if (stri_startswith_fixed(m, "invalid version specification")) { - parse_issue("error_invalid_idd_ver", "idd", "Invalid IDD version", ver_line) - } else { - stop(e) - } - } - ) - standardize_ver(ver) + if (!stri_startswith_fixed(ver_line, "!IDD_Version")) { + stop("No version found in input IDD.") } else { - parse_issue("error_multi_idd_ver", "idd", "Multiple versions found", ver_line) + ver <- standardize_ver(stri_sub(ver_line, 14L)) + + if (is.na(ver)) parse_error("idd", "Invalid IDD version", idd_dt[1L]) + + ver } } # }}} # get_idd_build {{{ +#' @importFrom checkmate assert_data_table assert_names get_idd_build <- function (idd_dt) { - assert(inherits(idd_dt, "data.table"), has_name(idd_dt, c("line", "string"))) + build_line <- idd_dt$string[[2L]] - build_line <- idd_dt[stri_startswith_fixed(string, "!IDD_BUILD")] - - if (!nrow(build_line)) { - warn("warning_miss_idd_build", "No build tag found in input IDD.") + if (!stri_startswith_fixed(build_line, "!IDD_BUILD")) { + warning("No build tag found in input IDD.") NA_character_ - } else if (nrow(build_line) == 1L) { - build <- stri_sub(build_line$string, 12L) } else { - parse_issue("error_multi_idd_build", "idd", "Multiple build tags found", build_line) + stri_sub(build_line, 12L) } } # }}} # get_idf_ver {{{ -get_idf_ver <- function (idf_dt, empty_removed = TRUE) { - assert(inherits(idf_dt, "data.table"), has_name(idf_dt, c("line", "string"))) - - if (!empty_removed) idf_dt <- idf_dt[!stri_isempty(string)] - +get_idf_ver <- function (idf_dt) { is_ver <- stri_startswith_fixed(idf_dt$string, "Version", opts_fixed = stringi::stri_opts_fixed(case_insensitive = TRUE) ) @@ -347,24 +340,24 @@ get_idf_ver <- function (idf_dt, empty_removed = TRUE) { } else if (nrow(ver_line) == 1L) { standardize_ver(ver_line$version, complete = FALSE) } else { - parse_issue("error_multiple_version", "idf", "Multiple versions found", ver_line) + parse_error("idf", "Multiple versions found", ver_line) } } # }}} # clean_idd_lines {{{ clean_idd_lines <- function (dt) { - dt <- dt[!(stri_startswith_fixed(string, "!") | stri_isempty(string))] - # trucate to characters left of ! in order to handle cases when there are # inline comments starting with "!", e.g. # "GrouhdHeatTransfer:Basement:EquivSlab, ! Supplies ..." - set(dt, NULL, "excl_loc", stri_locate_first_fixed(dt$string, "!")[, 1L]) - dt[!J(NA_integer_), on = "excl_loc", `:=`( - string = stri_trim_right(stri_sub(string, to = excl_loc - 1L))) - ] + excl_loc <- stri_locate_first_fixed(dt[["string"]], "!")[, 1L] + i <- which(!is.na(excl_loc)) + if (length(i)) set(dt, i, "string", stri_trim_right(stri_sub(dt[["string"]][i], to = excl_loc[i] - 1L))) + + # remove empty lines + i <- which(!stri_isempty(dt[["string"]])) + if (length(i)) dt <- .Call(data.table:::CsubsetDT, dt, i, seq_along(dt)) - set(dt, NULL, "excl_loc", NULL) dt } # }}} @@ -384,17 +377,9 @@ sep_idd_lines <- function (dt, col = "string") { slash = stri_trim_left(stri_sub(string, slash_loc + 1L)) )] - # locate first space and colon - dt[, `:=`( - space_loc = stri_locate_first_fixed(slash, " ")[, 1L], - colon_loc = stri_locate_first_fixed(slash, ":")[, 1L] - )] - dt[(colon_loc < space_loc) | (is.na(space_loc) & !is.na(colon_loc)), - `:=`(space_loc = colon_loc) - ] - dt[J(NA_integer_), on = "space_loc", `:=`(space_loc = 0L)] - # separate slash key and values + set(dt, NULL, "space_loc", stri_locate_first_charclass(dt$slash, "[\\:\\ ]")[, 1L]) + data.table::setnafill(dt, fill = 0L, cols = "space_loc") dt[!J(NA_integer_), on = "slash_loc", `:=`( slash_key = stri_trans_tolower(stri_sub(slash, to = space_loc - 1L)), slash_value = stri_trim_left(stri_sub(slash, space_loc + 1L)) @@ -419,7 +404,7 @@ sep_idd_lines <- function (dt, col = "string") { refs <- dt[J(c("reference-class-name", "reference")), on = "slash_key", unique(slash_value), nomatch = 0L] invld_objlst <- which(dt$slash_key == "object-list" & !dt$slash_value %chin% refs) if (length(invld_objlst)) { - parse_issue("error_object_list_value", "idd", "Invalid \\object-list value", dt[invld_objlst], + parse_error("idd", "Invalid \\object-list value", dt[invld_objlst], post = "Neither paired \\reference nor \\reference-class-name exist for \\object-list above." ) } @@ -427,7 +412,7 @@ sep_idd_lines <- function (dt, col = "string") { # check invalid slash keys invld_key <- dt[!J(c(NA_character_, unlist(IDD_SLASHKEY$type))), on = "slash_key", which = TRUE] if (length(invld_key)) - parse_issue("error_slash_key", "idd", "Invalid slash key", dt[invld_key]) + parse_error("idd", "Invalid slash key", dt[invld_key]) # check invalid slash value {{{ set(dt, NULL, "slash_value_lower", stri_trans_tolower(dt[["slash_value"]])) @@ -438,7 +423,7 @@ sep_idd_lines <- function (dt, col = "string") { "compactschedule", "fluidproperty", "viewfactor", "spectral") ) if (length(invld_val)) - parse_issue("error_format_value", "idd", "Invalid format value", dt[invld_val]) + parse_error("idd", "Invalid format value", dt[invld_val]) # check invalid \type value invld_val <- which( @@ -447,7 +432,7 @@ sep_idd_lines <- function (dt, col = "string") { "object-list", "external-list", "node") ) if (length(invld_val)) - parse_issue("error_type_value", "idd", "Invalid type value", dt[invld_val]) + parse_error("idd", "Invalid type value", dt[invld_val]) # check invalid \external-list value invld_val <- which( @@ -455,10 +440,10 @@ sep_idd_lines <- function (dt, col = "string") { !dt$slash_value_lower %chin% c("autorddvariable", "autorddmeter", "autorddvariablemeter") ) if (length(invld_val)) - parse_issue("error_external_list_value", "idd", "Invalid external list value", dt[invld_val]) + parse_error("idd", "Invalid external list value", dt[invld_val]) # }}} - set(dt, NULL, c("slash", "slash_loc", "space_loc", "colon_loc", "slash_value_lower"), NULL) + set(dt, NULL, c("slash", "slash_loc", "space_loc", "slash_value_lower"), NULL) dt } @@ -499,7 +484,7 @@ mark_idd_lines <- function (dt, type_enum) { # if there are still known lines, throw an error if (any(dt$type == type_enum$unknown)) { - parse_issue("error_unknown_line", "idd", "Invalid line", dt[type == type_enum$unknown]) + parse_error("idd", "Invalid line", dt[type == type_enum$unknown]) } set(dt, NULL, "semicolon", NULL) @@ -517,9 +502,8 @@ sep_group_table <- function (dt, type_enum) { # assign default group if necessary if (!nrow(dt_group)) { - parse_issue("warning_no_group", "idd", "Missing group name", num = 1L, - post = "No `\\group` key found. All classes will be assgined to a group named `Default Group`. ", - stop = FALSE + parse_warn("idd", "Missing group name", num = 1L, + post = "No '\\group' key found. All classes will be assgined to a group named 'Default Group'." ) set(dt, NULL, c("group_id", "group_name"), list(1L, "Default Group")) @@ -529,9 +513,9 @@ sep_group_table <- function (dt, type_enum) { # check missing group if (any(dt$line < dt_group$line[1L])) { invld_grp <- dt[line < dt_group$line[1L]] - parse_issue("warning_missing_group", "idd", "Missing group name", - invld_grp, invld_grp[type == type_enum$class, .N], stop = FALSE, - post = "Those classes will be assgined to a group named `Default Group`. ", + parse_warn("idd", "Missing group name", + invld_grp, invld_grp[type == type_enum$class, .N], + post = "Those classes will be assgined to a group named 'Default Group'.", ) dt[invld_grp, on = "line", `:=`(group_id = 1L, group_name = "Default Group")] @@ -564,9 +548,7 @@ sep_class_table <- function (dt, type_enum) { dup_cls <- dt[J(type_enum$class), on = "type", line[duplicated(class_name)], nomatch = 0L] if (length(dup_cls)) { invld_cls <- dt[class_name %in% dt[line %in% dup_cls, class_name]] - parse_issue("error_duplicated_class", "idd", "Duplicated class names found", - invld_cls, length(dup_cls) - ) + parse_error("idd", "Duplicated class names found", invld_cls, length(dup_cls)) } # fill downwards @@ -575,9 +557,7 @@ sep_class_table <- function (dt, type_enum) { # check missing class name if (anyNA(dt$class_id)) { invld_cls <- dt[is.na(class_id)] - parse_issue("error_missing_class", "idd", "Missing class name", - invld_cls, invld_cls[type == type_enum$field_last, .N] - ) + parse_error("idd", "Missing class name", invld_cls, invld_cls[type == type_enum$field_last, .N]) } # add expected type indicator @@ -601,14 +581,14 @@ sep_class_table <- function (dt, type_enum) { } else { n <- invld_cls[type == type_enum$field_last, .N] + 1L } - parse_issue("error_missing_class", "idd", "Missing class name", invld_cls, n) + parse_error("idd", "Missing class name", invld_cls, n) } # check incomplete class incomp_cls <- dt[J(type_enum$field, type_enum$field_last), on = c("type", "type_exp"), class_id, nomatch = 0L] if (length(incomp_cls)) { invld_cls <- dt[class_id %in% incomp_cls] - parse_issue("error_incomplete_class", "idd", "Incomplete class", invld_cls, length(incomp_cls)) + parse_error("idd", "Incomplete class", invld_cls, length(incomp_cls)) } # after checking possible errors, resign type @@ -720,10 +700,9 @@ get_field_table <- function (dt, type_enum) { # }}} # dcast_slash {{{ +#' @importFrom checkmate assert_names dcast_slash <- function (dt, id, keys, keep = NULL) { - assert(has_name(dt, id)) - assert(has_name(keys, c("flat", "nest"))) - if (!is.null(keep)) assert(has_name(dt, keep)) + if (!is.null(keep)) assert_names(names(dt), must.include = keep) f <- stats::as.formula(paste0(paste0(id[[1L]], collapse = "+"), "~slash_key")) @@ -733,26 +712,17 @@ dcast_slash <- function (dt, id, keys, keep = NULL) { i <- unique(dt[, .SD, .SDcols = c(id, keep)], by = c(id[[1L]])) setindexv(i, id[[1L]]) - # only use the first line of flat slash value - i_flat <- data.table::CJ(i[[id[[1L]]]], slash_key = keys$flat) - setnames(i_flat, "V1", id[[1L]]) - flat <- dt[i_flat, on = c(id[[1L]], "slash_key"), nomatch = 0L, mult = "first", - .SD, .SDcols = c(id[[1L]], "slash_key", "slash_value")] - if (nrow(flat)) flat <- dcast.data.table(flat, f, value.var = "slash_value") - setindexv(flat, id[[1L]]) + flat <- unique(dt[J(keys$flat), on = "slash_key", nomatch = 0L], by = c(id[[1L]], "slash_key")) + if (nrow(flat)) flat <- dcast.data.table(flat , f, value.var = "slash_value") nest <- dt[J(keys$nest), on = "slash_key", nomatch = 0L, {list(slash_value = list(slash_value))}, by = c(id[[1L]], "slash_key") ] if (nrow(nest)) nest <- dcast.data.table(nest, f, value.var = "slash_value") - setindexv(nest, id[[1L]]) # combine if (nrow(flat) && nrow(nest)) { - cbind( - # here use all i columns - flat[i, on = c(id[[1L]])], - # since flat gets all columns in i, here enable to simplify + set(flat[i, on = c(id[[1L]])], NULL, setdiff(names(nest), id[[1L]]), nest[J(i[[id[[1L]]]]), on = c(id[[1L]]), .SD, .SDcols = -id[[1L]]] ) } else if (!nrow(flat)) { @@ -806,7 +776,7 @@ complete_property <- function (dt, type, ref) { # add missing property columns if necessary for (key in unlist(keys, use.names = FALSE)) { - if (!has_name(dt, key)) set(dt, NULL, key, slash_init_value(key)) + if (!has_names(dt, key)) set(dt, NULL, key, slash_init_value(key)) } dt <- switch(type, @@ -924,7 +894,7 @@ parse_field_property_extensible_group <- function (dt, ref) { ext <- ext[, list(first_extensible = field_index[1L]), by = class_id] # handle the case when there is no extensible fields - if (!has_name(ref, "extensible") | !nrow(ext)) { + if (!has_names(ref, "extensible") | !nrow(ext)) { set(dt, NULL, "extensible_group", 0L) return(dt) } @@ -1141,8 +1111,7 @@ mark_idf_lines <- function (dt, type_enum) { })] if (nrow(dt[type == type_enum$macro])) { - parse_issue("warning_macro_line", "idf", "Marco lines found", - dt[type == type_enum$macro], stop = FALSE, + parse_warn("idf", "Marco lines found", dt[type == type_enum$macro], post = paste0( "Currently, IMF is not fully supported. All ", "EpMacro lines will be treated as normal comments of ", @@ -1166,7 +1135,7 @@ mark_idf_lines <- function (dt, type_enum) { # if there are still known lines, throw an error if (nrow(dt[type == type_enum$unknown]) > 0L) { - parse_issue("error_unknown_line", "idf", "Invalid line found", dt[type == type_enum$unknown]) + parse_error("idf", "Invalid line found", dt[type == type_enum$unknown]) } dt @@ -1235,7 +1204,7 @@ sep_object_table <- function (dt, type_enum, version, idd) { # check incomplete object incomp_obj <- dt[is.na(object_id) & type >= type_enum$value] if (nrow(incomp_obj)) { - parse_issue("error_incomplete_object", "idf", "Incomplete object", dt[is.na(object_id)], 1L) + parse_error("idf", "Incomplete object", dt[is.na(object_id)], 1L) } # extract class names @@ -1267,16 +1236,14 @@ sep_object_table <- function (dt, type_enum, version, idd) { # if multiple version found, stop if (length(id_ver) > 1L) { - parse_issue("error_multiple_version", "idf", "Multiple IDF Version found", - dt[object_id %in% id_ver], length(id_ver) - ) + parse_error("idf", "Multiple IDF Version found", dt[object_id %in% id_ver], length(id_ver)) } # }}} # check invalid class name invld_obj <- dt[is.na(class_id) & !is.na(class_name_lower)] if (nrow(invld_obj)) { - parse_issue("error_invalid_class", "idf", "Invalid class name", invld_obj) + parse_error("idf", "Invalid class name", invld_obj) } # fill class id and class name @@ -1380,8 +1347,7 @@ get_value_table <- function (dt, idd) { # modify message msg <- gsub(" *#\\d+\\|", "-->", gsub("index", "number", fld$message)) - parse_issue("error_invalid_field_number", "idf", "Invalid field number", - dt[J(obj), on = "object_id"], post = msg) + parse_error("idf", "Invalid field number", dt[J(obj), on = "object_id"], post = msg) } # bind columns @@ -1415,7 +1381,7 @@ update_object_name <- function (dt_object, dt_value) { list(object_name = value_chr, object_name_lower = stri_trans_tolower(value_chr)), by = "object_id"] if (!nrow(dt_nm)) { - if (!has_name(dt_object, "object_name")) { + if (!has_names(dt_object, "object_name")) { return(set(dt_object, NULL, c("object_name", "object_name_lower"), NA_character_)) } else { return(dt_object) @@ -1433,11 +1399,11 @@ convert_value_unit <- function (idd_env, dt_value, from, to, type = "value") { if (identical(from, to)) return(dt_value) - if (!has_name(dt_value, "units")) { + if (!has_names(dt_value, "units")) { add_field_property(idd_env, dt_value, "units") on.exit(set(dt_value, NULL, "units", NULL), add = TRUE) } - if (!has_name(dt_value, "ip_units")) { + if (!has_names(dt_value, "ip_units")) { add_field_property(idd_env, dt_value, "ip_units") on.exit(set(dt_value, NULL, "ip_units", NULL), add = TRUE) } @@ -1556,7 +1522,15 @@ get_value_reference_map <- function (map, src, value, all = TRUE) { # }}} # parse_issue {{{ -parse_issue <- function (error_type, type = c("idf", "idd", "err", "epw"), +parse_warn <- function (type = c("idf", "idd", "err", "epw"), title, data = NULL, + num = NULL, prefix = NULL, post = NULL) { + parse_issue(type, title, data, num, prefix, post, stop = FALSE) +} +parse_error <- function (type = c("idf", "idd", "err", "epw"), title, data = NULL, + num = NULL, prefix = NULL, post = NULL) { + parse_issue(type, title, data, num, prefix, post, stop = TRUE) +} +parse_issue <- function (type = c("idf", "idd", "err", "epw"), title, data = NULL, num = NULL, prefix = NULL, post = NULL, stop = TRUE) { @@ -1567,7 +1541,7 @@ parse_issue <- function (error_type, type = c("idf", "idd", "err", "epw"), if (is.null(num)) { num <- nrow(data) } - assert(has_name(data, c("line", "string"))) + assert_names(names(data), must.include = c("line", "string")) mes <- paste0(data$msg_each, "Line ", lpad(data$line), ": ", data$string) if (!is.null(prefix)) { mes <- paste0(prefix, mes) @@ -1612,10 +1586,15 @@ parse_issue <- function (error_type, type = c("idf", "idd", "err", "epw"), type <- match.arg(type) key <- if(stop) "ERROR" else "WARNING" all_mes <- paste0(paste0(toupper(type)," PARSING ", key, ".\n"), all_mes) + + ori <- getOption("warning.length") + options(warning.length = 8170L) + on.exit(options(warning.length = ori), add = TRUE) + if (stop) { - abort(c(error_type, paste0("error_parse_", type)), all_mes, NULL, data = data) + stop(all_mes, call. = FALSE) } else { - warn(c(error_type, paste0("warning_parse_", type)), all_mes, NULL, data = data) + warning(all_mes, call. = FALSE) } } # }}} @@ -1624,13 +1603,9 @@ parse_issue <- function (error_type, type = c("idf", "idd", "err", "epw"), insert_version <- function (x, ver) { if (is.character(x)) { paste0(x, "Version, ", standardize_ver(ver)[, 1L:2L], ";") - } else if (inherits(x, "data.table") && has_name(x, c("line", "string"))) { - append_dt(x, - data.table( - line = max(x$line) + 1L, - string = paste0("Version, ", standardize_ver(ver)[, 1L:2L], ";") - ) - ) + } else if (inherits(x, "data.table") && has_names(x, c("line", "string"))) { + n <- if (!nrow(x)) 0L else max(x$line) + append_dt(x, data.table(line = n + 1L, string = paste0("Version, ", standardize_ver(ver)[, 1L:2L], ";"))) } else { x } diff --git a/tests/testthat/test_parse.R b/tests/testthat/test_parse.R index 7c67bf3d9..7b48ed3c9 100644 --- a/tests/testthat/test_parse.R +++ b/tests/testthat/test_parse.R @@ -1,5 +1,3 @@ -context("parse IDD and IDF files") - # parse_idd_file() {{{ test_that("parse_idd_file()", { expect_silent(idd_parsed <- parse_idd_file(text("idd", "9.9.9"))) @@ -81,18 +79,17 @@ test_that("parse_idd_file()", { Test, A1 ; \\note something" ) - expect_error(parse_idd_file(idd_wrong), class = "error_miss_idd_ver") + expect_error(parse_idd_file(idd_wrong), "No version found") - # can detect error of multiple IDD versions + # can detect error of invalid IDD version idd_wrong <- c( - "!IDD_Version 9.9.9 - !IDD_Version 9.9.8 - \\group TestGroup + "!IDD_Version a + \\group TestGroup - Test, - A1 ; \\note something" + Test, + A1 ; \\note something" ) - expect_error(parse_idd_file(idd_wrong), class = "error_multi_idd_ver") + expect_error(parse_idd_file(idd_wrong), "Invalid IDD version") # can warn about missing IDD build tag idd_wrong <- c( @@ -102,21 +99,9 @@ test_that("parse_idd_file()", { Test, A1 ; \\note something" ) - expect_warning(idd_parsed <- parse_idd_file(idd_wrong), class = "warning_miss_idd_build") + expect_warning(idd_parsed <- parse_idd_file(idd_wrong), "No build tag found") expect_equal(idd_parsed$build, NA_character_) - # can warn about multiple IDD build tags - idd_wrong <- c( - "!IDD_Version 9.9.9 - !IDD_BUILD abc - !IDD_BUILD def - \\group TestGroup - - Test, - A1 ; \\note something" - ) - expect_error(parse_idd_file(idd_wrong), class = "error_multi_idd_build") - # can detect error of invalid line idd_wrong <- c( "!IDD_Version 9.9.9 @@ -128,7 +113,7 @@ test_that("parse_idd_file()", { Some Mess Here" ) - expect_error(parse_idd_file(idd_wrong), class = "error_unknown_line") + expect_error(parse_idd_file(idd_wrong), "Invalid line") # can detect missing group lines idd_wrong <- c( @@ -144,7 +129,7 @@ test_that("parse_idd_file()", { A1 ; \\note something " ) - expect_warning(idd_parsed <- parse_idd_file(idd_wrong), class = "warning_missing_group") + expect_warning(idd_parsed <- parse_idd_file(idd_wrong), "Missing group name") expect_equal(idd_parsed$group$group_id, 1L:2L) expect_equal(idd_parsed$group$group_name, c("Default Group", "TestGroup")) @@ -162,7 +147,7 @@ test_that("parse_idd_file()", { A1 ; \\note something " ) - expect_error(parse_idd_file(idd_wrong), class = "error_duplicated_class") + expect_error(parse_idd_file(idd_wrong), "Duplicated class names found") # can detect incomplete class idd_wrong <- c( @@ -179,7 +164,7 @@ test_that("parse_idd_file()", { A1 , \\note something " ) - expect_error(parse_idd_file(idd_wrong), class = "error_missing_class") + expect_error(parse_idd_file(idd_wrong), "Missing class name") # can detect missing class names idd_wrong <- c( @@ -195,7 +180,7 @@ test_that("parse_idd_file()", { A1 ; \\note something " ) - expect_error(parse_idd_file(idd_wrong), class = "error_missing_class") + expect_error(parse_idd_file(idd_wrong), "Missing class name") # can manually insert class slash idd_cls <- c( @@ -222,7 +207,7 @@ test_that("parse_idd_file()", { TestInvalidSlash, A1 ; \\invalid-slash-key") - expect_error(parse_idd_file(idd_wrong), class = "error_slash_key") + expect_error(parse_idd_file(idd_wrong), "Invalid slash key") # can detect error of invaid type key idd_wrong <- c( @@ -233,7 +218,7 @@ test_that("parse_idd_file()", { TestInvalidSlash, A1 ; \\type invalid" ) - expect_error(parse_idd_file(idd_wrong), class = "error_type_value") + expect_error(parse_idd_file(idd_wrong), "Invalid type value") # can detect error of invaid external list key idd_wrong <- c( @@ -244,7 +229,7 @@ test_that("parse_idd_file()", { TestInvalidSlash, A1 ; \\external-list invalid" ) - expect_error(parse_idd_file(idd_wrong), class = "error_external_list_value") + expect_error(parse_idd_file(idd_wrong), "Invalid external list value") # can detect error of invalid format key idd_wrong <- c( @@ -255,7 +240,25 @@ test_that("parse_idd_file()", { TestInvalidSlash, A1 ; \\format invalid" ) - expect_error(parse_idd_file(idd_wrong), class = "error_format_value") + expect_error(parse_idd_file(idd_wrong), "Invalid format value") + + # can detect error of mismatched object-list + idd_wrong <- c( + "!IDD_Version 9.9.9 + !IDD_BUILD 7c3bbe4830 + \\group TestGroup + + TestInvalidSlash, + A1 ; \\format invalid + \\object-list ref" + ) + expect_error(parse_idd_file(idd_wrong), "Invalid \\\\object-list value") + + # can fix ConnectorList references + if (!is_avail_eplus(8.8)) install_eplus(8.8) + idd <- parse_idd_file(file.path(eplus_config(8.8)$dir, "Energy+.idd")) + id <- idd$class[J("ConnectorList"), on = "class_name", class_id] + expect_true(idd$reference[J(id), on = "class_id", .N > 0]) }) # }}} @@ -359,7 +362,7 @@ test_that("parse_idf_file()", { 0.7800000, !- Solar Absorptance 0.7800000; !- Visible Absorptance ") - expect_error(parse_idf_file(idf_wrong, 8.8), class = "error_unknown_line") + expect_error(parse_idf_file(idf_wrong, 8.8), "Invalid line found") # can detect incomplete object idf_wrong <- c( @@ -375,7 +378,7 @@ test_that("parse_idf_file()", { 0.7800000, !- Solar Absorptance 0.7800000, !- Visible Absorptance ") - expect_error(parse_idf_file(idf_wrong, 8.8), class = "error_incomplete_object") + expect_error(parse_idf_file(idf_wrong, 8.8), "Incomplete object") # can detect error of invalid class name idf_wrong <- c( @@ -387,16 +390,16 @@ test_that("parse_idf_file()", { WrongClass, WD01; !- Name ") - expect_error(parse_idf_file(idf_wrong, 8.8), class = "error_invalid_class") + expect_error(parse_idf_file(idf_wrong, 8.8), "Invalid class name") idf_wrong <- c( "Version,8.8; WrongClass, WD01; ") - expect_error(parse_idf_file(idf_wrong, 8.8), class = "error_invalid_class") + expect_error(parse_idf_file(idf_wrong, 8.8), "Invalid class name") # can detect error of multiple version idf_wrong <- "Version, 8.8;\nVersion, 8.9;" - expect_error(parse_idf_file(idf_wrong, 8.8), class = "error_multiple_version") + expect_error(parse_idf_file(idf_wrong, 8.8), "Multiple versions found") # can detect error of invalid field number idf_wrong <- " @@ -405,6 +408,15 @@ test_that("parse_idf_file()", { Simple, !- Algorithm Simple, !- Algorithm TARP; !- Algorithm" - expect_error(parse_idf_file(idf_wrong, 8.8), class = "error_invalid_field_number") + expect_error(parse_idf_file(idf_wrong, 8.8), "Invalid field number") + + # can optional discard reference parsing + expect_equal(nrow(parse_idf_file(text(ver = 8.8), 8.8, ref = FALSE)$reference), 0L) + + # can handle DDY without giving unnecessary warning + ddy <- tempfile(fileext = ".ddy") + file.create(ddy) + expect_silent(idf_parsed <- parse_idf_file(ddy)) + unlink(ddy) }) # }}} From 29287bf87ee05d12adc9182052a48b272448a59a Mon Sep 17 00:00:00 2001 From: Hongyuan Jia Date: Tue, 14 Apr 2020 20:26:24 +0800 Subject: [PATCH 08/43] [refactor] Further clean utils.R --- R/utils.R | 54 +++++++++++-------------------------- tests/testthat/test_utils.R | 7 +---- 2 files changed, 16 insertions(+), 45 deletions(-) diff --git a/R/utils.R b/R/utils.R index 3fe5cde0b..41853802d 100644 --- a/R/utils.R +++ b/R/utils.R @@ -79,7 +79,8 @@ lpad <- function(x, char = " ", width = NULL) { read_lines <- function(input, trim = TRUE, ...) { dt <- tryCatch( fread(input = input, sep = NULL, header = FALSE, col.names = "string", ...), - error = function (e) stop("Failed to read input file. ", conditionMessage(e)) + warning = function (w) if (grepl("has size 0", conditionMessage(w))) data.table() else warning(w), + error = function (e) abort(paste0("Failed to read input file. ", conditionMessage(e)), "read_lines") ) if (!nrow(dt)) return(data.table(string = character(0L), line = integer(0L))) set(dt, j = "line", value = seq_along(dt[["string"]])) @@ -147,7 +148,7 @@ standardize_ver <- function (ver, strict = FALSE, complete = TRUE) { if (any(int)) ver[int] <- paste0(ver[int], ".0") } - if (!test_class(ver, "numeric_version")) ver <- numeric_version(ver, strict = FALSE) + if (!inherits(ver, "numeric_version")) ver <- numeric_version(ver, strict = FALSE) # only keep major.minor.patch, and remove others has_trail <- suppressWarnings(!is.na(ver[, 4L])) @@ -298,35 +299,31 @@ make_filename <- function (x, len = 100, unique = TRUE) { } # }}} -# cnd {{{ -cnd <- function (type = c("error", "warning", "message"), subclass, message, call = NULL, ...) { - type <- match.arg(type) - structure( - list(message = message, call = call, ...), - class = c(subclass, type, "condition") - ) -} -# }}} - # abort {{{ # reference: https://adv-r.hadley.nz/conditions.html#custom-conditions -abort <- function (subclass, message, call = NULL, ...) { +abort <- function (message, class = NULL, call = NULL, ...) { ori <- getOption("warning.length") options(warning.length = 8170L) on.exit(options(warning.length = ori), add = TRUE) - err <- cnd(type = "error", subclass = subclass, message = message, call = call, ...) - stop(err) + if (is.null(class)) { + stop(errorCondition(message, ..., class = "eplusr_error", call = call)) + } else { + stop(errorCondition(message, ..., class = unique(c(paste0("eplusr_error_", class), "eplusr_error")), call = call)) + } } # }}} # warn {{{ # reference: https://adv-r.hadley.nz/conditions.html#custom-conditions -warn <- function (subclass, message, call = NULL, ...) { +warn <- function (message, class = NULL, call = NULL, ...) { ori <- getOption("warning.length") options(warning.length = 8170L) on.exit(options(warning.length = ori), add = TRUE) - w <- cnd(type = "warning", subclass = subclass, message = message, call = call, ...) - warning(w) + if (is.null(class)) { + warning(warningCondition(message, ..., class = "eplusr_warning", call = call)) + } else { + warning(warningCondition(message, ..., class = unique(c(paste0("eplusr_warning_", class), "eplusr_warning")), call = call)) + } } # }}} @@ -365,27 +362,6 @@ ranger <- function (minimum = -Inf, lower_incbounds = FALSE, maximum = Inf, uppe } # }}} -# append_dt {{{ -#' @importFrom checkmate assert_names -append_dt <- function (dt, new_dt, base_col = NULL) { - assert_names(names(new_dt), must.include = names(dt)) - - if (is.null(base_col)) { - rbindlist(list(dt, new_dt[, .SD, .SDcols = names(dt)])) - } else { - rbindlist(list(dt[!new_dt, on = base_col], new_dt[, .SD, .SDcols = names(dt)])) - } -} -# }}} - -# unique_id {{{ -# nocov start -unique_id <- function () { - paste0("id-", stri_rand_strings(1, 15L), "-", Sys.time()) -} -# nocov end -# }}} - # fmt_* {{{ fmt_dbl <- function (x, digits = 2L) sprintf(paste0("%.", digits, "f"), x) fmt_int <- function (x, digits = 1L) sprintf(paste0("%.", digits, "f"), x) diff --git a/tests/testthat/test_utils.R b/tests/testthat/test_utils.R index b6d6cd083..6c1b2b59c 100644 --- a/tests/testthat/test_utils.R +++ b/tests/testthat/test_utils.R @@ -19,7 +19,7 @@ test_that("Utility functions", { expect_equal(lpad(c(1, 10)), c(" 1", "10")) expect_equal(lpad(c(1, 10), width = 3), c(" 1", " 10")) - expect_error(read_lines(NULL), "Failed to read input file") + expect_error(read_lines(NULL), "Failed to read input file", "eplusr_error_read_lines") expect_equal(read_lines("a\n b \n c \n"), data.table(line = 1:3, string = c("a", "b", "c"))) f <- tempfile() @@ -91,11 +91,6 @@ test_that("Utility functions", { expect_equal(ranger(1, TRUE)[], list(minimum = 1, lower_incbounds = TRUE, maximum = Inf, upper_incbounds = FALSE)) expect_equal(format(ranger(1, TRUE)), "[1, Inf)") - expect_error(append_dt(data.table(a = 1), data.table())) - expect_equal(append_dt(data.table(), data.table()), data.table()) - expect_equal(append_dt(data.table(a = 1), data.table(a = 2, b = 1)), data.table(a = c(1, 2))) - expect_equal(append_dt(data.table(a = 1, b = 1), data.table(a = c(1, 2), b = c(3, 4)), "a"), data.table(a = c(1, 2), b = c(3, 4))) - expect_equal(fmt_dbl(1.111), "1.11") expect_equal(fmt_dbl(1.111, 1), "1.1") expect_equal(fmt_int(1), "1.0") From 6da2971fc2b4eec117643062cf2a26211ebf2485 Mon Sep 17 00:00:00 2001 From: Hongyuan Jia Date: Tue, 14 Apr 2020 20:27:15 +0800 Subject: [PATCH 09/43] [refactor] Further clean parse.R --- R/parse.R | 60 ++++--------------------------------- tests/testthat/test_parse.R | 29 ++++++++---------- 2 files changed, 19 insertions(+), 70 deletions(-) diff --git a/R/parse.R b/R/parse.R index 3ef67be46..d0b112c6e 100644 --- a/R/parse.R +++ b/R/parse.R @@ -154,26 +154,6 @@ parse_idd_file <- function(path) { dt_field <- dt$left dt_reference <- dt$reference - # # add index - # setindexv(dt_group, "group_id") - # setindexv(dt_group, "group_name") - - # setindexv(dt_class, "class_id") - # setindexv(dt_class, "class_name") - # setindexv(dt_class, "class_name_us") - - # setindexv(dt_field, "field_id") - # setindexv(dt_field, "field_name") - # setindexv(dt_field, "field_name_us") - # setindexv(dt_field, c("class_id", "field_index")) - # setindexv(dt_field, c("class_id", "field_name")) - # setindexv(dt_field, c("class_id", "field_name_us")) - - # setindexv(dt_reference, "class_id") - # setindexv(dt_reference, "field_id") - # setindexv(dt_reference, "src_class_id") - # setindexv(dt_reference, "src_field_id") - list(version = idd_version, build = idd_build, group = dt_group, class = dt_class, field = dt_field, reference = dt_reference @@ -192,7 +172,7 @@ parse_idf_file <- function (path, idd = NULL, ref = TRUE) { if (has_ext(path, "ddy")) { idd <- withCallingHandlers(get_idd_from_ver(idf_ver, idd), - warning = function (w) invokeRestart("muffleWarning") + eplusr_warning = function (w) invokeRestart("muffleWarning") ) } else { idd <- get_idd_from_ver(idf_ver, idd) @@ -256,29 +236,6 @@ parse_idf_file <- function (path, idd = NULL, ref = TRUE) { c("value_id", "value_chr", "value_num", "object_id", "field_id")), NULL ) - # # set index - # setindexv(dt_object, "class_id") - # setindexv(dt_object, "object_id") - # setindexv(dt_object, "object_name") - # setindexv(dt_object, "object_name_lower") - # setindexv(dt_object, c("class_id", "object_id")) - # setindexv(dt_object, c("class_id", "object_name")) - # setindexv(dt_object, c("class_id", "object_name_lower")) - - # setindexv(dt_value, "field_id") - # setindexv(dt_value, "value_id") - # setindexv(dt_value, "value_chr") - # setindexv(dt_value, c("object_id", "field_id")) - # setindexv(dt_value, c("object_id", "value_id")) - # setindexv(dt_value, c("object_id", "value_chr")) - - # setindexv(dt_reference, "object_id") - # setindexv(dt_reference, "value_id") - # setindexv(dt_reference, c("object_id", "value_id")) - # setindexv(dt_reference, "src_object_id") - # setindexv(dt_reference, "src_value_id") - # setindexv(dt_reference, c("src_object_id", "src_value_id")) - list(version = idd_ver, options = options, object = dt_object, value = dt_value, reference = dt_reference ) @@ -291,11 +248,11 @@ get_idd_ver <- function (idd_dt) { ver_line <- idd_dt$string[[1L]] if (!stri_startswith_fixed(ver_line, "!IDD_Version")) { - stop("No version found in input IDD.") + parse_error("idd", "No IDD version on 1st line", idd_dt[1L]) } else { ver <- standardize_ver(stri_sub(ver_line, 14L)) - if (is.na(ver)) parse_error("idd", "Invalid IDD version", idd_dt[1L]) + if (is.na(ver)) parse_error("idd", "Invalid IDD version on 1st line", idd_dt[1L]) ver } @@ -308,7 +265,6 @@ get_idd_build <- function (idd_dt) { build_line <- idd_dt$string[[2L]] if (!stri_startswith_fixed(build_line, "!IDD_BUILD")) { - warning("No build tag found in input IDD.") NA_character_ } else { stri_sub(build_line, 12L) @@ -1335,7 +1291,7 @@ get_value_table <- function (dt, idd) { c("type_enum", "src_enum", "is_name", "units", "ip_units"), complete = TRUE ), - error_bad_field_index = function (e) e + eplusr_error_invalid_field_index = function (e) e ) # issue parse error if invalid field number found @@ -1587,14 +1543,10 @@ parse_issue <- function (type = c("idf", "idd", "err", "epw"), key <- if(stop) "ERROR" else "WARNING" all_mes <- paste0(paste0(toupper(type)," PARSING ", key, ".\n"), all_mes) - ori <- getOption("warning.length") - options(warning.length = 8170L) - on.exit(options(warning.length = ori), add = TRUE) - if (stop) { - stop(all_mes, call. = FALSE) + abort(all_mes, paste0("parse_", type)) } else { - warning(all_mes, call. = FALSE) + warn(all_mes, paste0("parse_", type)) } } # }}} diff --git a/tests/testthat/test_parse.R b/tests/testthat/test_parse.R index 7b48ed3c9..701f6ff28 100644 --- a/tests/testthat/test_parse.R +++ b/tests/testthat/test_parse.R @@ -79,7 +79,7 @@ test_that("parse_idd_file()", { Test, A1 ; \\note something" ) - expect_error(parse_idd_file(idd_wrong), "No version found") + expect_error(parse_idd_file(idd_wrong), "No IDD version", "eplusr_error_parse_idd") # can detect error of invalid IDD version idd_wrong <- c( @@ -89,7 +89,7 @@ test_that("parse_idd_file()", { Test, A1 ; \\note something" ) - expect_error(parse_idd_file(idd_wrong), "Invalid IDD version") + expect_error(parse_idd_file(idd_wrong), "Invalid IDD version", "eplusr_error_parse_idd") # can warn about missing IDD build tag idd_wrong <- c( @@ -99,8 +99,7 @@ test_that("parse_idd_file()", { Test, A1 ; \\note something" ) - expect_warning(idd_parsed <- parse_idd_file(idd_wrong), "No build tag found") - expect_equal(idd_parsed$build, NA_character_) + expect_equal(parse_idd_file(idd_wrong)$build, NA_character_) # can detect error of invalid line idd_wrong <- c( @@ -113,7 +112,7 @@ test_that("parse_idd_file()", { Some Mess Here" ) - expect_error(parse_idd_file(idd_wrong), "Invalid line") + expect_error(parse_idd_file(idd_wrong), "Invalid line", "eplusr_error_parse_idd") # can detect missing group lines idd_wrong <- c( @@ -147,7 +146,7 @@ test_that("parse_idd_file()", { A1 ; \\note something " ) - expect_error(parse_idd_file(idd_wrong), "Duplicated class names found") + expect_error(parse_idd_file(idd_wrong), "Duplicated class names found", class = "eplusr_error_parse_idd") # can detect incomplete class idd_wrong <- c( @@ -164,7 +163,7 @@ test_that("parse_idd_file()", { A1 , \\note something " ) - expect_error(parse_idd_file(idd_wrong), "Missing class name") + expect_error(parse_idd_file(idd_wrong), "Missing class name", class = "eplusr_error_parse_idd") # can detect missing class names idd_wrong <- c( @@ -180,7 +179,7 @@ test_that("parse_idd_file()", { A1 ; \\note something " ) - expect_error(parse_idd_file(idd_wrong), "Missing class name") + expect_error(parse_idd_file(idd_wrong), "Missing class name", class = "eplusr_error_parse_idd") # can manually insert class slash idd_cls <- c( @@ -207,7 +206,7 @@ test_that("parse_idd_file()", { TestInvalidSlash, A1 ; \\invalid-slash-key") - expect_error(parse_idd_file(idd_wrong), "Invalid slash key") + expect_error(parse_idd_file(idd_wrong), "Invalid slash key", class = "eplusr_error_parse_idd") # can detect error of invaid type key idd_wrong <- c( @@ -218,7 +217,7 @@ test_that("parse_idd_file()", { TestInvalidSlash, A1 ; \\type invalid" ) - expect_error(parse_idd_file(idd_wrong), "Invalid type value") + expect_error(parse_idd_file(idd_wrong), "Invalid type value", class = "eplusr_error_parse_idd") # can detect error of invaid external list key idd_wrong <- c( @@ -229,7 +228,7 @@ test_that("parse_idd_file()", { TestInvalidSlash, A1 ; \\external-list invalid" ) - expect_error(parse_idd_file(idd_wrong), "Invalid external list value") + expect_error(parse_idd_file(idd_wrong), "Invalid external list value", class = "eplusr_error_parse_idd") # can detect error of invalid format key idd_wrong <- c( @@ -240,7 +239,7 @@ test_that("parse_idd_file()", { TestInvalidSlash, A1 ; \\format invalid" ) - expect_error(parse_idd_file(idd_wrong), "Invalid format value") + expect_error(parse_idd_file(idd_wrong), "Invalid format value", class = "eplusr_error_parse_idd") # can detect error of mismatched object-list idd_wrong <- c( @@ -252,7 +251,7 @@ test_that("parse_idd_file()", { A1 ; \\format invalid \\object-list ref" ) - expect_error(parse_idd_file(idd_wrong), "Invalid \\\\object-list value") + expect_error(parse_idd_file(idd_wrong), "Invalid \\\\object-list value", class = "eplusr_error_parse_idd") # can fix ConnectorList references if (!is_avail_eplus(8.8)) install_eplus(8.8) @@ -281,9 +280,7 @@ test_that("parse_idf_file()", { ) # }}} - expect_warning(idf_parsed <- parse_idf_file(text("idf"), 8.8), - "Missing version field in input IDF" - ) + expect_warning(idf_parsed <- parse_idf_file(text("idf"), 8.8), "Missing version field in input IDF") # can parse Idf stored in strings expect_equal(names(idf_parsed), From de626faa8298bdd6fbd7640b94e731862831b960 Mon Sep 17 00:00:00 2001 From: Hongyuan Jia Date: Tue, 14 Apr 2020 20:28:22 +0800 Subject: [PATCH 10/43] [refactor] Further clean options.R --- R/options.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/options.R b/R/options.R index 398ab8931..7601f3b9b 100644 --- a/R/options.R +++ b/R/options.R @@ -130,7 +130,7 @@ eplusr_option <- function (...) { for (nm_opt in count_opt) assign_count_opt(opt, nm_opt) # validate level - if ("validate_level" %in% nm) { + if ("validate_level" %chin% nm) { level <- opt[["validate_level"]] if (test_choice(level, c("none", "draft", "final"))) { .options[["validate_level"]] <- level From 8b35ac8de44780f6a7157f95d00fa603efd5b035 Mon Sep 17 00:00:00 2001 From: Hongyuan Jia Date: Tue, 14 Apr 2020 22:53:54 +0800 Subject: [PATCH 11/43] [refactor] Further clean run.R --- R/run.R | 45 ++++++++++++++++++++++++--------------- tests/testthat/test_run.R | 14 ++++++------ 2 files changed, 35 insertions(+), 24 deletions(-) diff --git a/R/run.R b/R/run.R index 620aee354..1d12ab16c 100644 --- a/R/run.R +++ b/R/run.R @@ -226,8 +226,10 @@ run_idf <- function (model, weather, output_dir, design_day = FALSE, eplus <- eplus %||% as.character(get_idf_ver(read_lines(model))) if (!length(eplus)) { - stop("Missing version field in input IDF file. Failed to determine the ", - "version of EnergyPlus to use.", call. = FALSE) + abort(paste0("Missing version field in input IDF file. ", + "Failed to determine the version of EnergyPlus to use."), + "miss_idf_ver" + ) } energyplus_exe <- eplus_exe(eplus) @@ -237,7 +239,7 @@ run_idf <- function (model, weather, output_dir, design_day = FALSE, output_dir <- normalizePath(output_dir, mustWork = FALSE) if (!dir.exists(output_dir)) { tryCatch(dir.create(output_dir, recursive = TRUE), - warning = function (w) stop("Failed to create output directory: ", surround(output_dir)) + warning = function (w) abort(paste0("Failed to create output directory: ", surround(output_dir)), "create_output_dir") ) } @@ -293,7 +295,9 @@ run_multi <- function (model, weather, output_dir, design_day = FALSE, } if (any(annual & design_day)) { - stop("Cannot force both design-day-only simulation and annual simulation at the same time") + abort("Cannot force both design-day-only simulation and annual simulation at the same time", + "both_ddy_annual" + ) } model <- normalizePath(model, mustWork = TRUE) @@ -316,8 +320,8 @@ run_multi <- function (model, weather, output_dir, design_day = FALSE, if (any(ver_miss)) { msg <- paste0(" #", lpad(seq_along(model)[ver_miss]), "| ", surround(model[ver_miss]), collapse = "\n") - stop("Missing version field in input IDF file. Failed to determine the ", - "version of EnergyPlus to use:\n", msg) + abort(paste0("Missing version field in input IDF file. Failed to determine the ", + "version of EnergyPlus to use:\n", msg), "miss_idf_ver") } ver <- unlist(ver_list) @@ -328,7 +332,7 @@ run_multi <- function (model, weather, output_dir, design_day = FALSE, ver <- vcapply(ver, function (v) as.character(eplus_config(v)$version)) if (anyDuplicated(model) & is.null(output_dir)) { - stop("'model' cannot have any duplications when 'output_dir' is NULL.") + abort("'model' cannot have any duplications when 'output_dir' is NULL.", "duplicated_sim") } if (is.null(output_dir)) { @@ -342,13 +346,15 @@ run_multi <- function (model, weather, output_dir, design_day = FALSE, jobs <- data.table::data.table(input_model = model, output_dir = output_dir) if (anyDuplicated(jobs)) - stop("Duplication found in the combination of 'model' and 'output_dir'. ", - "One model could not be run in the same output directory multiple times simultaneously.") + stop(paste0("Duplication found in the combination of 'model' and 'output_dir'. ", + "One model could not be run in the same output directory multiple times simultaneously."), + "duplicated_sim" + ) d <- unique(output_dir[!dir.exists(output_dir)]) created <- vapply(d, dir.create, logical(1L), showWarnings = FALSE, recursive = TRUE) if (any(!created)) { - abort("error_create_output_dir", paste0("Failed to create output directory:\n", + abort(paste0("Failed to create output directory:\n", paste0(surround(d[!created]), collapse = "\n") )) } @@ -421,6 +427,9 @@ run_parallel_jobs <- function(jobs, options) { if (nrow(jobs) == 0) return() assert_count(options$num_parallel, positive = TRUE) + # in case run in background + jobs <- setDT(jobs) + ## Kill all child processes if we quit from this function on.exit(kill_jobs(jobs, options), add = TRUE) @@ -463,7 +472,7 @@ run_parallel_jobs <- function(jobs, options) { # }}} # kill_jobs {{{ kill_jobs <- function(jobs, options) { - jobs[vlapply(process, function (x) !is.null(x) && x$is_alive()), `:=`( + jobs[vlapply(process, function (x) inherits(x, "process") && x$is_alive()), `:=`( status = {for (p in process) p$kill(); "terminated"} )] @@ -617,7 +626,7 @@ energyplus <- function (eplus, model, weather, output_dir, output_prefix = NULL, if (!is.null(idd)) assert_file_exists(idd) if (annual && design_day) { - stop("Cannot force both design-day and annual simulations") + abort("Cannot force both design-day and annual simulations", "both_ddy_annual") } # argument docs {{{ @@ -843,13 +852,15 @@ eplus_run_wait <- function (proc, echo = TRUE) { # eplus_exe {{{ eplus_exe <- function (eplus) { if (!is_avail_eplus(eplus)) use_eplus(eplus) - config <- tryCatch(eplus_config(eplus), warning = function (w) stop(w)) + config <- tryCatch(eplus_config(eplus), miss_eplus_config = function (w) abort(conditionMessage(w), "miss_eplus_config")) if (config$version < 8.3) { - stop("Currently, eplusr only supports running IDFs of EnergyPlus v8.3 and above. ", + abort(paste0("Currently, eplusr only supports running IDFs of EnergyPlus v8.3 and above. ", "This is because eplusr uses EnergyPlus command line interface ", "which is available only in EnergyPlus v8.3 and above. ", - "You can update the version of your model using 'transition()' or 'version_updater()' and try again.") + "You can update the version of your model using 'transition()' or 'version_updater()' and try again."), + "eplus_ver_not_supported" + ) } normalizePath(file.path(config$dir, config$exe), mustWork = TRUE) @@ -869,8 +880,8 @@ copy_run_files <- function (file, dir) { ) if (any(!flag)) - stop("Unable to copy file ", surround(basename(file[!flag])), "into ", - "simulation output directory.", call. = FALSE) + abort(paste0("Unable to copy file ", surround(basename(file[!flag])), "into ", + "simulation output directory."), "copy_run_files") loc } diff --git a/tests/testthat/test_run.R b/tests/testthat/test_run.R index 271b0aa02..6dfd75fea 100644 --- a/tests/testthat/test_run.R +++ b/tests/testthat/test_run.R @@ -28,7 +28,7 @@ test_that("run_idf()", { f <- tempfile(fileext = ".idf") write_lines(read_lines(path_idf)[-91], f) run_idf(f, NULL, output_dir = tempdir(), echo = FALSE) - }, "Missing version field") + }, "Missing version field", class = "eplusr_error_miss_idf_ver") # can use input file directory expect_silent({ f <- tempfile(fileext = ".idf") @@ -72,7 +72,7 @@ test_that("run_idf()", { expect_null(res$stdout) expect_null(res$stderr) expect_is(res$process, "process") - expect_silent(res_post <- res$process$get_result()) + expect_silent({res$process$wait(); res_post <- res$process$get_result()}) expect_is(res_post$stdout, "character") expect_is(res_post$stderr, "character") }) @@ -92,7 +92,7 @@ test_that("run_multi()", { # can stop if idf and annual does not have the same length expect_error(run_multi(rep(path_idf, 2), NULL, annual = rep(FALSE, 3)), "Must have same length") # can stop if both design and annual is TRUE - expect_error(run_multi(path_idf, NULL, annual = TRUE, design_day = TRUE), "both design-day-only") + expect_error(run_multi(path_idf, NULL, annual = TRUE, design_day = TRUE), "both design-day-only", class = "eplusr_error_both_ddy_annual") # can stop if model does not exist expect_error(run_multi("", NULL), "No such file or directory") # can stop if model does not contain version @@ -100,11 +100,11 @@ test_that("run_multi()", { f <- tempfile(fileext = ".idf") write_lines(read_lines(path_idf)[-91], f) run_multi(f, NULL, output_dir = tempdir()) - }, "Failed to determine the version of EnergyPlus") + }, "Failed to determine the version of EnergyPlus", class = "eplusr_error_miss_idf_ver") # can stop if target EnergyPlus is not found - expect_error(run_multi(path_idf, NULL, eplus = 8.0), "Cannot locate EnergyPlus") + expect_error(run_multi(path_idf, NULL, eplus = 8.0), "Cannot locate EnergyPlus", class = "eplusr_error_locate_eplus") # can stop if input idf contain duplications - expect_error(run_multi(rep(path_idf, 2L), NULL, output_dir = NULL), "Have any duplication") + expect_error(run_multi(rep(path_idf, 2L), NULL, output_dir = NULL), class = "eplusr_error_duplicated_sim") # can stop if idf and output directory does not have the same length expect_error(run_multi(rep(path_idf, 2L), NULL, output_dir = tempdir()), "have same length") # can stop if idf and output directory combines same job @@ -132,7 +132,7 @@ test_that("run_multi()", { expect_silent(res <- run_multi(rep(path_idf, 2L), NULL, output_dir = c(file.path(tempdir(), "a"), file.path(tempdir(), "b")), wait = FALSE)) expect_is(res, "r_process") - expect_equal(res$get_exit_status(), 0L) + expect_equal({res$wait(); res$get_exit_status()}, 0L) expect_silent(res <- res$get_result()) expect_is(res, "data.table") expect_equal(names(res), c("index", "status", "idf", "epw", "version", From c6486976448bf94590632e8ec104a10cd077bbba Mon Sep 17 00:00:00 2001 From: Hongyuan Jia Date: Wed, 15 Apr 2020 14:14:41 +0800 Subject: [PATCH 12/43] [refactor] Refactor impl.R --- R/impl.R | 91 ++++++++++++++++---------- tests/testthat/test_impl.R | 127 +++++++++++++++++++++++++++++++++++++ 2 files changed, 183 insertions(+), 35 deletions(-) create mode 100644 tests/testthat/test_impl.R diff --git a/R/impl.R b/R/impl.R index 1855391d9..c966d6f23 100644 --- a/R/impl.R +++ b/R/impl.R @@ -10,13 +10,19 @@ NULL # recognize_input {{{ recognize_input <- function (input, type = "class", underscore = FALSE, lower = FALSE) { if (underscore && lower) stop("underscore and lower cannot all be TRUE.") + input <- assert_valid_type(input, name = type) # store the original input ori <- input - if (is.character(input)) { + + if (is.integer(input)) { + col_on <- paste0(type, "_id") + col_key <- paste0(type, " index") + } else { if (underscore) { input <- underscore_name(input) col_on <- paste0(type, "_name_us") + # always trans to lower case for field names if (type == "field") { input <- stri_trans_tolower(input) } @@ -27,27 +33,27 @@ recognize_input <- function (input, type = "class", underscore = FALSE, lower = col_on <- paste0(type, "_name") } col_key <- paste0(type, " name") - } else if (all(are_count(input))) { - col_on <- paste0(type, "_id") - col_key <- paste0(type, " index") - } else { - abort_bad_which_type(paste0("error_", type, "_which_type"), type) } + dt_in <- data.table(input = input, rleid = seq_along(input), original = ori) setnames(dt_in, "input", col_on) # make sure the first column is the column used for joinning setcolorder(dt_in, c(col_on, setdiff(names(dt_in), col_on))) - setindexv(dt_in, col_on) + dt_in } # }}} # join_from_input {{{ -join_from_input <- function (dt, input, check = "group_id") { +join_from_input <- function (dt, input, check = "group_id", allow.cartesian = TRUE) { col_on <- names(input)[[1L]] - res <- dt[input, on = col_on, allow.cartesian = TRUE] - check_bad_key(res, check, col_on) - if (has_name(res, "original")) on.exit(set(res, NULL, "original", NULL), add = TRUE) + + res <- dt[input, on = col_on, allow.cartesian = allow.cartesian] + + if (length(check)) check_bad_key(res, check, col_on) + + if (has_names(res, "original")) on.exit(set(res, NULL, "original", NULL), add = TRUE) + setcolorder(res, "rleid") res } @@ -55,7 +61,7 @@ join_from_input <- function (dt, input, check = "group_id") { # check_bad_key {{{ check_bad_key <- function (res, col_check, col_on) { if (anyNA(res[[col_check]])) { - if (has_name(res, "original")) { + if (has_names(res, "original")) { invld_cls <- res[is.na(get(col_check))][["original"]] } else { invld_cls <- res[is.na(get(col_check))][[col_on]] @@ -70,16 +76,16 @@ check_bad_key <- function (res, col_check, col_on) { col_key <- "name" } col_key <- paste(stri_replace_first_regex(col_on, "_.*", ""), col_key) - abort_bad_key(paste0("error_", col_on), col_key, invld_cls) + abort_bad_key(col_key, invld_cls) } res } # }}} # add_joined_cols {{{ add_joined_cols <- function (base, dt, on, cols) { - on_dt <- if (is_named(on)) names(on) else on + on_dt <- if (!is.null(names(on))) names(on) else on + nm <- if (!is.null(names(cols))) names(cols) else cols on <- unname(on) - nm <- if (is_named(cols)) names(cols) else cols cols <- unname(cols) set(dt, NULL, nm, base[J(dt[[on_dt]]), on = on, .SD, .SDcols = cols]) } @@ -91,8 +97,8 @@ del_redundant_cols <- function (base, dt, col_on = names(dt)[[1L]]) { dt } # }}} -# del_unuseful_cols {{{ -del_unuseful_cols <- function (base, dt) { +# keep_same_cols {{{ +keep_same_cols <- function (base, dt) { col_del <- setdiff(names(dt), intersect(names(dt), names(base))) if (length(col_del)) set(dt, NULL, col_del, NULL) setcolorder(dt, names(base)) @@ -143,6 +149,11 @@ in_ip_mode <- function () { eplusr_option("view_in_ip") } # }}} +# in_verbose {{{ +in_verbose <- function () { + eplusr_option("verbose_info") +} +# }}} # verbose_info {{{ verbose_info <- function (...) { if (eplusr_option("verbose_info")) message(...) @@ -150,19 +161,13 @@ verbose_info <- function (...) { # }}} # abort_bad_key {{{ -abort_bad_key <- function (error_type, key, value) { +abort_bad_key <- function (key, value) { mes <- paste0("Invalid ", key, " found: ", collapse(value)) - abort(error_type, mes, value = value) -} -# }}} -# abort_bad_which_type {{{ -abort_bad_which_type <- function (error_type, key, ...) { - mes <- paste0(key, " should be either a positive integer vector or a character vector", ...) - abort(error_type, mes) + abort(mes, value = value, class = paste0("invalid_", gsub(" ", "_", tolower(key)))) } # }}} # abort_bad_field {{{ -abort_bad_field <- function (error_type, key, dt, ...) { +abort_bad_field <- function (key, dt, ...) { h <- paste0("Invalid field ", key, " found:\n") mes <- switch(key, @@ -170,12 +175,12 @@ abort_bad_field <- function (error_type, key, dt, ...) { name = errormsg_field_name(dt) ) - abort(error_type, paste0(h, mes, ...), data = dt) + abort(paste0(h, mes, ...), class = paste0("invalid_field_", key)) } # }}} # errormsg_info {{{ errormsg_info <- function (dt) { - if (!has_name(dt, "rleid")) add_rleid(dt) + if (!has_names(dt, "rleid")) add_rleid(dt) dt[, `:=`(info = paste0(" #", lpad(rleid), "| Class ", surround(class_name)))] } # }}} @@ -213,8 +218,9 @@ errormsg_field_name <- function (dt) { # }}} # new_id {{{ +#' @importFrom checkmate assert_names new_id <- function (dt, name, num) { - assert(has_name(dt, name)) + assert_names(names(dt), must.include = name) max(dt[[name]], na.rm = TRUE) + seq_len(num) } # }}} @@ -225,8 +231,9 @@ add_rleid <- function (dt, prefix = NULL) { } # }}} # append_dt {{{ +#' @importFrom checkmate assert_names append_dt <- function (dt, new_dt, base_col = NULL) { - assert(has_name(new_dt, names(dt))) + assert_names(names(new_dt), must.include = names(dt)) if (is.null(base_col)) { rbindlist(list(dt, new_dt[, .SD, .SDcols = names(dt)])) @@ -237,15 +244,29 @@ append_dt <- function (dt, new_dt, base_col = NULL) { # }}} # unique_id {{{ unique_id <- function () { - paste0("id-", stri_rand_strings(1, 15L), "-", as.numeric(Sys.time())) + paste0("id-", stri_rand_strings(1, 10L), "-", as.integer(Sys.time())) } # }}} # assert_valid_type {{{ -assert_valid_type <- function (x, type) { - if (!is.character(x) && !all(are_count(x))) { - abort_bad_which_type(paste0("error_",type,"_which_type"), type) +#' @importFrom checkmate assert_character assert_integerish check_character +#' @importFrom checkmate check_integerish +assert_valid_type <- function (x, name = NULL, len = NULL, null.ok = FALSE, lower = -Inf, type = c("both", "id", "name")) { + if (is.null(name)) name <- checkmate::vname(x) + type <- match.arg(type) + + if (type == "name") { + x <- assert_character(x, any.missing = FALSE, len = len, null.ok = null.ok, .var.name = name) + } else if (type == "id") { + x <- assert_integerish(x, any.missing = FALSE, len = len, null.ok = null.ok, lower = lower, coerce = TRUE, .var.name = name) + } else { + assert( + check_character(x, any.missing = FALSE, len = len, null.ok = null.ok), + check_integerish(x, any.missing = FALSE, len = len, null.ok = null.ok, lower = lower), + .var.name = name + ) + if (is.numeric(x)) storage.mode(x) <- "integer" } - TRUE + x } # }}} diff --git a/tests/testthat/test_impl.R b/tests/testthat/test_impl.R new file mode 100644 index 000000000..715dc60a7 --- /dev/null +++ b/tests/testthat/test_impl.R @@ -0,0 +1,127 @@ +# Basic Impl {{{ +test_that("Basic Table Implementation", { + expect_equal(assert_valid_type("a"), "a") + expect_error(assert_valid_type("a", type = "id"), "integerish") + expect_error(assert_valid_type("a", "object", type = "id"), "object") + expect_error(assert_valid_type("a", len = 2, type = "name"), "length 2") + expect_equal(assert_valid_type(1, type = "id"), 1L) + expect_equal(assert_valid_type(1), 1L) + expect_error(assert_valid_type(1, lower = 2, type = "both"), 1L) + + expect_error( + recognize_input("ClassName", type = "class", underscore = TRUE, lower = TRUE), + "underscore and lower cannot all be TRUE" + ) + + expect_equivalent( + recognize_input("Class:Name", type = "class", underscore = TRUE), + data.table(class_name_us = "Class_Name", rleid = 1L, original = "Class:Name") + ) + + expect_equivalent( + recognize_input("Field Name", type = "field", underscore = TRUE), + data.table(field_name_us = "field_name", rleid = 1L, original = "Field Name") + ) + + expect_equivalent( + recognize_input("Field Name", type = "field", lower = TRUE), + data.table(field_name_lower = "field name", rleid = 1L, original = "Field Name") + ) + + expect_equal( + join_from_input( + dt = data.table(object_id = 1:3, object_name = c("A", "B", "C")), + input = recognize_input(2L, "object") + ), + data.table(rleid = 1L, object_id = 2L, object_name = "B") + ) + + expect_equal( + join_from_input( + dt = data.table(object_id = 1:3, object_name = c("A", "B", "C"), + object_name_lower = c("a", "b", "c")), + input = recognize_input("B", "object") + ), + data.table(rleid = 1L, object_id = 2L, object_name = "B", object_name_lower = "b") + ) + + expect_equal( + join_from_input( + dt = data.table(object_id = 1:3, object_name = c("A", "B", "C"), + object_name_lower = c("a", "b", "c")), + input = recognize_input("b", "object", lower = TRUE) + ), + data.table(rleid = 1L, object_id = 2L, object_name = "B", object_name_lower = "b") + ) + + expect_error( + join_from_input( + dt = data.table(object_id = 1:3, object_name = c("A", "B", "C"), + object_name_lower = c("a", "b", "c")), + input = recognize_input("D", "object", lower = TRUE), + check = "object_id" + ), + class = "eplusr_error_invalid_object_name" + ) + + expect_equal( + { + base <- data.table(object_id = 1:3, object_name = c("A", "B", "C"), + object_name_lower = c("a", "b", "c")) + dt <- data.table(id = 2L) + add_joined_cols(base, dt, on = c(id = "object_id"), cols = c("name" = "object_name")) + }, + data.table(data.table(id = 2L, name = "B")) + ) + + # log {{{ + log <- new.env(parent = emptyenv()) + + expect_silent(log_new_uuid(log)) + expect_equal(nchar(log$uuid), 2 + 1 + 10 + 1 + 10) + + log$order <- data.table(object_id = 1:5, object_order = 0L) + expect_silent(log_new_order(log, 6L)) + expect_equal(log$order, data.table(object_id = 1:6, object_order = c(rep(0L, 5), 1L))) + + expect_silent(log_add_order(log, 6L)) + expect_equal(log$order[.N], data.table(object_id = 6L, object_order = 2L)) + + expect_silent(log_del_order(log, 6L)) + expect_equal(log$order, data.table(object_id = 1:5, object_order = 0L)) + + expect_silent(log_unsaved(log)) + expect_equal(log$unsaved, TRUE) + + expect_silent(log_saved(log)) + expect_equal(log$unsaved, FALSE) + # }}} + + eplusr_option(validate_level = "final") + eplusr_option(verbose_info = TRUE) + expect_true(in_final_mode()) + expect_false(in_ip_mode()) + expect_true(in_verbose()) + expect_message(verbose_info("a"), "a") + eplusr_option(verbose_info = FALSE) + + expect_error(abort_bad_key("object ID", 1L), class = "eplusr_error_invalid_object_id") + expect_error( + abort_bad_field("index", data.table(rleid = 1L, class_name = "Class", field_index = 1L, min_fields = 2L, num_fields = 3L)), + class = "eplusr_error_invalid_field_index" + ) + expect_error( + abort_bad_field("name", data.table(rleid = 1L, class_name = "Class", field_name = "Name")), + class = "eplusr_error_invalid_field_name" + ) + + expect_equal(new_id(data.table(object_id = 1:5), "object_id", 2L), 6:7) + expect_equal(add_rleid(data.table(object_id = 1:5)), data.table(object_id = 1:5, rleid = 1:5)) + expect_equal(add_rleid(data.table(object_id = 1:5), "object"), data.table(object_id = 1:5, object_rleid = 1:5)) + + expect_error(append_dt(data.table(a = 1), data.table())) + expect_equal(append_dt(data.table(), data.table()), data.table()) + expect_equal(append_dt(data.table(a = 1), data.table(a = 2, b = 1)), data.table(a = c(1, 2))) + expect_equal(append_dt(data.table(a = 1, b = 1), data.table(a = c(1, 2), b = c(3, 4)), "a"), data.table(a = c(1, 2), b = c(3, 4))) +}) +# }}} From 9353e09d40e7cde7920d681e24f2527030443974 Mon Sep 17 00:00:00 2001 From: Hongyuan Jia Date: Wed, 15 Apr 2020 14:17:02 +0800 Subject: [PATCH 13/43] [refactor] Refactor impl-idd.R --- NAMESPACE | 3 + R/impl-idd.R | 292 ++++++++++++++++++++------------- R/parse.R | 2 +- man/get_idd_class.Rd | 29 ++++ man/get_idd_field.Rd | 54 ++++++ man/get_idd_relation.Rd | 71 ++++++++ tests/testthat/test_impl-idd.R | 157 ++++++++++++++---- 7 files changed, 461 insertions(+), 147 deletions(-) create mode 100644 man/get_idd_class.Rd create mode 100644 man/get_idd_field.Rd create mode 100644 man/get_idd_relation.Rd diff --git a/NAMESPACE b/NAMESPACE index d0d481d70..67bc9002b 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -102,6 +102,9 @@ export(eplus_config) export(eplus_job) export(eplus_sql) export(eplusr_option) +export(get_idd_class) +export(get_idd_field) +export(get_idd_relation) export(group_job) export(idd_object) export(idf_object) diff --git a/R/impl-idd.R b/R/impl-idd.R index 35ab7972e..6e59e199c 100644 --- a/R/impl-idd.R +++ b/R/impl-idd.R @@ -8,75 +8,81 @@ NULL # GROUP # get_idd_group_index {{{ +#' @importFrom checkmate assert_string get_idd_group_index <- function (idd_env, group = NULL) { if (is.null(group)) return(idd_env$group$group_id) - assert(are_string(group)) + assert_string(group) res <- idd_env$group[J(group), on = "group_name", group_id] - if (anyNA(res)) abort_bad_key("error_group_name", "group name", group) + if (anyNA(res)) abort_bad_key("group name", group) res } # }}} # get_idd_group_name {{{ +#' @importFrom checkmate assert_count get_idd_group_name <- function (idd_env, group = NULL) { if (is.null(group)) return(idd_env$group$group_name) - assert(are_count(group)) + assert_count(group, positive = TRUE) res <- idd_env$group[J(group), on = "group_id", group_name] - if (anyNA(res)) abort_bad_key("error_group_id", "group index", group) + if (anyNA(res)) abort_bad_key("group index", group) res } # }}} # CLASS # get_idd_class {{{ -# Get class data -# @param idd_env An environment or list contains IDD tables including class, -# field, and reference. -# @param class An integer vector of valid class indexes or a character vector -# of valid class names. If `NULL`, all classes are returned. -# @param property A character vector of column names in class table to return. -# If `NULL`, only class index columns are returned, plus column `rleid`. -# @param underscore If `TRUE`, input class name will be converted into -# underscore style name first and column `class_name_us` will be used -# for matching. -# @return A data.table containing specified columns. +#' Get class data +#' +#' @param idd_env An environment or list contains IDD tables including class, +#' field, and reference. +#' @param class An integer vector of valid class indexes or a character vector +#' of valid class names. If `NULL`, all classes are returned. +#' @param property A character vector of column names in class table to return. +#' If `NULL`, only class index columns are returned, plus column `rleid`. +#' @param underscore If `TRUE`, input class name will be converted into +#' underscore style name first and column `class_name_us` will be used +#' for matching. +#' +#' @return A data.table containing specified columns. +#' @keywords internal +#' @export get_idd_class <- function (idd_env, class = NULL, property = NULL, underscore = FALSE) { + cols <- setdiff(CLASS_COLS$index, "class_name_us") + if (is.null(class)) { - cols <- setdiff(CLASS_COLS$index, "class_name_us") - if (is.null(property)) { - return(idd_env$class[, .SD, .SDcols = cols]) + # very odd way to subset columns but is way faster that others + # ref: https://github.com/Rdatatable/data.table/issues/3477 + if (is.null(property)) return(setDT(unclass(idd_env$class)[cols])) + + if ("group_name" %chin% property) { + property <- setdiff(property, "group_name") + add_group <- TRUE } else { - if ("group_name" %chin% property) { - property <- setdiff(property, "group_name") - add_group <- TRUE - } else { - add_group <- FALSE - } + add_group <- FALSE + } - res <- idd_env$class[, .SD, .SDcols = unique(c(cols, property))] + # very odd way to subset columns but is way faster + # ref: https://github.com/Rdatatable/data.table/issues/3477 + res <- setDT(unclass(idd_env$class)[unique(c(cols, property))]) - if (add_group) { - add_joined_cols(idd_env$group, res, "group_id", "group_name") - } + if (add_group) add_joined_cols(idd_env$group, res, "group_id", "group_name") - return(res) - } + return(res) } cls_in <- recognize_input(class, "class", underscore) res <- join_from_input(idd_env$class, cls_in, "group_id") - set(res, NULL, "class_name_us", NULL) - property <- property %||% "" - if ("group_name" %chin% property) { + if (!is.null(property) && "group_name" %chin% property) { add_joined_cols(idd_env$group, res, "group_id", "group_name") } - clean_class_property(res, property) - res + # very odd way to subset columns but is way faster + # ref: https://github.com/Rdatatable/data.table/issues/3477 + setDT(unclass(res)[c("rleid", unique(c(cols, property)))]) } # }}} # get_idd_class_field_num {{{ @@ -97,15 +103,17 @@ get_idd_class <- function (idd_env, class = NULL, property = NULL, underscore = # * If input number is larger than the total existing field number: # - The acceptable field number will be the field index of the last # field in the last extensible group. +#' @importFrom checkmate assert_integer assert_names get_idd_class_field_num <- function (dt_class, num = NULL) { - if (!is.null(num)) assert(are_count(num)) + assert_integer(num, lower = 1L, any.missing = FALSE, null.ok = TRUE) dt_class <- add_rleid(dt_class, "class") # directly return num of fields in class - assert(has_name(dt_class, c("num_fields", "min_fields", "last_required", "num_extensible", "first_extensible"))) + assert_names(names(dt_class), must.include = c("num_fields", "min_fields", "last_required", "num_extensible", "first_extensible")) if (!nrow(dt_class)) { + set(dt_class, NULL, "class_rleid", NULL) set(dt_class, NULL, "input_num", integer(0L)) set(dt_class, NULL, "acceptable_num", integer(0L)) return(dt_class) @@ -114,13 +122,13 @@ get_idd_class_field_num <- function (dt_class, num = NULL) { if (is.null(num)) { set(dt_class, NULL, "input_num", 0L) } else { - assert(have_same_len(dt_class, num)) + assert_same_len(dt_class, num) set(dt_class, NULL, "input_num", as.integer(num)) } # get index of the last field in the last extensible group set(dt_class, NULL, "last_extensible", 0) - if (nrow(dt_class[num_extensible > 0L])) { + if (any(dt_class$num_extensible > 0L)) { dt_class[ num_extensible > 0L & input_num > first_extensible, last_extensible := @@ -144,16 +152,37 @@ get_idd_class_field_num <- function (dt_class, num = NULL) { dt_class } # }}} -# clean_class_property {{{ -clean_class_property <- function (dt, property) { - col_del <- setdiff(CLASS_COLS$property, property) - if (length(col_del)) set(dt, NULL, col_del, NULL) - dt -} -# }}} # FIELD # get_idd_field {{{ +#' Get field data +#' +#' @param idd_env An environment or list contains IDD tables including class, +#' field, and reference. +#' @param class An integer vector of valid class indexes or a character vector +#' of valid class names or a data.table that contains column `class_id` +#' and `rleid`. If a data.table that contains a column `object_id`, that +#' column will be preserved. +#' @param field An integer vector of valid field indexes or a character +#' vector of valid field names (can be in in underscore style). `class` +#' and `field` should have the same length. +#' @param property A character vector of column names in field table to return. If +#' `NULL`, all columns from IDD field table will be returned, plus column +#' `rleid`, `object_id` (if applicable) and `matched_rleid` (if +#' `complete` is `TRUE`). +#' @param underscore If `TRUE`, input class name and field names will be +#' converted into underscore style name first and column `class_name_us` +#' and `field_name_us` will be used for matching. +#' @param no_ext If `TRUE`, no new extensible groups will be added even if there +#' are no matched input found and an error will be issued right away. +#' @param complete If `TRUE`, at least fields till the current whole extensible +#' group will be returned. A new column named "matched_rleid" will be +#' created (when `property` is NULL) indicating if given field has been +#' matched or not. +#' +#' @return A data.table containing specified columns. +#' @keywords internal +#' @export get_idd_field <- function (idd_env, class, field = NULL, property = NULL, all = FALSE, underscore = TRUE, no_ext = FALSE, complete = FALSE) { if (is.null(field)) { @@ -161,7 +190,7 @@ get_idd_field <- function (idd_env, class, field = NULL, property = NULL, all = } else { res <- get_idd_field_from_which(idd_env, class, field, underscore, no_ext, complete, all) } - if (has_name(res, "field_name_us")) set(res, NULL, "field_name_us", NULL) + if (has_names(res, "field_name_us")) set(res, NULL, "field_name_us", NULL) clean_field_property(res, property %||% "") res } @@ -185,29 +214,7 @@ get_idd_field_in_class <- function (idd_env, class, all = FALSE, underscore = TR } # }}} # get_idd_field_from_which {{{ -# Get specified field data -# @param idd_env An environment or list contains IDD tables including class, -# field, and reference. -# @param class An integer vector of valid class indexes or a character vector -# of valid class names or a data.table that contains column `class_id` -# and `rleid`. If a data.table that contains a column `object_id`, that -# column will be preserved. -# @param field An integer vector of valid field indexes or a character -# vector of valid field names (can be in in underscore style). `class` -# and `field` should have the same length. -# @param property A character vector of column names in field table to return. If -# `NULL`, all columns from IDD field table will be returned, plus column -# `rleid`, `object_id` (if applicable) and `matched_rleid` (if -# `complete` is `TRUE`). -# @param underscore If `TRUE`, input class name and field names will be -# converted into underscore style name first and column `class_name_us` -# and `field_name_us` will be used for matching. -# @param no_ext If `TRUE`, no new extensible groups will be added even if there -# are no matched input found and an error will be issued right away. -# @param complete If `TRUE`, at least fields till the current whole extensible -# group will be returned. A new column named "matched_rleid" will be -# created (when `property` is NULL) indicating if given field has been -# matched or not. +#' @importFrom checkmate test_integerish get_idd_field_from_which <- function (idd_env, class, field, underscore = TRUE, no_ext = FALSE, complete = FALSE, all = FALSE) { assert_valid_type(field, "field") @@ -239,9 +246,9 @@ get_idd_field_from_which <- function (idd_env, class, field, underscore = TRUE, } # }}} - assert(have_same_len(dt_in, field), prefix = "class and field") + assert_same_len(dt_in, field, "class and field") - if (all(are_count(field))) { + if (test_integerish(field, lower = 1L, any.missing = FALSE)) { # from field index {{{ field <- as.integer(field) set(dt_in, NULL, c("field_index", "field_in"), list(field, field)) @@ -255,7 +262,7 @@ get_idd_field_from_which <- function (idd_env, class, field, underscore = TRUE, # check invalid field index if (dt_in[field_in > acceptable_num, .N > 0L]) { invld_idx <- dt_in[field_in > acceptable_num] - abort_bad_field("error_bad_field_index", "index", invld_idx) + abort_bad_field("index", invld_idx) } # handle extensible fields @@ -266,7 +273,7 @@ get_idd_field_from_which <- function (idd_env, class, field, underscore = TRUE, # stop if adding new extensible groups is not allowed if (no_ext && nrow(dt_in[num > 0L])) { - abort_bad_field("error_bad_field_index", "index", dt_in[num > 0L]) + abort_bad_field("index", dt_in[num > 0L]) } # add extensible groups @@ -348,12 +355,12 @@ get_idd_field_from_which <- function (idd_env, class, field, underscore = TRUE, # invalid field names for non-extensible classes if (any(dt_nom$class_id %in% idd_env$class[J(0L), on = "num_extensible", class_id])) { invld_non_ext <- dt_nom[class_id %in% idd_env$class[J(0L), on = "num_extensible", class_id]] - abort_bad_field("error_bad_field_name", "name", clean_errnm_dt(invld_non_ext)) + abort_bad_field("name", clean_errnm_dt(invld_non_ext)) } # if all names not found are in extensible class if (no_ext) { - abort_bad_field("error_bad_field_name", "name", clean_errnm_dt(dt_nom)) + abort_bad_field("name", clean_errnm_dt(dt_nom)) } # get number of field names to check per class @@ -383,7 +390,7 @@ get_idd_field_from_which <- function (idd_env, class, field, underscore = TRUE, num_extensible_group = num_extensible_group + num )] idd_env <- del_idd_extensible_group(idd_env, dt_ext) - abort_bad_field("error_bad_field_name", "name", + abort_bad_field("name", add_class_property(idd_env, invld_nm, c("min_fields", "num_fields")), "\n\nNOTE: For extensible fields, new one will be added only ", "when all previous extensible groups exist." @@ -445,6 +452,7 @@ get_recursive_relation <- function (all_ref, init_ref, init_dep, max_dep, col_fld <- "field_id" col_val <- "value_id" } + if (!col_val %chin% names(init_ref)) col_val <- col_fld # this assume that one class-name-reference is always followed by one # field value reference @@ -480,7 +488,7 @@ get_recursive_relation <- function (all_ref, init_ref, init_dep, max_dep, while (dep < max_dep && nrow(cur_ref)) { # skip if specified classes/objects are matched if (!match_all && !is.null(include)) { - skip <- cur_ref[J(include), on = col_ref, .SD, .SDcols = col_rev, nomatch = 0L][[1L]] + skip <- unique(cur_ref[J(include), on = col_ref, col_rev, with = FALSE][[1L]]) if (length(skip)) { cur_ref <- cur_ref[!J(skip), on = col_rev] @@ -602,12 +610,56 @@ combine_input_and_relation <- function (input, ref, type, direction) { ref } # }}} + # get_idd_relation {{{ -get_idd_relation <- function (idd_env, class_id = NULL, field_id = NULL, direction = c("ref_to", "ref_by"), - class = NULL, group = NULL, depth = 0L, name = FALSE, keep_all = FALSE, match_all = FALSE) { - direction <- match.arg(direction) - assert(is.null(depth) || is_count(depth, TRUE)) +#' Get field relation data +#' +#' @param idd_env An environment or list contains IDD tables including class, +#' field, and reference. +#' @param class_id An integer vector of valid class indexes. Should be `NULL` if +#' `field_id` is given. +#' @param field_id An integer vector of valid field id. Should be `NULL` if +#' `class_id` is given. +#' @param direction The relation direction to extract. Should be one of +#' `"ref_to"` or `"ref_by"`. +#' @param underscore If `TRUE`, input class name and field names will be +#' converted into underscore style name first and column `class_name_us` +#' and `field_name_us` will be used for matching. +#' @param depth If > 0, the relation is searched recursively. If `NULL`, +#' all possible recursive relations are returned. Default: `0`. +#' @param name If `TRUE`, additional formatting columns are added and an +#' `IddRelation` object is returned. Default: `FALSE`. +#' @param class,group A character vector of group names used for searching +#' relations. Default: `NULL`. +#' @param keep If `TRUE`, all inputs are returned regardless they have any +#' relations with other fields or not. If `FALSE`, only input that have +#' relations with other fields are returned. Default: `FALSE`. +#' @param class_ref Specify how to handle class-name-references. There are 3 +#' options in total, i.e. `"none"`, `"both"` and `"all"`, with `"both"` +#' being the default. +#' * `"none"`: just ignore class-name-references. +#' * `"both"`: only include class-name-references if this object +#' also reference field values of the same one. This is the default +#' option. +#' * `"all"`: include all class-name-references. This is the most aggressive +#' option. +#' @param match_all If `TRUE`, relation search will continue even though one +#' relation has been found. If `FALSE`, searching is stopped whenever one +#' relation is found in specified classes/groups. Default: `FALSE`. +#' +#' @return A data.table. +#' +#' @keywords internal +#' @export +#' @importFrom checkmate assert_count +get_idd_relation <- function (idd_env, class_id = NULL, field_id = NULL, + direction = c("ref_to", "ref_by"), depth = 0L, name = FALSE, + class = NULL, group = NULL, keep_all = FALSE, + class_ref = c("both", "none", "all"), match_all = FALSE) { + assert_count(depth, null.ok = TRUE) if (is.null(depth)) depth <- Inf + direction <- match.arg(direction) + class_ref <- match.arg(class_ref) # get class reference if (is.null(field_id)) { @@ -622,8 +674,9 @@ get_idd_relation <- function (idd_env, class_id = NULL, field_id = NULL, directi if (is.null(class_id)) { id <- field_id } else { - warning("Both class id and field id are given.") - id <- intersect(field_id, get_idd_field(idd_env, class_id)$field_id) + abort("Should not specify both class id and field id at the same time", + "idd_relation" + ) } col_on <- "field_id" } @@ -637,6 +690,15 @@ get_idd_relation <- function (idd_env, class_id = NULL, field_id = NULL, directi all_ref <- idd_env$reference + if (class_ref == "none") { + both <- FALSE + all_ref <- all_ref[!J(IDDFIELD_SOURCE$class), on = "src_enum"] + } else if (class_ref == "all") { + both <- FALSE + } else if (class_ref == "both") { + both <- TRUE + } + # init depth dep <- 0L @@ -668,8 +730,12 @@ get_idd_relation <- function (idd_env, class_id = NULL, field_id = NULL, directi cur_ref <- cur_ref[J(cls_id), on = col_ref, nomatch = 0L] } + # no matched found for specified classes or groups + if (!is.null(cls_id) && !length(cls_id)) all_ref <- all_ref[0L] + # get recursive relation - ref <- get_recursive_relation(all_ref, cur_ref, dep, depth, col_ref, col_rev, cls_id, match_all = match_all) + ref <- get_recursive_relation(all_ref, cur_ref, dep, depth, col_ref, + col_rev, cls_id, both = both, match_all = match_all) # keep all input if (keep_all) ref <- combine_input_and_relation(fld, ref, "idd", direction) @@ -704,6 +770,7 @@ add_idd_relation_format_cols <- function (idd_env, ref) { } # }}} +# PROPERTY COLUMNS # add_class_id {{{ add_class_id <- function (idd_env, dt) { add_joined_cols(idd_env$class, dt, "class_name", "class_id") @@ -744,22 +811,20 @@ add_field_property <- function (idd_env, dt, property) { } # }}} +# UNIT CONVERSION # field_default_to_unit {{{ field_default_to_unit <- function (idd_env, dt_field, from, to) { - if (has_name(dt_field, "value_id")) { + if (has_names(dt_field, "value_id")) { value_id <- dt_field$value_id } else { value_id <- NULL } set(dt_field, NULL, "value_id", seq_along(dt_field$field_id)) - if (!has_name(dt_field, "default_chr")) { - add_field_property(idd_env, dt_field, "default_chr") - } - - if (!has_name(dt_field, "default_num")) { - add_field_property(idd_env, dt_field, "default_num") - } + cols_add <- NULL + if (!has_names(dt_field, "default_chr")) cols_add <- "default_chr" + if (!has_names(dt_field, "default_num")) cols_add <- c(cols_add, "default_num") + if (!is.null(cols_add)) add_field_property(idd_env, dt_field, cols_add) setnames(dt_field, c("default_chr", "default_num"), c("value_chr", "value_num")) @@ -778,11 +843,9 @@ add_idd_extensible_group <- function (idd_env, class, num = NULL, strict = FALSE # stop if non-extensible class found if (strict && nrow(dt_cls[num_extensible == 0L])) { - abort("error_nonextensible_class", - paste0("Non-extensible class found: ", - collapse(dt_cls[num_extensible == 0L, unique(class_name)]) - ) - ) + abort(paste0("Non-extensible class found: ", + collapse(dt_cls[num_extensible == 0L, unique(class_name)]) + ), "non_extensible_class") } ext <- dt_cls[num_extensible > 0L & num > 0L] @@ -897,13 +960,12 @@ del_idd_extensible_group <- function (idd_env, class, num = NULL, strict = FALSE # stop if non-extensible class found if (strict && nrow(dt_cls[num_extensible == 0L])) { - stop("Non-extensible class found: ", - collapse(dt_cls[num_extensible == 0L, unique(class_name)]), - call. = FALSE - ) + abort(paste0("Non-extensible class found: ", + collapse(dt_cls[num_extensible == 0L, unique(class_name)]) + ), "non_extensible_class") } - ext <- dt_cls[num_extensible > 0L] + ext <- dt_cls[num_extensible > 0L & num > 0L] if (!nrow(ext)) return(idd_env) @@ -923,7 +985,7 @@ del_idd_extensible_group <- function (idd_env, class, num = NULL, strict = FALSE less <- errormsg_info(less) mes <- less[, paste0(info, ": ", left_fields, " left with ", last_required, " required.")] mes <- paste0("Failed to delete extensible groups. Number of field(s) left less than required:\n", mes) - abort("error_del_extensible", mes, data = less) + abort(mes, data = less) } # get field id to delete @@ -945,19 +1007,20 @@ del_idd_extensible_group <- function (idd_env, class, num = NULL, strict = FALSE } # }}} # get_input_class_data {{{ +#' @importFrom checkmate assert_names assert_integerish get_input_class_data <- function (idd_env, class, num = NULL) { if (is.data.frame(class)) { dt_cls <- class - assert(has_name(dt_cls, - c("min_fields", "num_fields", "num_extensible", "last_required", "num_extensible_group") - )) + assert_names(names(dt_cls), + must.include = c("min_fields", "num_fields", "num_extensible", "last_required", "num_extensible_group") + ) if (is.null(num)) { - assert(has_name(dt_cls, "num")) + assert_names(names(dt_cls), must.include = "num") set(dt_cls, NULL, "num", as.integer(dt_cls$num)) } else { - assert(are_count(num)) - set(dt_cls, NULL, "num", as.integer(num)) + num <- assert_integerish(num, lower = 1L, any.missing = FALSE, coerce = TRUE) + set(dt_cls, NULL, "num", num) } } else { @@ -969,9 +1032,9 @@ get_input_class_data <- function (idd_env, class, num = NULL) { ) ) - assert(are_count(num)) - assert(have_same_len(class, num)) - set(dt_cls, NULL, "num", as.integer(num)) + num <- assert_integerish(num, lower = 1L, any.missing = FALSE, coerce = TRUE, len = 1L) + assert_same_len(class, num) + set(dt_cls, NULL, "num", num) } } # }}} @@ -992,9 +1055,10 @@ get_idd_table <- function (idd_env, class, all = FALSE) { # STRING # get_idd_string {{{ +#' @importFrom checkmate assert_count get_idd_string <- function (idd_env, class, leading = 4L, sep_at = 29L, sep_each = 0L, all = FALSE) { assert_valid_type(class, "class") - assert(is_count(sep_each, TRUE)) + assert_count(sep_each) fld <- get_idd_field(idd_env, class, property = c("units", "ip_units"), all = all) diff --git a/R/parse.R b/R/parse.R index d0b112c6e..7319f428c 100644 --- a/R/parse.R +++ b/R/parse.R @@ -1380,7 +1380,7 @@ convert_value_unit <- function (idd_env, dt_value, from, to, type = "value") { by = list(si, ip) ] - dt_value[val, on = "value_id", `:=`(value_num = val$value_num)] + dt_value[val, on = "value_id", `:=`(value_num = i.value_num, value_chr = as.character(i.value_num))] dt_value } diff --git a/man/get_idd_class.Rd b/man/get_idd_class.Rd new file mode 100644 index 000000000..664df871a --- /dev/null +++ b/man/get_idd_class.Rd @@ -0,0 +1,29 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/impl-idd.R +\name{get_idd_class} +\alias{get_idd_class} +\title{Get class data} +\usage{ +get_idd_class(idd_env, class = NULL, property = NULL, underscore = FALSE) +} +\arguments{ +\item{idd_env}{An environment or list contains IDD tables including class, +field, and reference.} + +\item{class}{An integer vector of valid class indexes or a character vector +of valid class names. If \code{NULL}, all classes are returned.} + +\item{property}{A character vector of column names in class table to return. +If \code{NULL}, only class index columns are returned, plus column \code{rleid}.} + +\item{underscore}{If \code{TRUE}, input class name will be converted into +underscore style name first and column \code{class_name_us} will be used +for matching.} +} +\value{ +A data.table containing specified columns. +} +\description{ +Get class data +} +\keyword{internal} diff --git a/man/get_idd_field.Rd b/man/get_idd_field.Rd new file mode 100644 index 000000000..b05910043 --- /dev/null +++ b/man/get_idd_field.Rd @@ -0,0 +1,54 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/impl-idd.R +\name{get_idd_field} +\alias{get_idd_field} +\title{Get field data} +\usage{ +get_idd_field( + idd_env, + class, + field = NULL, + property = NULL, + all = FALSE, + underscore = TRUE, + no_ext = FALSE, + complete = FALSE +) +} +\arguments{ +\item{idd_env}{An environment or list contains IDD tables including class, +field, and reference.} + +\item{class}{An integer vector of valid class indexes or a character vector +of valid class names or a data.table that contains column \code{class_id} +and \code{rleid}. If a data.table that contains a column \code{object_id}, that +column will be preserved.} + +\item{field}{An integer vector of valid field indexes or a character +vector of valid field names (can be in in underscore style). \code{class} +and \code{field} should have the same length.} + +\item{property}{A character vector of column names in field table to return. If +\code{NULL}, all columns from IDD field table will be returned, plus column +\code{rleid}, \code{object_id} (if applicable) and \code{matched_rleid} (if +\code{complete} is \code{TRUE}).} + +\item{underscore}{If \code{TRUE}, input class name and field names will be +converted into underscore style name first and column \code{class_name_us} +and \code{field_name_us} will be used for matching.} + +\item{no_ext}{If \code{TRUE}, no new extensible groups will be added even if there +are no matched input found and an error will be issued right away.} + +\item{complete}{If \code{TRUE}, at least fields till the current whole extensible +group will be returned. A new column named "matched_rleid" will be +created (when \code{property} is NULL) indicating if given field has been +matched or not.} +} +\value{ +A data.table containing specified columns. +} +\description{ +Get field data +} +\keyword{internal} diff --git a/man/get_idd_relation.Rd b/man/get_idd_relation.Rd new file mode 100644 index 000000000..701b89e06 --- /dev/null +++ b/man/get_idd_relation.Rd @@ -0,0 +1,71 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/impl-idd.R +\name{get_idd_relation} +\alias{get_idd_relation} +\title{Get field relation data} +\usage{ +get_idd_relation( + idd_env, + class_id = NULL, + field_id = NULL, + direction = c("ref_to", "ref_by"), + depth = 0L, + name = FALSE, + class = NULL, + group = NULL, + keep_all = FALSE, + class_ref = c("both", "none", "all"), + match_all = FALSE +) +} +\arguments{ +\item{idd_env}{An environment or list contains IDD tables including class, +field, and reference.} + +\item{class_id}{An integer vector of valid class indexes. Should be \code{NULL} if +\code{field_id} is given.} + +\item{field_id}{An integer vector of valid field id. Should be \code{NULL} if +\code{class_id} is given.} + +\item{direction}{The relation direction to extract. Should be one of +\code{"ref_to"} or \code{"ref_by"}.} + +\item{depth}{If > 0, the relation is searched recursively. If \code{NULL}, +all possible recursive relations are returned. Default: \code{0}.} + +\item{name}{If \code{TRUE}, additional formatting columns are added and an +\code{IddRelation} object is returned. Default: \code{FALSE}.} + +\item{class, group}{A character vector of group names used for searching +relations. Default: \code{NULL}.} + +\item{class_ref}{Specify how to handle class-name-references. There are 3 +options in total, i.e. \code{"none"}, \code{"both"} and \code{"all"}, with \code{"both"} +being the default. +* \code{"none"}: just ignore class-name-references. +* \code{"both"}: only include class-name-references if this object +also reference field values of the same one. This is the default +option. +* \code{"all"}: include all class-name-references. This is the most aggressive +option.} + +\item{match_all}{If \code{TRUE}, relation search will continue even though one +relation has been found. If \code{FALSE}, searching is stopped whenever one +relation is found in specified classes/groups. Default: \code{FALSE}.} + +\item{underscore}{If \code{TRUE}, input class name and field names will be +converted into underscore style name first and column \code{class_name_us} +and \code{field_name_us} will be used for matching.} + +\item{keep}{If \code{TRUE}, all inputs are returned regardless they have any +relations with other fields or not. If \code{FALSE}, only input that have +relations with other fields are returned. Default: \code{FALSE}.} +} +\value{ +A data.table. +} +\description{ +Get field relation data +} +\keyword{internal} diff --git a/tests/testthat/test_impl-idd.R b/tests/testthat/test_impl-idd.R index ff75d9a23..a7f3bf9fb 100644 --- a/tests/testthat/test_impl-idd.R +++ b/tests/testthat/test_impl-idd.R @@ -1,24 +1,27 @@ -context("IDD Implementation") - # IDD {{{ -test_that("table manipulation", { +test_that("IDD implementation", { expect_silent(idd_parsed <- parse_idd_file(text("idd", "9.9.9"))) # GROUP {{{ expect_equal(get_idd_group_index(idd_parsed), 1L:2L) expect_equal(get_idd_group_index(idd_parsed, "TestGroup2"), 2L) - expect_error(get_idd_group_index(idd_parsed, "Wrong"), class = "error_group_name") + expect_error(get_idd_group_index(idd_parsed, "Wrong"), class = "eplusr_error_invalid_group_name") expect_equal(get_idd_group_name(idd_parsed), c("TestGroup1", "TestGroup2")) expect_equal(get_idd_group_name(idd_parsed, 2L), "TestGroup2") - expect_error(get_idd_group_name(idd_parsed, 3), class = "error_group_id") + expect_error(get_idd_group_name(idd_parsed, 3), class = "eplusr_error_invalid_group_index") # }}} # CLASS {{{ - expect_equal(get_idd_class(idd_parsed), + expect_equivalent(get_idd_class(idd_parsed), idd_parsed$class[, .SD, .SDcols = c("class_id", "class_name", "group_id")] ) - expect_error(get_idd_class(idd_parsed, ""), class = "error_class_name") - expect_error(get_idd_class(idd_parsed, 10L), class = "error_class_id") + expect_equivalent(get_idd_class(idd_parsed, property = "group_name"), + set(idd_parsed$class[, .SD, .SDcols = c("class_id", "class_name", "group_id")], + NULL, "group_name", c("TestGroup1", "TestGroup2") + ) + ) + expect_error(get_idd_class(idd_parsed, ""), class = "eplusr_error_invalid_class_name") + expect_error(get_idd_class(idd_parsed, 10L), class = "eplusr_error_invalid_class_index") expect_equal( get_idd_class(idd_parsed, c(2L, 1L)), @@ -51,12 +54,19 @@ test_that("table manipulation", { min_fields = c(0L, 3L) ) ) + + expect_equivalent(get_idd_class_field_num(copy(idd_parsed$class)), + set(copy(idd_parsed$class), NULL, c("input_num", "acceptable_num"), list(0L, c(0L, 3L))) + ) + expect_equivalent(names(get_idd_class_field_num(idd_parsed$class[0L])), + names(set(idd_parsed$class[0L], NULL, c("input_num", "acceptable_num"), integer(0))[]) + ) # }}} # EXTENSIBLE GROUP {{{ # ADD {{{ expect_equal(add_idd_extensible_group(idd_parsed, "TestSimple", 1)$field, idd_parsed$field) - expect_error(add_idd_extensible_group(idd_parsed, "TestSimple", 1, strict = TRUE), class = "error_nonextensible_class") + expect_error(add_idd_extensible_group(idd_parsed, "TestSimple", 1, strict = TRUE), "Non-extensible class", class = "eplusr_error_non_extensible_class") expect_equal(nrow(idd_added <- add_idd_extensible_group(idd_parsed, "TestSlash", 2)$field), 13L) expect_equal(nrow((idd_added <- add_idd_extensible_group(idd_parsed, "TestSlash", 1))$field), 9L) expect_equal(idd_added$class$num_fields[2L], 8L) @@ -88,17 +98,18 @@ test_that("table manipulation", { ) # }}} # DEL {{{ + expect_error(del_idd_extensible_group(idd_parsed, "TestSimple", 1, strict = TRUE), "Non-extensible class", class = "eplusr_error_non_extensible_class") expect_equivalent((idd_del <- del_idd_extensible_group(idd_added, "TestSlash", 1))$field, idd_parsed$field) expect_equal(idd_del$class$num_fields[2L], 4L) expect_equal(idd_del$class$num_extensible_group[2L], 1L) - expect_error(del_idd_extensible_group(idd_del, "TestSlash", 4), class = "error_del_extensible") + expect_error(del_idd_extensible_group(idd_del, "TestSlash", 4), "0 left with 1 required", class = "eplusr_error") # }}} # }}} # FIELD {{{ ## USING CLASS {{{ - expect_error(get_idd_field(idd_parsed, 10), class = "error_class_id") - expect_error(get_idd_field(idd_parsed, ""), class = "error_class_name_us") + expect_error(get_idd_field(idd_parsed, 10), class = "eplusr_error_invalid_class_index") + expect_error(get_idd_field(idd_parsed, ""), class = "eplusr_error_invalid_class_name") expect_equal(get_idd_field(idd_parsed, c("TestSimple", "TestSlash")), data.table(field_id = 1:4, class_id = c(1L, rep(2L, 3)), field_index = c(1L, 1:3), @@ -126,9 +137,9 @@ test_that("table manipulation", { ) # }}} ## USING FIELD INDEX {{{ - expect_error(get_idd_field(idd_parsed, c("TestSimple", "TestSlash"), c(2, 2)), class = "error_bad_field_index") - expect_error(get_idd_field(idd_parsed, c("TestSimple", "TestSlash"), c(2, 2, 3)), class = "error_not_have_same_len") - expect_error(get_idd_field(idd_parsed, c("TestSimple", "TestSlash"), c(1, 10), no_ext = TRUE), class = "error_bad_field_index") + expect_error(get_idd_field(idd_parsed, c("TestSimple", "TestSlash"), c(2, 2)), class = "eplusr_error_invalid_field_index") + expect_error(get_idd_field(idd_parsed, c("TestSimple", "TestSlash"), c(2, 2, 3)), "Must have same length") + expect_error(get_idd_field(idd_parsed, c("TestSimple", "TestSlash"), c(1, 10), no_ext = TRUE), class = "eplusr_error_invalid_field_index") expect_equal(get_idd_field(idd_parsed, c("TestSimple", "TestSlash", "TestSlash"), c(1, 3, 99)), data.table(field_id = c(1L, 4L, 100L), class_id = c(1L, 2L, 2L), field_index = c(1L, 3L, 99L), @@ -137,6 +148,17 @@ test_that("table manipulation", { field_in = c(1L, 3L, 99L) ) ) + expect_silent({fld <- get_idd_field(idd_parsed, c("TestSlash", "TestSlash"), c(3, 19), all = TRUE)}) + expect_equal(fld, + data.table(field_id = c(2:5, 2:21), class_id = rep(2L, 24), field_index = c(1:4, 1:20), + field_name = paste0( + rep(c("Test Character Field ", "Test Numeric Field ", "Test Numeric Field ", "Test Character Field "), times = 6), + c(rep(1:2, each = 2), rep(1:10, each = 2)) + ), + rleid = c(rep(1L, 4), rep(2L, 20)), class_name = rep("TestSlash", 24), + field_in = c(rep(NA_real_, 2), 3L, rep(NA_real_, 19), 19L, NA_real_) + ) + ) expect_silent({fld <- get_idd_field(idd_parsed, c("TestSlash", "TestSlash"), c(3, 19), complete = TRUE)}) expect_equal(fld, data.table(field_id = c(2:5, 2:21), class_id = rep(2L, 24), field_index = c(1:4, 1:20), @@ -168,9 +190,15 @@ test_that("table manipulation", { ) ) ) - expect_error(get_idd_field(idd_parsed, "TestSimple", ""), class = "error_bad_field_name") - expect_error(get_idd_field(idd_parsed, "TestSlash", ""), class = "error_bad_field_name") - expect_error(get_idd_field(idd_parsed, "TestSlash", "", no_ext = TRUE), class = "error_bad_field_name") + expect_error(get_idd_field(idd_parsed, "TestSimple", ""), class = "eplusr_error_invalid_field_name") + expect_error(get_idd_field(idd_parsed, "TestSlash", ""), class = "eplusr_error_invalid_field_name") + expect_error(get_idd_field(idd_parsed, "TestSlash", "", no_ext = TRUE), class = "eplusr_error_invalid_field_name") + expect_equal(get_idd_field(idd_parsed, 1L, "Test Field", underscore = FALSE), + data.table(field_id = 1L, class_id = 1L, field_index = 1L, + field_name = "Test Field", rleid = 1L, class_name = "TestSimple", + field_in = "Test Field" + ) + ) expect_equal(get_idd_field(idd_parsed, c(1L, 2L), c("test_field", "test_numeric_field_3")), data.table(field_id = c(1L, 7L), class_id = c(1L, 2L), field_index = c(1L, 6L), field_name = c("Test Field", "Test Numeric Field 3"), @@ -178,6 +206,19 @@ test_that("table manipulation", { field_in = c("test_field", "test_numeric_field_3") ) ) + expect_equal(get_idd_field(idd_parsed, c(1L, 2L), c("test_field", "test_numeric_field_3"), all = TRUE), + data.table(field_id = 1:9, class_id = c(1L, rep(2L, 8)), field_index = c(1L, 1:8), + field_name = c("Test Field", + paste0( + rep(c("Test Character Field ", "Test Numeric Field ", "Test Numeric Field ", "Test Character Field "), 2), + rep(1:4, each = 2) + )), + rleid = c(1L, rep(2L, 8)), class_name = c("TestSimple", rep("TestSlash", 8)), + field_in = c("test_field", rep(NA_character_, 5), + "test_numeric_field_3", rep(NA_character_, 2) + ) + ) + ) expect_equal(get_idd_field(idd_parsed, c(1L, 2L), c("test_field", "test_numeric_field_3"), complete = TRUE), data.table(field_id = 1:9, class_id = c(1L, rep(2L, 8)), field_index = c(1L, 1:8), field_name = c("Test Field", @@ -191,6 +232,7 @@ test_that("table manipulation", { ) ) ) + expect_equal(nrow(get_idd_field(idd_parsed, 2L, "test_numeric_field_3", all = TRUE)), 8L) # }}} # }}} @@ -215,35 +257,86 @@ test_that("table manipulation", { src_enum = 2L, dep = 0L ) ) + + idd <- use_idd(8.8, "auto") + idd_env <- ._get_private(idd)$idd_env() + fld <- get_idd_field(idd_env, "Construction") + expect_equal(nrow(get_idd_relation(idd_env, field_id = fld$field_id, direction = "ref_to", keep_all = TRUE, depth = 0L)), 15L) + + fld <- get_idd_field(idd_env, "Material") + expect_equal(nrow(get_idd_relation(idd_env, field_id = fld$field_id, direction = "ref_to", depth = NULL)), 0L) + expect_equal(nrow(get_idd_relation(idd_env, class_id = fld$class_id, direction = "ref_to", depth = NULL)), 0L) + expect_error(get_idd_relation(idd_env, class_id = fld$class_id, field_id = fld$field_id), class = "eplusr_error_idd_relation") + + fld <- get_idd_field(idd_env, "Construction") + expect_equal(nrow(get_idd_relation(idd_env, field_id = fld$field_id, direction = "ref_by", keep_all = TRUE, depth = 2L)), 29697L) + + fld <- get_idd_field(idd_env, "Construction", 2L) + expect_equal(nrow(get_idd_relation(idd_env, field_id = fld$field_id, direction = "ref_to", depth = 0L)), 14L) + + fld <- get_idd_field(idd_env, "Construction", 1L) + expect_equal(nrow(get_idd_relation(idd_env, field_id = fld$field_id, direction = "ref_by", depth = 3L, class = "PlantEquipmentOperationSchemes")), 212L) + + fld <- get_idd_field(idd_env, "Branch", 3:4) + expect_equal(nrow(get_idd_relation(idd_env, field_id = fld$field_id, direction = "ref_to", depth = 0L)), 123L) + + fld <- get_idd_field(idd_env, "Pump:ConstantSpeed") + expect_equal(nrow(get_idd_relation(idd_env, field_id = fld$field_id, direction = "ref_by", + group = "Node-Branch Management", depth = 2L)), 11L) + fld <- get_idd_field(idd_env, "Branch", 1:4, property = "type_enum") + expect_equal(nrow(get_idd_relation(idd_env, field_id = fld$field_id, direction = "ref_to", + class_ref = "none", group = "Node-Branch Management", depth = 0L)), 7L) + expect_equal(nrow(get_idd_relation(idd_env, field_id = fld$field_id, direction = "ref_to", + class_ref = "all", group = "Node-Branch Management", depth = 0L)), 14L) + # }}} + + # PROPERTY COLUMNS {{{ + dt_in <- idd_env$class[1:5, .(class_name)] + expect_equal(add_class_id(idd_env, dt_in), set(dt_in, NULL, "class_id", list(1:5))) + + dt_in <- idd_env$class[1:3, .(class_id)] + expect_equal(add_class_name(idd_env, dt_in), + set(dt_in, NULL, "class_name", list(c("Version", "SimulationControl", "Building")))) + + dt_in <- idd_env$class[1:3, .(class_id)] + expect_equal(add_class_property(idd_env, dt_in, c("group_name", "num_fields")), + set(dt_in, NULL, c("num_fields", "group_name"), list(c(1L, 7:8), "Simulation Parameters"))) + dt_in <- idd_env$class[1:3, .(class_id, group_id)] + expect_equal(add_class_property(idd_env, dt_in, c("group_name", "num_fields")), + set(dt_in, NULL, c("num_fields", "group_name"), list(c(1L, 7:8), "Simulation Parameters"))) + + dt_in <- idd_env$field[1:3, .(field_id)] + expect_equal(add_field_property(idd_env, dt_in, "type_enum"), + set(dt_in, NULL, "type_enum", list(c(4L, 3L, 3L)))) + # }}} + + # UNIT CONVERSION {{{ + fld <- get_idd_field(idd_env, "WindowMaterial:Glazing:RefractionExtinctionMethod", 9, property = c("units", "ip_units")) + expect_equal(field_default_to_unit(idd_env, fld, "si", "ip")$default_num, + drop_units(set_units(set_units(0.9, "W/m/K"), "Btu*in/h/ft^2/degF")) + ) + + # can keep input value_id + fld <- get_idd_field(idd_env, "Material", 1:6) + set(fld, NULL, "value_id", 1:6) + expect_equal(field_default_to_unit(idd_env, fld, "si", "ip")$value_id, 1:6) # }}} # TABLE {{{ - expect_equal(get_iddobj_table(idd_parsed, 1), + expect_equal(get_idd_table(idd_parsed, 1), data.table(class = "TestSimple", index = 1L, field = "Test Field") ) # }}} # STRING {{{ - expect_equal(get_iddobj_string(idd_parsed, 2, leading = 0L, sep_at = 0L), + expect_equal(get_idd_string(idd_parsed, 2, leading = 0L, sep_at = 0L), c("TestSlash,", ",!- Test Character Field 1", ",!- Test Numeric Field 1 {m}", ";!- Test Numeric Field 2" ) - ) - expect_equal(get_iddobj_string(idd_parsed, 2, comment = c("This is", "a comment"), leading = 0L, sep_at = 0L), - c("!This is", - "!a comment", - "", - "TestSlash,", - ",!- Test Character Field 1", - ",!- Test Numeric Field 1 {m}", - ";!- Test Numeric Field 2" - ) - ) # }}} - }) # }}} From abc760ef9b3148f6f492bc6379a5105bd405e6b8 Mon Sep 17 00:00:00 2001 From: Hongyuan Jia Date: Wed, 15 Apr 2020 14:27:07 +0800 Subject: [PATCH 14/43] [refactor] Export 'get_*_env()' internal functions --- NAMESPACE | 2 ++ R/parse.R | 4 +-- R/reload.R | 18 +++++----- R/utils.R | 28 +++++++++++++--- man/get_env.Rd | 29 ++++++++++++++++ tests/testthat/test_impl-idd.R | 2 +- tests/testthat/test_reload.R | 60 +++++++++++++++++----------------- 7 files changed, 97 insertions(+), 46 deletions(-) create mode 100644 man/get_env.Rd diff --git a/NAMESPACE b/NAMESPACE index 67bc9002b..aee59dfab 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -105,6 +105,8 @@ export(eplusr_option) export(get_idd_class) export(get_idd_field) export(get_idd_relation) +export(get_priv_env) +export(get_self_env) export(group_job) export(idd_object) export(idf_object) diff --git a/R/parse.R b/R/parse.R index 7319f428c..907ea2ada 100644 --- a/R/parse.R +++ b/R/parse.R @@ -179,8 +179,8 @@ parse_idf_file <- function (path, idd = NULL, ref = TRUE) { } # get idd version and table - idd_ver <- ._get_private(idd)$m_version - idd_env <- ._get_private(idd)$m_idd_env + idd_ver <- get_priv_env(idd)$m_version + idd_env <- get_priv_env(idd)$m_idd_env # insert version line if necessary if (is.null(idf_ver)) idf_dt <- insert_version(idf_dt, idd_ver) diff --git a/R/reload.R b/R/reload.R index 7b3b222a6..6cde2f3fa 100644 --- a/R/reload.R +++ b/R/reload.R @@ -54,27 +54,27 @@ reload.default <- function (x, ...) { #' @export reload.Idf <- function (x, ...) { - reload_idd_env(._get_private(x)$idd_env()) - reload_idf_env(._get_private(x)$idf_env()) - reload_log_env(._get_private(x)$log_env()) + reload_idd_env(get_priv_env(x)$idd_env()) + reload_idf_env(get_priv_env(x)$idf_env()) + reload_log_env(get_priv_env(x)$log_env()) x } #' @export reload.Idd <- function (x, ...) { - reload_idd_env(._get_private(x)$m_idd_env) + reload_idd_env(get_priv_env(x)$m_idd_env) x } #' @export reload.IddObject <- function (x, ...) { - reload_idd_env(._get_private(x)$idd_env()) + reload_idd_env(get_priv_env(x)$idd_env()) x } #' @export reload.Epw <- function (x, ...) { - priv <- ._get_private(x) + priv <- get_priv_env(x) priv$m_header$typical <- setDT(priv$m_header$typical) priv$m_header$ground <- setDT(priv$m_header$ground) priv$m_header$holiday$holiday <- setDT(priv$m_header$holiday$holiday) @@ -85,13 +85,13 @@ reload.Epw <- function (x, ...) { #' @export reload.EplusJob <- function (x, ...) { - reload.Idf(._get_private(x)$m_idf) + reload.Idf(get_priv_env(x)$m_idf) x } #' @export reload.EplusGroupJob <- function (x, ...) { - priv <- ._get_private(x) + priv <- get_priv_env(x) for (idf in priv$m_idfs) reload.Idf(idf, ...) if (inherits(priv$m_job, "data.table")) priv$m_job <- setDT(priv$m_job) @@ -100,7 +100,7 @@ reload.EplusGroupJob <- function (x, ...) { #' @export reload.ParametricJob <- function (x, ...) { - priv <- ._get_private(x) + priv <- get_priv_env(x) reload.Idf(priv$m_seed) if (!is.null(priv$m_idfs)) for (idf in priv$m_idfs) reload.Idf(idf, ...) diff --git a/R/utils.R b/R/utils.R index 41853802d..2a22ba765 100644 --- a/R/utils.R +++ b/R/utils.R @@ -47,14 +47,34 @@ surround <- function (x, out = "'") { } # }}} -# `._get_self`{{{ -`._get_self` <- function (x) { +# `get_self_env`{{{ +#' Get the enclosed environment of an R6 object +#' +#' @details +#' +#' `get_self_env()` returns the `self` enclosed environment of an [R6::R6Class()] +#' object. +#' +#' `get_priv_env()` returns the `private` enclosed environment of an [R6::R6Class()] +#' object. +#' +#' @param x An R6 object. +#' +#' @return An environment. +#' +#' @keywords internal +#' @export +#' @name get_env +`get_self_env` <- function (x) { .subset2(.subset2(x, ".__enclos_env__"), "self") } # }}} -# `._get_private`{{{ -`._get_private` <- function (x) { +# `get_priv_env`{{{ +#' @keywords internal +#' @export +#' @name get_env +`get_priv_env` <- function (x) { .subset2(.subset2(x, ".__enclos_env__"), "private") } # }}} diff --git a/man/get_env.Rd b/man/get_env.Rd new file mode 100644 index 000000000..d35789b3e --- /dev/null +++ b/man/get_env.Rd @@ -0,0 +1,29 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils.R +\name{get_env} +\alias{get_env} +\alias{get_self_env} +\alias{get_priv_env} +\title{Get the enclosed environment of an R6 object} +\usage{ +get_self_env(x) + +get_priv_env(x) +} +\arguments{ +\item{x}{An R6 object.} +} +\value{ +An environment. +} +\description{ +Get the enclosed environment of an R6 object +} +\details{ +\code{get_self_env()} returns the \code{self} enclosed environment of an \code{\link[R6:R6Class]{R6::R6Class()}} +object. + +\code{get_priv_env()} returns the \code{private} enclosed environment of an \code{\link[R6:R6Class]{R6::R6Class()}} +object. +} +\keyword{internal} diff --git a/tests/testthat/test_impl-idd.R b/tests/testthat/test_impl-idd.R index a7f3bf9fb..cf8eb1c05 100644 --- a/tests/testthat/test_impl-idd.R +++ b/tests/testthat/test_impl-idd.R @@ -259,7 +259,7 @@ test_that("IDD implementation", { ) idd <- use_idd(8.8, "auto") - idd_env <- ._get_private(idd)$idd_env() + idd_env <- get_priv_env(idd)$idd_env() fld <- get_idd_field(idd_env, "Construction") expect_equal(nrow(get_idd_relation(idd_env, field_id = fld$field_id, direction = "ref_to", keep_all = TRUE, depth = 0L)), 15L) diff --git a/tests/testthat/test_reload.R b/tests/testthat/test_reload.R index 4cc7e9400..b045e0293 100644 --- a/tests/testthat/test_reload.R +++ b/tests/testthat/test_reload.R @@ -32,18 +32,18 @@ test_that("Reload", { grp <- readRDS(f_grp) par <- readRDS(f_par) - expect_equal(data.table::truelength(._get_private(idf)$idd_env()$group), 0L) - expect_equal(data.table::truelength(._get_private(idf)$idd_env()$class), 0L) - expect_equal(data.table::truelength(._get_private(idf)$idd_env()$field), 0L) - expect_equal(data.table::truelength(._get_private(idf)$idd_env()$reference), 0L) - expect_equal(data.table::truelength(._get_private(idf)$idf_env()$object), 0L) - expect_equal(data.table::truelength(._get_private(idf)$idf_env()$value), 0L) - expect_equal(data.table::truelength(._get_private(idf)$idf_env()$reference), 0L) - expect_equal(data.table::truelength(._get_private(epw)$m_header$typical), 0L) - expect_equal(data.table::truelength(._get_private(epw)$m_header$ground), 0L) - expect_equal(data.table::truelength(._get_private(epw)$m_header$holiday$holiday), 0L) - expect_equal(data.table::truelength(._get_private(epw)$m_header$period$period), 0L) - expect_equal(data.table::truelength(._get_private(epw)$m_data), 0L) + expect_equal(data.table::truelength(get_priv_env(idf)$idd_env()$group), 0L) + expect_equal(data.table::truelength(get_priv_env(idf)$idd_env()$class), 0L) + expect_equal(data.table::truelength(get_priv_env(idf)$idd_env()$field), 0L) + expect_equal(data.table::truelength(get_priv_env(idf)$idd_env()$reference), 0L) + expect_equal(data.table::truelength(get_priv_env(idf)$idf_env()$object), 0L) + expect_equal(data.table::truelength(get_priv_env(idf)$idf_env()$value), 0L) + expect_equal(data.table::truelength(get_priv_env(idf)$idf_env()$reference), 0L) + expect_equal(data.table::truelength(get_priv_env(epw)$m_header$typical), 0L) + expect_equal(data.table::truelength(get_priv_env(epw)$m_header$ground), 0L) + expect_equal(data.table::truelength(get_priv_env(epw)$m_header$holiday$holiday), 0L) + expect_equal(data.table::truelength(get_priv_env(epw)$m_header$period$period), 0L) + expect_equal(data.table::truelength(get_priv_env(epw)$m_data), 0L) expect_silent(reload(idf)) expect_silent(reload(epw)) @@ -52,28 +52,28 @@ test_that("Reload", { expect_silent(reload(par)) expect_idf_reloaded <- function (idf) { - expect_true(data.table::truelength(._get_private(idf)$idd_env()$group) > 0L) - expect_true(data.table::truelength(._get_private(idf)$idd_env()$class) > 0L) - expect_true(data.table::truelength(._get_private(idf)$idd_env()$field) > 0L) - expect_true(data.table::truelength(._get_private(idf)$idd_env()$reference) > 0L) - expect_true(data.table::truelength(._get_private(idf)$idf_env()$object) > 0L) - expect_true(data.table::truelength(._get_private(idf)$idf_env()$value) > 0L) - expect_true(data.table::truelength(._get_private(idf)$idf_env()$reference) > 0L) + expect_true(data.table::truelength(get_priv_env(idf)$idd_env()$group) > 0L) + expect_true(data.table::truelength(get_priv_env(idf)$idd_env()$class) > 0L) + expect_true(data.table::truelength(get_priv_env(idf)$idd_env()$field) > 0L) + expect_true(data.table::truelength(get_priv_env(idf)$idd_env()$reference) > 0L) + expect_true(data.table::truelength(get_priv_env(idf)$idf_env()$object) > 0L) + expect_true(data.table::truelength(get_priv_env(idf)$idf_env()$value) > 0L) + expect_true(data.table::truelength(get_priv_env(idf)$idf_env()$reference) > 0L) } - expect_true(data.table::truelength(._get_private(epw)$m_header$typical) > 0L) - expect_true(data.table::truelength(._get_private(epw)$m_header$ground) > 0L) - expect_true(data.table::truelength(._get_private(epw)$m_header$holiday$holiday) > 0L) - expect_true(data.table::truelength(._get_private(epw)$m_header$period$period) > 0L) - expect_true(data.table::truelength(._get_private(epw)$m_data) > 0L) + expect_true(data.table::truelength(get_priv_env(epw)$m_header$typical) > 0L) + expect_true(data.table::truelength(get_priv_env(epw)$m_header$ground) > 0L) + expect_true(data.table::truelength(get_priv_env(epw)$m_header$holiday$holiday) > 0L) + expect_true(data.table::truelength(get_priv_env(epw)$m_header$period$period) > 0L) + expect_true(data.table::truelength(get_priv_env(epw)$m_data) > 0L) expect_idf_reloaded(idf) - expect_idf_reloaded(._get_private(job)$m_idf) - expect_idf_reloaded(._get_private(par)$m_seed) - lapply(._get_private(grp)$m_idfs, expect_idf_reloaded) - lapply(._get_private(par)$m_idfs, expect_idf_reloaded) - expect_true(data.table::truelength(._get_private(grp)$m_job) > 0L) - expect_true(data.table::truelength(._get_private(par)$m_job) > 0L) + expect_idf_reloaded(get_priv_env(job)$m_idf) + expect_idf_reloaded(get_priv_env(par)$m_seed) + lapply(get_priv_env(grp)$m_idfs, expect_idf_reloaded) + lapply(get_priv_env(par)$m_idfs, expect_idf_reloaded) + expect_true(data.table::truelength(get_priv_env(grp)$m_job) > 0L) + expect_true(data.table::truelength(get_priv_env(par)$m_job) > 0L) expect_true(job$status()$successful) expect_true(grp$status()$successful) From b2e4e17cafc5449a8a5c54c29095f1d223afe566 Mon Sep 17 00:00:00 2001 From: Hongyuan Jia Date: Wed, 15 Apr 2020 14:29:35 +0800 Subject: [PATCH 15/43] [doc] Update NEWS --- NEWS.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/NEWS.md b/NEWS.md index 1c10a7eb4..ca0c44e6a 100644 --- a/NEWS.md +++ b/NEWS.md @@ -51,6 +51,8 @@ sure they are initialized properly. It is recommended to call `reload()` on each `Idd`, `Idf` and other class object in eplusr loaded with `readRDS()` or `load()`, to make sure all eplusr's functionaries works properly (#251). +* Some internal functions have been exported. They are mainly useful for + developers to handle internal IDD and IDF data more efficiently. ## Major changes From 246ba0dab4c234490d9f5431a2c6bdac2d850cdd Mon Sep 17 00:00:00 2001 From: Hongyuan Jia Date: Wed, 15 Apr 2020 22:41:18 +0800 Subject: [PATCH 16/43] [refactor] Clean up checkmate imports --- R/impl-idd.R | 13 ++++--------- R/impl.R | 6 ++---- R/options.R | 6 ++++-- R/parse.R | 4 +--- R/run.R | 4 ++-- R/utils.R | 5 ++--- 6 files changed, 15 insertions(+), 23 deletions(-) diff --git a/R/impl-idd.R b/R/impl-idd.R index 6e59e199c..36e875531 100644 --- a/R/impl-idd.R +++ b/R/impl-idd.R @@ -1,4 +1,6 @@ #' @importFrom cli cat_bullet cat_line cat_rule rule symbol +#' @importFrom checkmate assert_count assert_names assert_integerish +#' @importFrom checkmate test_integerish assert_integer assert_character #' @importFrom data.table copy data.table dcast rbindlist #' @importFrom data.table setattr setcolorder setnames setorder setorderv #' @importFrom stringi stri_locate_first_regex stri_replace_first_regex "stri_sub<-" @@ -8,11 +10,10 @@ NULL # GROUP # get_idd_group_index {{{ -#' @importFrom checkmate assert_string get_idd_group_index <- function (idd_env, group = NULL) { if (is.null(group)) return(idd_env$group$group_id) - assert_string(group) + assert_character(group, any.missing = FALSE) res <- idd_env$group[J(group), on = "group_name", group_id] if (anyNA(res)) abort_bad_key("group name", group) @@ -20,11 +21,10 @@ get_idd_group_index <- function (idd_env, group = NULL) { } # }}} # get_idd_group_name {{{ -#' @importFrom checkmate assert_count get_idd_group_name <- function (idd_env, group = NULL) { if (is.null(group)) return(idd_env$group$group_name) - assert_count(group, positive = TRUE) + assert_integerish(group, lower = 1L, any.missing = FALSE) res <- idd_env$group[J(group), on = "group_id", group_name] if (anyNA(res)) abort_bad_key("group index", group) @@ -103,7 +103,6 @@ get_idd_class <- function (idd_env, class = NULL, property = NULL, underscore = # * If input number is larger than the total existing field number: # - The acceptable field number will be the field index of the last # field in the last extensible group. -#' @importFrom checkmate assert_integer assert_names get_idd_class_field_num <- function (dt_class, num = NULL) { assert_integer(num, lower = 1L, any.missing = FALSE, null.ok = TRUE) @@ -214,7 +213,6 @@ get_idd_field_in_class <- function (idd_env, class, all = FALSE, underscore = TR } # }}} # get_idd_field_from_which {{{ -#' @importFrom checkmate test_integerish get_idd_field_from_which <- function (idd_env, class, field, underscore = TRUE, no_ext = FALSE, complete = FALSE, all = FALSE) { assert_valid_type(field, "field") @@ -651,7 +649,6 @@ combine_input_and_relation <- function (input, ref, type, direction) { #' #' @keywords internal #' @export -#' @importFrom checkmate assert_count get_idd_relation <- function (idd_env, class_id = NULL, field_id = NULL, direction = c("ref_to", "ref_by"), depth = 0L, name = FALSE, class = NULL, group = NULL, keep_all = FALSE, @@ -1007,7 +1004,6 @@ del_idd_extensible_group <- function (idd_env, class, num = NULL, strict = FALSE } # }}} # get_input_class_data {{{ -#' @importFrom checkmate assert_names assert_integerish get_input_class_data <- function (idd_env, class, num = NULL) { if (is.data.frame(class)) { dt_cls <- class @@ -1055,7 +1051,6 @@ get_idd_table <- function (idd_env, class, all = FALSE) { # STRING # get_idd_string {{{ -#' @importFrom checkmate assert_count get_idd_string <- function (idd_env, class, leading = 4L, sep_at = 29L, sep_each = 0L, all = FALSE) { assert_valid_type(class, "class") assert_count(sep_each) diff --git a/R/impl.R b/R/impl.R index c966d6f23..f37475f75 100644 --- a/R/impl.R +++ b/R/impl.R @@ -1,4 +1,6 @@ #' @importFrom cli cat_bullet cat_line cat_rule rule symbol +#' @importFrom checkmate assert_names check_integerish +#' @importFrom checkmate assert_character assert_integerish check_character #' @importFrom data.table copy data.table dcast rbindlist #' @importFrom data.table setattr setcolorder setnames setorder setorderv #' @importFrom stringi stri_locate_first_regex stri_replace_first_regex "stri_sub<-" @@ -218,7 +220,6 @@ errormsg_field_name <- function (dt) { # }}} # new_id {{{ -#' @importFrom checkmate assert_names new_id <- function (dt, name, num) { assert_names(names(dt), must.include = name) max(dt[[name]], na.rm = TRUE) + seq_len(num) @@ -231,7 +232,6 @@ add_rleid <- function (dt, prefix = NULL) { } # }}} # append_dt {{{ -#' @importFrom checkmate assert_names append_dt <- function (dt, new_dt, base_col = NULL) { assert_names(names(new_dt), must.include = names(dt)) @@ -249,8 +249,6 @@ unique_id <- function () { # }}} # assert_valid_type {{{ -#' @importFrom checkmate assert_character assert_integerish check_character -#' @importFrom checkmate check_integerish assert_valid_type <- function (x, name = NULL, len = NULL, null.ok = FALSE, lower = -Inf, type = c("both", "id", "name")) { if (is.null(name)) name <- checkmate::vname(x) type <- match.arg(type) diff --git a/R/options.R b/R/options.R index 7601f3b9b..38ebade2e 100644 --- a/R/options.R +++ b/R/options.R @@ -1,3 +1,7 @@ +#' @importFrom checkmate assert_count assert_choice assert_flag assert_subset +#' @importFrom checkmate assert_string test_choice +NULL + # package level global constant {{{ .globals <- new.env(parent = emptyenv()) @@ -71,8 +75,6 @@ #' #' # set options #' eplusr_option(verbose_info = TRUE, view_in_ip = FALSE) -#' @importFrom checkmate assert_count assert_choice assert_flag assert_subset -#' @importFrom checkmate assert_string test_choice #' @export #' @author Hongyuan Jia # eplusr_option {{{ diff --git a/R/parse.R b/R/parse.R index 907ea2ada..b933a42d8 100644 --- a/R/parse.R +++ b/R/parse.R @@ -1,4 +1,5 @@ #' @importFrom cli rule +#' @importFrom checkmate assert_data_table assert_names #' @importFrom data.table ":=" "%chin%" #' @importFrom data.table between chmatch data.table dcast.data.table last #' @importFrom data.table rbindlist rowidv rleid set setattr setcolorder @@ -243,7 +244,6 @@ parse_idf_file <- function (path, idd = NULL, ref = TRUE) { # }}} # get_idd_ver {{{ -#' @importFrom checkmate assert_data_table assert_names get_idd_ver <- function (idd_dt) { ver_line <- idd_dt$string[[1L]] @@ -260,7 +260,6 @@ get_idd_ver <- function (idd_dt) { # }}} # get_idd_build {{{ -#' @importFrom checkmate assert_data_table assert_names get_idd_build <- function (idd_dt) { build_line <- idd_dt$string[[2L]] @@ -656,7 +655,6 @@ get_field_table <- function (dt, type_enum) { # }}} # dcast_slash {{{ -#' @importFrom checkmate assert_names dcast_slash <- function (dt, id, keys, keep = NULL) { if (!is.null(keep)) assert_names(names(dt), must.include = keep) diff --git a/R/run.R b/R/run.R index 1d12ab16c..a62db84b2 100644 --- a/R/run.R +++ b/R/run.R @@ -1,4 +1,6 @@ #' @importFrom callr r_bg +#' @importFrom checkmate assert_flag assert_file_exists assert_directory_exists +#' @importFrom checkmate assert_logical #' @importFrom cli cat_line #' @importFrom crayon red #' @importFrom data.table data.table setattr setnames @@ -270,7 +272,6 @@ run_idf <- function (model, weather, output_dir, design_day = FALSE, #' @export #' @rdname run_model -#' @importFrom checkmate assert_flag assert_logical # run_multi {{{ run_multi <- function (model, weather, output_dir, design_day = FALSE, annual = FALSE, wait = TRUE, echo = TRUE, eplus = NULL) { @@ -604,7 +605,6 @@ sim_status <- function (type, index, model, weather, exit_code = NULL) { } # }}} # energyplus {{{ -#' @importFrom checkmate assert_flag assert_file_exists assert_directory_exists energyplus <- function (eplus, model, weather, output_dir, output_prefix = NULL, output_suffix = c("C", "L", "D"), expand_obj = TRUE, readvars = TRUE, annual = FALSE, design_day = FALSE, diff --git a/R/utils.R b/R/utils.R index 2a22ba765..413d85ad2 100644 --- a/R/utils.R +++ b/R/utils.R @@ -1,4 +1,6 @@ #' @importFrom stringi stri_enc_toutf8 stri_replace_all_charclass stri_trans_tolower +#' @importFrom checkmate assert_number assert_flag assert_class assert_vector +#' @importFrom checkmate assert_character assert_names NULL # `%||%` {{{ @@ -131,7 +133,6 @@ read_lines <- function(input, trim = TRUE, ...) { # write_lines {{{ # NOTE: IDFEditor will crash if a large IDF file was saved with LF eol on # Windows. -#' @importFrom checkmate assert_character assert_names write_lines <- function (x, file = "", append = FALSE) { if (inherits(x, "data.table")) { assert_names(names(x), must.include = "string") @@ -184,7 +185,6 @@ standardize_ver <- function (ver, strict = FALSE, complete = TRUE) { # }}} # match_minor_ver {{{ -#' @importFrom checkmate assert_class assert_vector match_minor_ver <- function (ver, all_ver, type = c("idd", "eplus"), max = TRUE, verbose = TRUE) { checkmate::assert_class(ver, "numeric_version") checkmate::assert_vector(ver, len = 1L) @@ -366,7 +366,6 @@ each_length <- function (x) { # }}} # ranger {{{ -#' @importFrom checkmate assert_number assert_flag ranger <- function (minimum = -Inf, lower_incbounds = FALSE, maximum = Inf, upper_incbounds = FALSE) { assert_number(minimum) assert_number(maximum) From 937c761e2f048396db1583425fe271d1dfea118e Mon Sep 17 00:00:00 2001 From: Hongyuan Jia Date: Wed, 15 Apr 2020 22:42:13 +0800 Subject: [PATCH 17/43] [refactor] Refactor idd.R --- NAMESPACE | 1 - NEWS.md | 2 + R/idd.R | 169 +++++++++++++----------------- tests/testthat/test_idd.R | 212 +++++++++++++++++++++++++++++++------- 4 files changed, 244 insertions(+), 140 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index aee59dfab..bfdc0c670 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -22,7 +22,6 @@ S3method("==",Idf) S3method("==",IdfObject) S3method("==",ParametricJob) S3method("[",EpwDate) -S3method("[",Idd) S3method("[",IdfObject) S3method("[<-",EpwDate) S3method("[[",EpwDate) diff --git a/NEWS.md b/NEWS.md index ca0c44e6a..ed0e58637 100644 --- a/NEWS.md +++ b/NEWS.md @@ -121,6 +121,8 @@ * `run_idf()` and `run_multi()` now return additional element/column called * `version` which contain the versions of EnergyPlus that are called during simulations +* `format.Idd()` now returns a single line string in format + `", x$version(), n, + if (n <= 1L) "class" else "classes" + ) + } else { + sprintf("", x$version(), x$build(), + n, if (n <= 1L) "class" else "classes" + ) + } } # }}} @@ -961,7 +958,7 @@ format.Idd <- function (x, ...) { # ==.Idd {{{ `==.Idd` <- function (e1, e2) { if (!is_idd(e2)) return(FALSE) - identical(._get_private(e1)$m_log$uuid, ._get_private(e2)$m_log$uuid) + identical(get_priv_env(e1)$m_log$uuid, get_priv_env(e2)$m_log$uuid) } # }}} @@ -1067,31 +1064,23 @@ read_idd <- function (path) { use_idd <- function (idd, download = FALSE) { if (is_idd(idd)) return(idd) - assert(is_scalar(idd)) + assert_vector(idd, len = 1L) # if input is a file path or literal IDD string if (!is_idd_ver(idd)) { - return(tryCatch(read_idd(idd), error_read_file = function (e) { - abort("error_invalid_idd_input", - paste0("Parameter `idd` should be a valid version, a path, or ", - "a single character string of an EnergyPlus Input Data ", - "Dictionary (IDD) file (usually named `Energy+.idd`). ", - "Invalid input found: ", - if (length(idd) > 1L) { - surround(paste0(idd[1L], "...")) - } else { - surround(idd) - }, - "." - ) - ) + return(tryCatch(read_idd(idd), eplusr_error_read_lines = function (e) { + abort(paste0("Parameter 'idd' should be a valid version, a path, or ", + "a single character string of an EnergyPlus Input Data ", + "Dictionary (IDD) file (usually named 'Energy+.idd'). ", + "Invalid input found: ", str_trunc(surround(idd)), "." + ), "read_lines") })) } # make sure to print multiple version message only once ver_in <- standardize_ver(idd, complete = FALSE) # first check if version already exists - ver <- match_minor_ver(ver_in, c(names(.globals$idd), names(.globals$eplus_config)), "idd") + ver <- match_minor_ver(ver_in, c(names(.globals$idd), names(.globals$eplus)), "idd") # if not exists, try to find more if (is.na(ver)) ver <- match_minor_ver(ver_in, ALL_IDD_VER, "idd") @@ -1104,12 +1093,12 @@ use_idd <- function (idd, download = FALSE) { if (is_avail_idd(ver)) return(.globals$idd[[as.character(ver)]]) verbose_info("IDD v", ver, " has not been parsed before.\nTry to locate ", - "`Energy+.idd` in EnergyPlus v", ver, " installation folder ", + "'Energy+.idd' in EnergyPlus v", ver, " installation folder ", surround(eplus_default_path(ver)), ".") # if corresponding EnergyPlus folder not found if (!is_avail_eplus(ver)) { - verbose_info("Failed to locate `Energy+.idd` because EnergyPlus v", + verbose_info("Failed to locate 'Energy+.idd' because EnergyPlus v", ver, " is not available.") # try to locate using latest IDFVersionUpdater @@ -1124,13 +1113,11 @@ use_idd <- function (idd, download = FALSE) { idd <- attr(dl, "file") # else issue an error } else { - abort("error_no_matched_idd", - paste0("Failed to locate IDD v", ver, ".\n", - "You may want to set `download` to TRUE or ", - "\"auto\" to download the IDD file from EnregyPlus ", - "GitHub repo." - ) - ) + abort(paste0("Failed to locate IDD v", ver, ".\n", + "You may want to set 'download' to TRUE or ", + "\"auto\" to download the IDD file from EnregyPlus ", + "GitHub repo." + ), "locate_idd") } } # if corresponding EnergyPlus folder is found @@ -1140,7 +1127,7 @@ use_idd <- function (idd, download = FALSE) { # but IDD file is missing if (!file.exists(idd)) { - verbose_info("`Energy+.idd` file does not exist in EnergyPlus v", + verbose_info("'Energy+.idd' file does not exist in EnergyPlus v", config$version, " installation folder ", surround(config$dir), "." ) @@ -1156,13 +1143,10 @@ use_idd <- function (idd, download = FALSE) { idd <- attr(dl, "file") # else issue an error } else { - abort("error_no_matched_idd", - paste0("Failed to locate IDD v", ver, - "You may want to set `download` to TRUE or ", - "\"auto\" to download the IDD file from EnregyPlus ", - "GitHub repo." - ) - ) + abort(paste0("Failed to locate IDD v", ver, + "You may want to set 'download' to TRUE or ", + "\"auto\" to download the IDD file from EnregyPlus GitHub repo." + ), "locate_idd") } } } @@ -1181,8 +1165,10 @@ use_idd <- function (idd, download = FALSE) { #' @export # download_idd {{{ download_idd <- function (ver = "latest", dir = ".") { + assert_vector(ver, len = 1L) ver <- standardize_ver(ver, complete = FALSE) - assert(is_scalar(ver), is_idd_ver(ver)) + + if (!is_eplus_ver(ver)) abort("'ver' must be a valid EnergyPlus version", "invalid_eplus_ver") ori_ver <- ver # if no patch version is given @@ -1202,11 +1188,6 @@ download_idd <- function (ver = "latest", dir = ".") { if (ver == numeric_version("9.0.1")) ver <- numeric_version("9.0.0") - # in case explicitly download IDD version "9.0.0" - # because if ver is "9.0", then "9.0.1" will be downloaded, as there is no - # "9.0.0" IDD any more in current latest release. - } else if (ver == 9.0) { - latest_ver <- "9.0.0" # in case explicitly download IDD version "9.0.1" # change the file to download to "V9-0-0-Energy+.idd" as there is no # "V9-0-1-Energy+.idd" and only "V9-0-0-Energy+.idd", which does not follow @@ -1239,8 +1220,7 @@ download_idd <- function (ver = "latest", dir = ".") { dest <- normalizePath(file.path(dir, file), mustWork = FALSE) res <- download_file(url, dest) - if (res != 0L) - stop(sprintf("Failed to download EnergyPlus IDD v%s.", ver), call. = FALSE) + if (res != 0L) abort(sprintf("Failed to download EnergyPlus IDD v%s.", ver), "download_idd") if (ver == latest_ver) { cmt <- ALL_EPLUS_RELEASE_COMMIT[version == ver][["commit"]] @@ -1274,8 +1254,10 @@ avail_idd <- function () { #' @export # is_avail_idd {{{ is_avail_idd <- function (ver) { - assert(is_idd_ver(ver, strict = TRUE)) - !is.na(match_minor_ver(standardize_ver(ver, complete = FALSE), names(.globals$idd), "idd", verbose = FALSE)) + if (is.character(ver) && "latest" %chin% ver) { + abort("'latest' notation for IDD version is not allowed here. Please give specific versions.", "ambiguous_idd_ver") + } + !is.na(convert_to_idd_ver(ver, strict = TRUE, all_ver = names(.globals$idd))) } # }}} @@ -1284,7 +1266,7 @@ find_idd_from_updater <- function (ver) { ver <- standardize_ver(ver, strict = TRUE) # check if there are any EnergyPlus detected whose version is # newer than specified version - vers <- rev(avail_eplus()[avail_eplus() > ver]) + vers <- rev(avail_eplus()[avail_eplus() >= ver]) if (!length(vers)) return(NULL) @@ -1326,25 +1308,21 @@ get_idd_from_ver <- function (idf_ver = NULL, idd = NULL, warn = TRUE) { # if input IDF has a version but neither that version of EnergyPlus # nor IDD is available, rewrite the message idd <- tryCatch(use_idd(idf_ver), - error_no_matched_idd = function (e) { + eplusr_error_locate_idd = function (e) { mes <- stri_replace_all_fixed(conditionMessage(e), - "You may want to set `download`", - "You may want to use `use_idd()` and set `download`" + "You may want to set 'download'", + "You may want to use 'use_idd()' and set 'download'" ) - abort("error_no_matched_idd", mes) + abort(mes, "locate_idd") } ) } else { idd <- use_idd(idd) if (warn && idf_ver[, 1L:2L] != idd$version()[, 1L:2L]) { - warn("waring_idf_idd_mismatch_ver", - paste0( - "Version Mismatch. The IDF file parsing has a differnet ", - "version (", idf_ver, ") than the IDD file used (", - idd$version(), "). Parsing errors may occur." - ), - idf_ver = idf_ver, - idd_ver = idd$version() + warn(paste0("Version mismatch. The IDF file parsing has a differnet ", + "version (", idf_ver, ") than the IDD file used (", + idd$version(), "). Parsing errors may occur."), + "use_mismatch_idd" ) } } @@ -1354,28 +1332,21 @@ get_idd_from_ver <- function (idf_ver = NULL, idd = NULL, warn = TRUE) { if (!is.null(idd)) { idd <- use_idd(idd) if (warn) { - warn("warning_given_idd_used", - paste0( - mes, " The given IDD version ", idd$version(), - " will be used. Parsing errors may occur." - ) + warn(paste0(mes, " The given IDD version ", idd$version(), + " will be used. Parsing errors may occur."), "use_hard_coded_idd" ) } } else { if (is.null(avail_idd())) { - abort("error_no_avail_idd", - paste(mes, "No parsed IDD was available to use.") - ) + abort(paste(mes, "No parsed IDD was available to use."), "no_avail_idd") } # which.max does not work with numeric_version objects idd <- use_idd(avail_idd()[max(order(avail_idd()))]) if (warn) { - warn("warning_latest_idd_used", - paste0(mes, - " The latest parsed IDD version ", idd$version(), + warn(paste0(mes, " The latest parsed IDD version ", idd$version(), " will be used. Parsing errors may occur." - ) + ), "use_latest_idd" ) } } diff --git a/tests/testthat/test_idd.R b/tests/testthat/test_idd.R index 94ab0bf1e..5c829ac49 100644 --- a/tests/testthat/test_idd.R +++ b/tests/testthat/test_idd.R @@ -1,57 +1,121 @@ -context("Idd and IddObject") +context("Idd") eplusr_option(verbose_info = FALSE) # download_idd() {{{ -test_that("can download IDD from EnergyPlus repo", { - skip_on_cran() - expect_silent(download_idd(8.8, tempdir())) - expect_true(file.exists(file.path(tempdir(), "V8-8-0-Energy+.idd"))) +test_that("download_idd() can download IDD from EnergyPlus repo", { + expect_error(download_idd(1, tempdir()), classs = "eplusr_error_invalid_eplus_ver") - expect_silent(download_idd("latest", tempdir())) - expect_true(file.exists(file.path(tempdir(), "V9-2-0-Energy+.idd"))) + # skip_on_cran() + # should download IDD v9.0.1 if input is 9, 9.0, 9.0.1 + expect_equal(read_idd(attr(download_idd(9.0, tempdir()), "file"))$version(), numeric_version("9.0.1")) + expect_equal(read_idd(attr(download_idd("9.0.1", tempdir()), "file"))$version(), numeric_version("9.0.1")) }) # }}} # use_idd() {{{ test_that("can read IDD", { - skip_on_cran() - glo <- eplusr:::`.globals` - glo$idd <- list() - expect_error(is_avail_idd("latest")) - expect_equal(avail_idd(), NULL) - if (any(avail_eplus() >= 8.4)) { - expect_silent(use_idd(8.4)) - } else { - expect_error(use_idd(8.4)) - } - - expect_silent(use_idd(8.4, download = TRUE)) - expect_silent(use_idd("latest", download = TRUE)) - expect_true(file.exists(file.path(tempdir(), "V8-4-0-Energy+.idd"))) - expect_is(use_idd("8.4.0"), "Idd") - expect_true(numeric_version("8.4.0") %in% avail_idd()) - expect_true(is_avail_idd(8.4)) - expect_true(is_avail_idd("8.4")) - expect_true(is_avail_idd("8.4.0")) + # skip_on_cran() + # remove all parsed IDD + .globals$idd <- list() + expect_error(is_avail_idd("latest")) - expect_silent(use_idd(8.7, download = "auto")) - expect_equal(avail_idd(), numeric_version(c("8.4.0", "8.7.0", "9.2.0"))) + expect_equal(avail_idd(), NULL) + # can stop if failed to read input file + expect_error(use_idd(""), class = "eplusr_error_read_lines") + + # can directly download from EnergyPlus GitHub repo + expect_silent(idd <- use_idd(8.4, download = TRUE)) + + # can directly return if input is an Idd + expect_is(use_idd(idd), "Idd") + + # can directly return if parsed previously + expect_is(use_idd(8.4), "Idd") + + # can use the IDD in EnergyPlus VersionUpdater folder + if (!is_avail_eplus(8.8)) install_eplus(8.8) + .globals$idd <- list() + expect_is(use_idd(8.4), "Idd") + + # can stop if that EnergyPlus is not available and IDD if not found in any + # existing VersionUpdater folder + .globals$eplus['9.2.0'] <- NULL + expect_error(use_idd(9.2), class = "eplusr_error_locate_idd") + + # can direct read if corresponding EnergyPlus is found + expect_is(use_idd(8.8), "Idd") + + # can search in VersionUpdater folder if "Energy+.idd" is not found in + # EnergyPlus folder + f1 <- file.path(eplus_config(8.8)$dir, "Energy+.idd") + f1_bak <- paste0(f1, ".bak") + file.rename(f1, f1_bak) + expect_is(use_idd(8.8), "Idd") + file.rename(f1_bak, f1) + + # can stop if no available IDD found in any existing VersionUpdater folder + .globals$eplus <- list() + .globals$eplus[["8.8.0"]] <- use_eplus(8.8) + .globals$idd <- list() + f2 <- find_idd_from_updater(8.8) + f2_bak <- paste0(f2, ".bak") + file.rename(f1, f1_bak) + file.rename(f2, f2_bak) + expect_error(use_idd(8.8), class = "eplusr_error_locate_idd") + # but "auto" still work in this case + expect_is(use_idd(8.8, "auto"), "Idd") + + # recover + file.rename(f1_bak, f1) + file.rename(f2_bak, f2) + + # can use "latest" notation + expect_is(use_idd("latest", download = TRUE), "Idd") + + # helper functions + expect_true(numeric_version("8.8.0") %in% avail_idd()) + expect_true(is_avail_idd(8.8)) + expect_true(is_avail_idd("8.8")) + expect_true(is_avail_idd("8.8.0")) + + # can use custom IDD expect_silent(use_idd(text("idd", "9.9.9"))) expect_true(is_avail_idd("9.9.9")) + # recover EnergyPlus config + locate_eplus() + # can parse old IDD - expect_warning(use_idd(7.2, download = "auto")) - expect_warning(use_idd(8.0, download = "auto")) - expect_warning(use_idd(8.1, download = "auto")) + skip_on_travis() + skip_on_appveyor() + expect_silent(use_idd(7.2)) + expect_silent(use_idd(8.0)) + expect_silent(use_idd(8.1)) + expect_silent(use_idd(8.2)) + + # can auto find suitable IDD + expect_is(get_idd_from_ver(8.8, NULL), "Idd") + # can give warning if hard-coded IDD is used + expect_warning(get_idd_from_ver(standardize_ver(8.5), use_idd(8.8)), "mismatch") + expect_warning(get_idd_from_ver(NULL, use_idd(8.8)), "given IDD") + # can stop if no available IDD parsed + .globals$idd <- list() + .globals$eplus <- list() + expect_error(get_idd_from_ver(8.8, NULL), class = "eplusr_error_locate_idd") + expect_error(get_idd_from_ver(NULL, NULL), class = "eplusr_error_no_avail_idd") + + locate_eplus() + use_idd(8.8) + expect_warning(get_idd_from_ver(NULL, NULL), "latest") }) # }}} # Idd class {{{ test_that("Idd class", { - .options$autocomplete <- TRUE + .options$autocomplete <- FALSE # can create an Idd object from string expect_silent(idd <- use_idd(text("idd", "9.9.9"))) @@ -72,11 +136,14 @@ test_that("Idd class", { c("TestGroup2", "TestGroup1")) # can stop when invalid class name is given - expect_error(idd$from_group("WrongClass"), class = "error_class_name") + expect_error(idd$from_group("WrongClass"), class = "eplusr_error_invalid_class_name") # can return all class names expect_equal(idd$class_name(), c("TestSimple", "TestSlash")) + # can group class names + expect_equal(idd$class_name(by_group = TRUE), list(TestGroup1 = "TestSimple", TestGroup2 = "TestSlash")) + # can return an index of a single group expect_equal(idd$group_index("TestGroup1"), 1) @@ -85,7 +152,7 @@ test_that("Idd class", { c(2L, 1L, 2L)) # can stop when invalid group names are given - expect_error(idd$group_index("WrongGroup"), class = "error_group_name") + expect_error(idd$group_index("WrongGroup"), class = "eplusr_error_invalid_group_name") # can return an index of a single class expect_equal(idd$class_index("TestSlash"), 2L) @@ -94,8 +161,11 @@ test_that("Idd class", { expect_equal(idd$class_index(c("TestSlash", "TestSimple", "TestSimple")), c(2L, 1L, 1L)) + # can group class index + expect_equal(idd$class_index(by_group = TRUE), list(TestGroup1 = 1L, TestGroup2 = 2L)) + # can stop when invalid class names are given - expect_error(idd$class_index("WrongClass"), error = "error_class_name") + expect_error(idd$class_index("WrongClass"), error = "eplusr_error_invalid_class_name") expect_is(idd$object_relation("TestSimple"), "IddRelation") expect_is(idd$object_relation("TestSimple", "ref_to"), "IddRelation") @@ -115,6 +185,7 @@ test_that("Idd class", { # can stop when invalid class names are given expect_error(idd$object("WrongClass"), error = "error_class_name_us") + expect_is(idd$object("TestSlash"), "IddObject") # can return when multiple class names are given expect_equal(idd$objects(c("TestSimple", "TestSlash")), @@ -126,10 +197,11 @@ test_that("Idd class", { expect_equal(idd$objects_in_group("TestGroup1"), list(TestSimple = idd$object("TestSimple"))) # can stop when invalid group names are given - expect_error(idd$objects_in_group("WrongGroup"), class = "error_group_name") + expect_error(idd$objects_in_group("WrongGroup"), class = "eplusr_error_invalid_group_name") # can stop when multiple group names are given - expect_error(idd$objects_in_group(c("TestGroup1", "TestGroup2")), class = "error_not_string") + expect_error(idd$objects_in_group(c("TestGroup1", "TestGroup2")), "Must have length 1") + expect_is(idd$objects_in_group("TestGroup1")[[1L]], "IddObject") expect_is(idd$objects_in_relation("TestSimple", "ref_to"), "list") expect_equal(names(idd$objects_in_relation("TestSimple", "ref_to")), "TestSimple") @@ -144,15 +216,75 @@ test_that("Idd class", { expect_false(idd$is_valid_class("WrongClass")) expect_true(idd$is_valid_class("TestSlash")) + # can export IDD data in data.table format + expect_equal(idd$to_table("TestSlash", all = TRUE), + data.table(class = "TestSlash", index = 1:4, + field = c("Test Character Field 1", "Test Numeric Field 1", + "Test Numeric Field 2", "Test Character Field 2" + ) + ) + ) + expect_equal(idd$to_table("TestSlash"), + data.table(class = "TestSlash", index = 1:3, + field = c("Test Character Field 1", "Test Numeric Field 1", + "Test Numeric Field 2" + ) + ) + ) + + # can export IDD data in character format + expect_equal(idd$to_string("TestSlash", all = TRUE), + c( + "TestSlash,", + " , !- Test Character Field 1", + " , !- Test Numeric Field 1 {m}", + " , !- Test Numeric Field 2", + " ; !- Test Character Field 2" + ) + + ) + # can print without error expect_output(idd$print()) - # can get single object using S3 method + # private functions + expect_equal(get_priv_env(idd)$idd_env(), get_priv_env(idd)$m_idd_env) + + # private functions + expect_equal(get_priv_env(idd)$log_env(), get_priv_env(idd)$m_log) +}) +# }}} + +# Idd S3 methods {{{ +test_that("Idd S3 methods", { + .options$autocomplete <- FALSE + expect_silent(idd <- use_idd(text("idd", "9.9.9"))) + expect_false("TestSlash" %in% names(idd)) + + # can create active bindings for class names + .options$autocomplete <- TRUE + expect_silent(idd <- use_idd(text("idd", "9.9.9"))) + expect_true("TestSlash" %in% names(idd)) + expect_true("TestSimple" %in% names(idd)) expect_equal(idd$TestSlash, idd$object("TestSlash")) expect_equal(idd[["TestSlash"]], idd$object("TestSlash")) + expect_null(idd$Missing) + expect_null(idd[["Missing"]]) + expect_error(idd$Missing <- "a", "cannot add bindings to a locked environment") + expect_error(idd[["Missing"]] <- "a", "cannot add bindings to a locked environment") - expect_is(idd$object("TestSlash"), "IddObject") - expect_is(idd$objects_in_group("TestGroup1")[[1L]], "IddObject") + .options$autocomplete <- FALSE + # can still use S3 subsetting without active bindings + expect_silent(idd <- use_idd(text("idd", "9.9.9"))) + expect_equal(idd$TestSlash, idd$object("TestSlash")) + expect_equal(idd[["TestSlash"]], idd$object("TestSlash")) + expect_null(idd$Missing) + expect_null(idd[["Missing"]]) + + expect_equal(capture.output(str(idd)), capture.output(print(idd))) + expect_equal(format(idd), "") + expect_equal(format(read_idd("!IDD_Version 9.9.9\n\\group TestGroup\nTest,\nA1; \\note something")), + "") # can check equality expect_false(idd == "a") From 0f693e3f34fe648b8fcc0cab81361a1c74ea6532 Mon Sep 17 00:00:00 2001 From: Hongyuan Jia Date: Thu, 16 Apr 2020 10:27:36 +0800 Subject: [PATCH 18/43] [refactor] Allow min and max being NA in 'ranger()' --- R/utils.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/utils.R b/R/utils.R index 413d85ad2..7c7bfef06 100644 --- a/R/utils.R +++ b/R/utils.R @@ -367,8 +367,8 @@ each_length <- function (x) { # ranger {{{ ranger <- function (minimum = -Inf, lower_incbounds = FALSE, maximum = Inf, upper_incbounds = FALSE) { - assert_number(minimum) - assert_number(maximum) + assert_number(minimum, na.ok = TRUE) + assert_number(maximum, na.ok = TRUE) assert_flag(lower_incbounds) assert_flag(upper_incbounds) setattr( From ceeced36dc484d5294c1ea1df348ebce9093929c Mon Sep 17 00:00:00 2001 From: Hongyuan Jia Date: Thu, 16 Apr 2020 10:27:55 +0800 Subject: [PATCH 19/43] [refactor] Refactor impl-iddobj.R --- R/impl-iddobj.R | 32 ++++---- tests/testthat/test_impl-iddobj.R | 123 ++++++++++++++++++++++++++++++ 2 files changed, 141 insertions(+), 14 deletions(-) create mode 100644 tests/testthat/test_impl-iddobj.R diff --git a/R/impl-iddobj.R b/R/impl-iddobj.R index 752ede1f1..2fb4cecf2 100644 --- a/R/impl-iddobj.R +++ b/R/impl-iddobj.R @@ -2,42 +2,47 @@ NULL # get_iddobj_relation {{{ -get_iddobj_relation <- function (idd_env, class_id, field_id = NULL, name = TRUE, - direction = c("ref_to", "ref_by", "all"), - class = NULL, group = NULL, depth = 0L, keep_all = TRUE) { +get_iddobj_relation <- function (idd_env, class_id, field_id = NULL, + direction = c("ref_to", "ref_by", "all"), depth = 0L, name = FALSE, + class = NULL, group = NULL, keep_all = FALSE, + class_ref = c("both", "none", "all"), match_all = FALSE) { direction <- match.arg(direction) if (direction == "ref_to") { res <- list( ref_to = get_idd_relation(idd_env, class_id, field_id, - class = class, group = group, depth = depth, name = name, - direction = "ref_to", keep_all = keep_all), + direction = "ref_to", depth = depth, name = name, + class = class, group = group, keep_all = keep_all, + class_ref = class_ref, match_all = match_all), ref_by = NULL ) } else if (direction == "ref_by") { res <- list( ref_to = NULL, ref_by = get_idd_relation(idd_env, class_id, field_id, - class = class, group = group, depth = depth, name = name, - direction = "ref_by", keep_all = keep_all) + direction = "ref_by", depth = depth, name = name, + class = class, group = group, keep_all = keep_all, + class_ref = class_ref, match_all = match_all) ) } else { res <- list( ref_to = get_idd_relation(idd_env, class_id, field_id, - class = class, group = group, depth = depth, name = name, - direction = "ref_to", keep_all = keep_all), + direction = "ref_to", depth = depth, name = name, + class = class, group = group, keep_all = keep_all, + class_ref = class_ref, match_all = match_all), ref_by = get_idd_relation(idd_env, class_id, field_id, - class = class, group = group, depth = depth, name = name, - direction = "ref_by", keep_all = keep_all) + direction = "ref_by", depth = depth, name = name, + class = class, group = group, keep_all = keep_all, + class_ref = class_ref, match_all = match_all) ) } - setattr(res, "class", c("IddRelation", class(res))) + if (name) setattr(res, "class", c("IddRelation", class(res))) res } # }}} # get_iddobj_possible {{{ -get_iddobj_possible <- function (idd_env, class_id, field_id = NULL) { +get_iddobj_possible <- function (idd_env, class_id = NULL, field_id = NULL) { all <- if (is.null(field_id)) TRUE else FALSE if (all) { cls_id <- class_id @@ -99,7 +104,6 @@ get_iddobj_string <- function (idd_env, class_id = NULL, comment = NULL, leading str_cmt <- NULL if (!is.null(comment)) { - assert(is.character(comment)) str_cmt <- c(paste0("!", comment), "") } diff --git a/tests/testthat/test_impl-iddobj.R b/tests/testthat/test_impl-iddobj.R new file mode 100644 index 000000000..43e871e00 --- /dev/null +++ b/tests/testthat/test_impl-iddobj.R @@ -0,0 +1,123 @@ +# IddObject {{{ +test_that("IddObject implementation", { + expect_silent(idd_parsed <- parse_idd_file(text("idd", "9.9.9"))) + + # RELATION {{{ + expect_silent(rel <- get_iddobj_relation(idd_parsed, 2L, direction = "ref_to", name = TRUE, keep_all = TRUE)) + expect_equal(names(rel), c("ref_to", "ref_by")) + expect_equivalent( + rel$ref_to, + data.table( + class_id = 2L, class_name = "TestSlash", + field_id = 2:5, field_index = 1:4, + field_name = c("Test Character Field 1", "Test Numeric Field 1", "Test Numeric Field 2", "Test Character Field 2"), + src_class_id = c(1L, rep(NA_integer_, 3)), + src_class_name = c("TestSimple", rep(NA_character_, 3)), + sec_field_id = c(1L, rep(NA_integer_, 3)), + src_field_index = c(1L, rep(NA_integer_, 3)), + src_field_name = c("Test Field", rep(NA_character_, 3L)), + src_enum = c(2L, rep(NA_integer_, 3L)), dep = 0L + ) + ) + expect_null(rel$ref_by) + + expect_silent(rel <- get_iddobj_relation(idd_parsed, 2L, direction = "ref_to", name = TRUE, keep_all = FALSE)) + expect_equal(names(rel), c("ref_to", "ref_by")) + expect_equivalent( + rel$ref_to, + data.table( + class_id = 2L, class_name = "TestSlash", + field_id = 2L, field_index = 1L, field_name = "Test Character Field 1", + src_class_id = 1L, src_class_name = "TestSimple", + sec_field_id = 1L, src_field_index = 1L, src_field_name = "Test Field", + src_enum = 2L, dep = 0L + ) + ) + expect_null(rel$ref_by) + + expect_silent(rel <- get_iddobj_relation(idd_parsed, 2L, direction = "ref_by", name = TRUE, keep_all = FALSE)) + expect_equal(names(rel), c("ref_to", "ref_by")) + expect_equivalent( + rel$ref_by, + data.table( + class_id = integer(), class_name = character(), + field_id = integer(), field_index = integer(), field_name = character(), + src_class_id = integer(), src_class_name = character(), + sec_field_id = integer(), src_field_index = integer(), src_field_name = character(), + src_enum = integer(), dep = integer() + ) + ) + expect_null(rel$ref_to) + + expect_silent(rel <- get_iddobj_relation(idd_parsed, 2L, direction = "all", name = FALSE, keep_all = FALSE)) + expect_equal(names(rel), c("ref_to", "ref_by")) + expect_equivalent( + rel$ref_to, + data.table( + class_id = 2L, field_id = 2L, src_class_id = 1L, sec_field_id = 1L, + src_enum = 2L, dep = 0L + ) + ) + expect_equal(rel$ref_by, + data.table(class_id = integer(), field_id = integer(), src_class_id = integer(), src_field_id = integer(), src_enum = integer(), dep = integer()) + ) + # }}} + + # POSSIBLE {{{ + expect_equivalent( + get_iddobj_possible(idd_parsed, 1L), + data.table(class_id = 1L, class_name = "TestSimple", + field_id = 1L, field_index = 1L, + field_name = "Test Field", + auto = NA_character_, + default = list(NA_character_), + choice = list(NULL), + range = list( + ranger(NA_real_, FALSE, NA_real_, FALSE) + ) + ) + ) + expect_equivalent( + get_iddobj_possible(idd_parsed, field_id = c(5L, 3L)), + data.table(class_id = 2L, class_name = "TestSlash", + field_id = c(5L, 3L), field_index = c(4L, 2L), + field_name = c("Test Character Field 2", "Test Numeric Field 1"), + auto = c(NA_character_, "Autosize"), + default = list(NA_character_, 2), + choice = list(c("Key1", "Key2"), NULL), + range = list( + ranger(NA_real_, FALSE, NA_real_, FALSE), + ranger(1, TRUE, 10, FALSE) + ) + ) + ) + # }}} + + # TABLE {{{ + expect_equal(get_iddobj_table(idd_parsed, 1), + data.table(class = "TestSimple", index = 1L, field = "Test Field") + ) + # }}} + + # STRING {{{ + expect_equal(get_iddobj_string(idd_parsed, 2, leading = 0L, sep_at = 0L), + c("TestSlash,", + ",!- Test Character Field 1", + ",!- Test Numeric Field 1 {m}", + ";!- Test Numeric Field 2" + ) + + ) + + expect_equal(get_iddobj_string(idd_parsed, 2, comment = c(1, 2), leading = 0L, sep_at = 0L), + c("!1", "!2", "", + "TestSlash,", + ",!- Test Character Field 1", + ",!- Test Numeric Field 1 {m}", + ";!- Test Numeric Field 2" + ) + + ) + # }}} +}) +# }}} From 9b351e856211da9ddd986e20c342ebbe168ceeb6 Mon Sep 17 00:00:00 2001 From: Hongyuan Jia Date: Thu, 16 Apr 2020 11:02:30 +0800 Subject: [PATCH 20/43] [refactor] Refactor idd_object.R --- R/{idd_object.R => iddobj.R} | 90 +++++++++++++++++++---------------- man/IddObject.Rd | 2 +- man/as.character.IddObject.Rd | 4 +- man/format.Idd.Rd | 25 ++++++++++ man/format.IddObject.Rd | 21 ++------ man/idd_object.Rd | 2 +- tests/testthat/test_iddobj.R | 28 +++++++++-- tests/testthat/test_parse.R | 2 +- 8 files changed, 106 insertions(+), 68 deletions(-) rename R/{idd_object.R => iddobj.R} (96%) create mode 100644 man/format.Idd.Rd diff --git a/R/idd_object.R b/R/iddobj.R similarity index 96% rename from R/idd_object.R rename to R/iddobj.R index 0582564d4..26e806891 100644 --- a/R/idd_object.R +++ b/R/iddobj.R @@ -1,4 +1,5 @@ #' @importFrom R6 R6Class +#' @importFrom checkmate assert_count assert_vector assert_integerish NULL #' EnergyPlus IDD object @@ -70,16 +71,14 @@ IddObject <- R6::R6Class(classname = "IddObject", cloneable = FALSE, #' initialize = function (class, parent) { if (missing(parent)) { - abort("error_iddobject_missing_parent", - paste("IddObject can only be created based on a parent Idd object.", - "Please give `parent`, which should be either an IDD version or an `Idd` object." - ) - ) + abort(paste("IddObject can only be created based on a parent Idd object.", + "Please give 'parent', which should be either an IDD version or an 'Idd' object." + )) } else { private$m_parent <- use_idd(parent) } - assert(!is.null(class)) + assert_vector(class, null.ok = FALSE) private$m_class_id <- get_idd_class(private$idd_env(), class, underscore = TRUE)$class_id }, # }}} @@ -1414,12 +1413,8 @@ IddObject <- R6::R6Class(classname = "IddObject", cloneable = FALSE, # }}} # PRIVATE FUNCTIONS {{{ - idd_priv = function () { - ._get_private(private$m_parent) - }, - idd_env = function () { - .subset2(._get_private(private$m_parent), "m_idd_env") + .subset2(get_priv_env(private$m_parent), "m_idd_env") } # }}} ) @@ -1428,7 +1423,7 @@ IddObject <- R6::R6Class(classname = "IddObject", cloneable = FALSE, # iddobj_version {{{ iddobj_version <- function (self, private) { - private$idd_priv()$m_version + private$m_parent$version() } # }}} # iddobj_parent {{{ @@ -1499,9 +1494,9 @@ iddobj_extensible_group_num <- function (self, private) { # }}} # iddobj_add_extensible_group {{{ iddobj_add_extensible_group <- function (self, private, num) { - assert(is_count(num)) + assert_count(num, positive = TRUE) - iddenv <- ._get_private(private$m_parent)$m_idd_env + iddenv <- get_priv_env(private$m_parent)$m_idd_env iddenv <- add_idd_extensible_group(private$idd_env(), private$m_class_id, num, strict = TRUE) verbose_info(num, " extensible group(s) added") @@ -1511,9 +1506,9 @@ iddobj_add_extensible_group <- function (self, private, num) { # }}} # iddobj_del_extensible_group {{{ iddobj_del_extensible_group <- function (self, private, num) { - assert(is_count(num)) + assert_count(num, positive = TRUE) - iddenv <- ._get_private(private$m_parent)$m_idd_env + iddenv <- get_priv_env(private$m_parent)$m_idd_env iddenv <- del_idd_extensible_group(private$idd_env(), private$m_class_id, num, strict = TRUE) verbose_info(num, " extensible group(s) deleted") @@ -1551,14 +1546,14 @@ iddobj_field_data <- function (self, private, which = NULL, property = NULL, und # }}} # iddobj_field_name {{{ iddobj_field_name <- function (self, private, index = NULL, unit = FALSE, in_ip = eplusr_option("view_in_ip")) { - if (!is.null(index)) assert(are_count(index)) + index <- assert_integerish(index, lower = 1L, any.missing = FALSE, null.ok = TRUE, coerce = TRUE) if (unit) { if (eplusr_option("view_in_ip") != in_ip) { eplusr_option(view_in_ip = in_ip) on.exit(eplusr_option(view_in_ip = !in_ip), add = TRUE) } - res <- format_name(iddobj_field_data(self, private, index, c("units", "ip_units"))) + res <- format_name(iddobj_field_data(self, private, index, c("units", "ip_units")), prefix = FALSE) } else { res <- iddobj_field_data(self, private, index)$field_name } @@ -1568,7 +1563,7 @@ iddobj_field_name <- function (self, private, index = NULL, unit = FALSE, in_ip # }}} # iddobj_field_index {{{ iddobj_field_index <- function (self, private, name = NULL) { - if (!is.null(name)) assert(is.character(name)) + assert_character(name, any.missing = FALSE, null.ok = TRUE) iddobj_field_data(self, private, name, underscore = TRUE)$field_index } # }}} @@ -1650,7 +1645,7 @@ iddobj_field_possible <- function (self, private, which = NULL) { # }}} # iddobj_is_valid_field_num {{{ iddobj_is_valid_field_num <- function (self, private, num) { - assert(are_count(num)) + num <- assert_integerish(num, lower = 1L, any.missing = FALSE, coerce = TRUE) cls <- iddobj_class_data(self, private) @@ -1670,7 +1665,7 @@ iddobj_is_valid_field_num <- function (self, private, num) { # }}} # iddobj_is_extensible_index {{{ iddobj_is_extensible_index <- function (self, private, index) { - assert(are_count(index)) + index <- assert_integerish(index, lower = 1L, any.missing = FALSE, coerce = TRUE) cls <- iddobj_class_data(self, private) @@ -1694,7 +1689,7 @@ iddobj_is_valid_field_name <- function (self, private, name, strict = FALSE) { # }}} # iddobj_is_valid_field_index {{{ iddobj_is_valid_field_index <- function (self, private, index) { - assert(are_count(index)) + index <- assert_integerish(index, lower = 1L, any.missing = FALSE, coerce = TRUE) index <= iddobj_class_data(self, private)$num_fields } # }}} @@ -1735,12 +1730,16 @@ iddobj_has_ref <- function (self, private, which = NULL, class = NULL, group = N if (is.null(which)) { rel <- get_iddobj_relation(private$idd_env(), private$m_class_id, - class = class, group = group, depth = depth, direction = type) + class = class, group = group, depth = depth, direction = type, + keep_all = TRUE + ) } else { fld <- get_idd_field(private$idd_env(), private$m_class_id, which) rel <- get_iddobj_relation(private$idd_env(), NULL, fld$field_id, - class = class, group = group, depth = depth, direction = type) + class = class, group = group, depth = depth, direction = type, + keep_all = TRUE + ) } if (type == "all") { @@ -1835,30 +1834,28 @@ iddobj_print <- function (self, private, brief = FALSE) { #' Format an IddObject #' -#' Format an [IddObject] into a string of an empty object of current class. -#' It is formatted exactly the same as in IDF Editor. +#' Format an [IddObject] into a string. It is formatted the same way as +#' `IddObject$print(brief = TRUE)` but with a suffix of current IDD version. #' #' @param x An [IddObject] object. -#' @param all If `TRUE`, all fields in current class are returned, otherwise -#' only minimum fields are returned. -#' @param comment A character vector to be used as comments of returned string -#' format object. If `NULL`, no comments are inserted. Default: `NULL`. -#' @param leading Leading spaces added to each field. Default: `4`. -#' @param sep_at The character width to separate value string and field string. -#' Default: `29` which is the same as IDF Editor. +#' @param ver If `TRUE`, a suffix of version string is added. Default: `TRUE`. #' @param ... Further arguments passed to or from other methods. +#' #' @return A single length character vector. #' @examples #' \dontrun{ -#' cat(format(use_idd(8.8, download = "auto")$Materal, leading = 0)) +#' format(use_idd(8.8, download = "auto")$Material) #' } #' #' @export # format.IddObject {{{ -format.IddObject <- function (x, comment = NULL, leading = 4L, sep_at = 29L, all = FALSE, ...) { - paste0(x$to_string(comment = comment, leading = leading, sep_at = sep_at, all = all), - collapse = "\n" - ) +format.IddObject <- function (x, ver = TRUE, ...) { + nm <- get_idd_class(get_priv_env(x)$idd_env(), get_priv_env(x)$m_class_id)$class_name + if (isTRUE(ver)) { + paste0("") + } else { + paste0("") + } } # }}} @@ -1867,7 +1864,16 @@ format.IddObject <- function (x, comment = NULL, leading = 4L, sep_at = 29L, all #' Coerce an [IddObject] into an empty object of current class in a character #' vector format. It is formatted exactly the same as in IDF Editor. #' -#' @inheritParams format.IddObject +#' @param x An [IddObject] object. +#' @param all If `TRUE`, all fields in current class are returned, otherwise +#' only minimum fields are returned. +#' @param comment A character vector to be used as comments of returned string +#' format object. If `NULL`, no comments are inserted. Default: `NULL`. +#' @param leading Leading spaces added to each field. Default: `4`. +#' @param sep_at The character width to separate value string and field string. +#' Default: `29` which is the same as IDF Editor.' +#' @param ... Further arguments passed to or from other methods. +#' #' @return A character vector. #' @examples #' \dontrun{ @@ -1893,10 +1899,10 @@ str.IddObject <- function (object, brief = FALSE, ...) { `==.IddObject` <- function (e1, e2) { if (!is_iddobject(e2)) return(FALSE) identical( - ._get_private(._get_private(e1)$m_parent)$m_log$uuid, - ._get_private(._get_private(e2)$m_parent)$m_log$uuid + get_priv_env(get_priv_env(e1)$m_parent)$m_log$uuid, + get_priv_env(get_priv_env(e2)$m_parent)$m_log$uuid ) && - identical(._get_private(e1)$m_class_id, ._get_private(e2)$m_class_id) + identical(get_priv_env(e1)$m_class_id, get_priv_env(e2)$m_class_id) } #' @export diff --git a/man/IddObject.Rd b/man/IddObject.Rd index 0ea7332af..e061b8f36 100644 --- a/man/IddObject.Rd +++ b/man/IddObject.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/idd_object.R +% Please edit documentation in R/iddobj.R \docType{class} \name{IddObject} \alias{IddObject} diff --git a/man/as.character.IddObject.Rd b/man/as.character.IddObject.Rd index 22525139f..a4334c49c 100644 --- a/man/as.character.IddObject.Rd +++ b/man/as.character.IddObject.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/idd_object.R +% Please edit documentation in R/iddobj.R \name{as.character.IddObject} \alias{as.character.IddObject} \title{Coerce an IddObject into a Character Vector} @@ -15,7 +15,7 @@ format object. If \code{NULL}, no comments are inserted. Default: \code{NULL}.} \item{leading}{Leading spaces added to each field. Default: \code{4}.} \item{sep_at}{The character width to separate value string and field string. -Default: \code{29} which is the same as IDF Editor.} +Default: \code{29} which is the same as IDF Editor.'} \item{all}{If \code{TRUE}, all fields in current class are returned, otherwise only minimum fields are returned.} diff --git a/man/format.Idd.Rd b/man/format.Idd.Rd new file mode 100644 index 000000000..6807ffe28 --- /dev/null +++ b/man/format.Idd.Rd @@ -0,0 +1,25 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/idd.R +\name{format.Idd} +\alias{format.Idd} +\title{Format an Idd} +\usage{ +\method{format}{Idd}(x, ...) +} +\arguments{ +\item{x}{An \link{Idd} object.} + +\item{...}{Further arguments passed to or from other methods.} +} +\value{ +A single length character vector. +} +\description{ +Format an \link{Idd} into a string. +} +\examples{ +\dontrun{ +format(use_idd(8.8, download = "auto")) +} + +} diff --git a/man/format.IddObject.Rd b/man/format.IddObject.Rd index 1832205d2..8b6c32277 100644 --- a/man/format.IddObject.Rd +++ b/man/format.IddObject.Rd @@ -1,37 +1,26 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/idd_object.R +% Please edit documentation in R/iddobj.R \name{format.IddObject} \alias{format.IddObject} \title{Format an IddObject} \usage{ -\method{format}{IddObject}(x, comment = NULL, leading = 4L, sep_at = 29L, all = FALSE, ...) +\method{format}{IddObject}(x, ...) } \arguments{ \item{x}{An \link{IddObject} object.} -\item{comment}{A character vector to be used as comments of returned string -format object. If \code{NULL}, no comments are inserted. Default: \code{NULL}.} - -\item{leading}{Leading spaces added to each field. Default: \code{4}.} - -\item{sep_at}{The character width to separate value string and field string. -Default: \code{29} which is the same as IDF Editor.} - -\item{all}{If \code{TRUE}, all fields in current class are returned, otherwise -only minimum fields are returned.} - \item{...}{Further arguments passed to or from other methods.} } \value{ A single length character vector. } \description{ -Format an \link{IddObject} into a string of an empty object of current class. -It is formatted exactly the same as in IDF Editor. +Format an \link{IddObject} into a string. It is formatted the same way as +\code{IddObject$print(brief = TRUE)} but with a suffix of current IDD version. } \examples{ \dontrun{ -cat(format(use_idd(8.8, download = "auto")$Materal, leading = 0)) +format(use_idd(8.8, download = "auto")$Material) } } diff --git a/man/idd_object.Rd b/man/idd_object.Rd index 15d1f1bb9..fd114b121 100644 --- a/man/idd_object.Rd +++ b/man/idd_object.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/idd_object.R +% Please edit documentation in R/iddobj.R \name{idd_object} \alias{idd_object} \title{Create an \code{IddObject} object.} diff --git a/tests/testthat/test_iddobj.R b/tests/testthat/test_iddobj.R index 1ea289f81..8b8128440 100644 --- a/tests/testthat/test_iddobj.R +++ b/tests/testthat/test_iddobj.R @@ -3,10 +3,13 @@ context("IddObject") test_that("IddObject class", { expect_silent(idd <- Idd$new(text("idd", 9.9))) + expect_silent(simple <- IddObject$new("TestSimple", idd)) expect_silent(slash <- IddObject$new("TestSlash", idd)) expect_silent(slash <- idd_object(use_idd(text("idd", 9.9)), "TestSlash")) - expect_error(idd_object(), class = "error_iddobject_missing_parent") + expect_error(idd_object(), "based on a parent Idd object", class = "eplusr_error") + + expect_equal(slash$version(), idd$version()) expect_is(slash$parent(), "Idd") @@ -65,17 +68,19 @@ test_that("IddObject class", { # can use $del_extensible_groups() expect_equal(slash$del_extensible_group(1)$num_fields(), 4L) - expect_s3_class(catch_cnd(slash$del_extensible_group(1)), "error_del_extensible") + expect_s3_class(catch_cnd(slash$del_extensible_group(1)), "eplusr_error") # }}} # Field {{{ # can use $field_name() - expect_error(slash$field_name(slash$num_fields() + 30), class = "error_bad_field_index") + expect_error(slash$field_name(slash$num_fields() + 30), class = "eplusr_error_invalid_field_index") expect_equal(slash$field_name(c(2, 1)), c("Test Numeric Field 1", "Test Character Field 1")) + expect_equal(slash$field_name(c(2, 1), unit = TRUE), c("Test Numeric Field 1 {m}", "Test Character Field 1")) + expect_equal(slash$field_name(c(2, 1), unit = TRUE, in_ip = TRUE), c("Test Numeric Field 1 {in}", "Test Character Field 1")) # can use $field_index() expect_equal(slash$field_index(), 1L:4L) - expect_error(slash$field_index("WrongName"), class = "error_bad_field_name") + expect_error(slash$field_index("WrongName"), class = "eplusr_error_invalid_field_name") expect_equal(slash$field_index( c("Test Numeric Field 1", "Test Character Field 1")), c(2L, 1L)) # can use $field_type() @@ -101,6 +106,7 @@ test_that("IddObject class", { list(ranger(NA_real_, FALSE, NA_real_, FALSE), ranger(1L, TRUE, 10, FALSE))) # can use $field_relation() + expect_is(slash$field_relation(), "list") expect_is(slash$field_relation(c(4, 2)), "list") expect_null(slash$field_relation(c(4, 2), "ref_by")$ref_to) expect_equal(nrow(slash$field_relation(c(4, 2), keep = TRUE)$ref_by), 2L) @@ -137,6 +143,7 @@ test_that("IddObject class", { expect_equal(slash$is_valid_field_num(c(1, 4, 6, 12)), c(FALSE, TRUE, FALSE, TRUE)) # can use $is_extensible_field_index() + expect_equal(simple$is_extensible_index(1:2), rep(FALSE, 2L)) expect_equal(slash$is_extensible_index(c(1, 4, 6, 12)), rep(TRUE, times = 4L)) # can use $is_valid_field_name() @@ -145,6 +152,7 @@ test_that("IddObject class", { expect_true(slash$is_valid_field_name("Test Numeric Field 1")) expect_true(slash$is_valid_field_name("Test Numeric Field 2")) expect_true(slash$is_valid_field_name("test_character_field_1")) + expect_false(slash$is_valid_field_name("test_character_field_1", strict = TRUE)) expect_true(slash$is_valid_field_name("test_numeric_field_1")) expect_false(slash$is_valid_field_name(1)) expect_false(slash$is_valid_field_name("wrong")) @@ -154,7 +162,7 @@ test_that("IddObject class", { expect_true(slash$is_valid_field_index(2)) expect_true(slash$is_valid_field_index(3)) expect_true(slash$is_valid_field_index(4)) - expect_error(slash$is_valid_field_index("wrong"), class = "error_not_count") + expect_error(slash$is_valid_field_index("wrong"), "integerish") expect_false(slash$is_valid_field_index(5)) # can use $is_autosizable_field() @@ -245,11 +253,21 @@ test_that("IddObject class", { ) # }}} + # S3 {{{ + expect_equal(format(slash), "") + expect_equal(format(slash, ver = FALSE), "") + expect_output(str(slash)) + expect_equal(as.character(slash), slash$to_string()) + # }}} + # can check equality expect_true(slash == slash) + expect_false(slash == "a") expect_false(slash == IddObject$new("TestSlash", idd)) expect_true(slash != IddObject$new("TestSlash", idd)) # print + expect_output(slash$print(brief = TRUE)) expect_output(slash$print()) + expect_output(simple$print()) }) diff --git a/tests/testthat/test_parse.R b/tests/testthat/test_parse.R index 701f6ff28..661026a46 100644 --- a/tests/testthat/test_parse.R +++ b/tests/testthat/test_parse.R @@ -91,7 +91,7 @@ test_that("parse_idd_file()", { ) expect_error(parse_idd_file(idd_wrong), "Invalid IDD version", "eplusr_error_parse_idd") - # can warn about missing IDD build tag + # can handle missing IDD build tag idd_wrong <- c( "!IDD_Version 9.9.9 \\group TestGroup From 349cd4b387670b3523a5f40202fd4c8c9818d653 Mon Sep 17 00:00:00 2001 From: Hongyuan Jia Date: Thu, 16 Apr 2020 11:03:46 +0800 Subject: [PATCH 21/43] [refactor] Skip 'download_idd()' and 'use_idd()' tests on CRAN --- tests/testthat/test_idd.R | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/tests/testthat/test_idd.R b/tests/testthat/test_idd.R index 5c829ac49..a37599312 100644 --- a/tests/testthat/test_idd.R +++ b/tests/testthat/test_idd.R @@ -6,7 +6,7 @@ eplusr_option(verbose_info = FALSE) test_that("download_idd() can download IDD from EnergyPlus repo", { expect_error(download_idd(1, tempdir()), classs = "eplusr_error_invalid_eplus_ver") - # skip_on_cran() + skip_on_cran() # should download IDD v9.0.1 if input is 9, 9.0, 9.0.1 expect_equal(read_idd(attr(download_idd(9.0, tempdir()), "file"))$version(), numeric_version("9.0.1")) expect_equal(read_idd(attr(download_idd("9.0.1", tempdir()), "file"))$version(), numeric_version("9.0.1")) @@ -15,7 +15,7 @@ test_that("download_idd() can download IDD from EnergyPlus repo", { # use_idd() {{{ test_that("can read IDD", { - # skip_on_cran() + skip_on_cran() # remove all parsed IDD .globals$idd <- list() @@ -89,8 +89,6 @@ test_that("can read IDD", { locate_eplus() # can parse old IDD - skip_on_travis() - skip_on_appveyor() expect_silent(use_idd(7.2)) expect_silent(use_idd(8.0)) expect_silent(use_idd(8.1)) From de46ac95a5c9f08f81064ca67f10027aaf369b17 Mon Sep 17 00:00:00 2001 From: Hongyuan Jia Date: Fri, 10 Jul 2020 16:03:38 +0800 Subject: [PATCH 22/43] [fix] Fix IdfRelationBy printing when depth > 0. Closes #246 --- R/format.R | 15 +++++++-------- R/impl-idf.R | 4 +++- 2 files changed, 10 insertions(+), 9 deletions(-) diff --git a/R/format.R b/R/format.R index 3a5708a9f..6173bb765 100644 --- a/R/format.R +++ b/R/format.R @@ -527,15 +527,12 @@ format_idf_relation <- function (ref, direction = c("ref_to", "ref_by")) { # the deepest c(src_class_name[[i]][[1L]], add_pre(src_object_name[[i]][[1L]]), - paste0(" ", unlist(src_value_chr[[i]][[1L]], FALSE, FALSE)) + paste0(" ", add_pre(unlist(src_value_chr[[i]][[1L]], FALSE, FALSE))) ) } else { # remove class and field prefix - srci <- c( - src_value_chr[i[[1L]]], - lapply(src_value_chr[i[-1L]], - function (s) if (length(s) > 1L) stri_sub(s[-(1L:2L)], 7L) else s - ) + srci <- lapply(src_value_chr[i], + function (s) if (length(s) > 1L) stri_sub(s[-(1L:2L)], 7L) else s ) l <- length(srci) @@ -571,8 +568,10 @@ format_idf_relation <- function (ref, direction = c("ref_to", "ref_by")) { ref[[i - 1L]] <- rbindlist(list( pre, unique(pre[, .SD, .SDcols = c("class_id", "class_name", "object_id", "object_name", "field_id", "value_chr", "dep", "pointer", "src_class_id", "src_object_id")])[ - cur[, list(src_class_id = class_id, src_class_name = class_name, src_object_id = object_id, src_object_name = object_name, src_field_id = field_id, src_value_chr)], - on = c("src_class_id", "src_object_id"), allow.cartesian = TRUE] + cur[, list(src_class_id = class_id, src_class_name = class_name, + src_object_id = object_id, src_object_name = object_name, + src_field_id = field_id, src_value_chr)], + on = c("src_class_id", "src_object_id"), allow.cartesian = TRUE] ), fill = TRUE) setorderv(ref[[i - 1L]], c("class_id", "object_id", "field_id", "src_class_id", "src_object_id", "src_field_id")) diff --git a/R/impl-idf.R b/R/impl-idf.R index 16cdc2506..c273d61f6 100644 --- a/R/impl-idf.R +++ b/R/impl-idf.R @@ -3623,8 +3623,10 @@ get_idf_node_relation <- function (idd_env, idf_env, object_id = NULL, value_id all_nodes <- all_nodes[!J(cur_nodes$value_id), on = "value_id"] # match new nodes new_nodes <- all_nodes[J(unique(cur_nodes$object_id)), on = col_ref, nomatch = NULL] + # excluding already matched objects + all_nodes <- all_nodes[!J(new_nodes$value_id), on = "value_id"] setnames(new_nodes, c("object_id", "value_id"), c("src_object_id", "src_value_id")) - new_nodes <- all_nodes[new_nodes, on = "value_chr"] + new_nodes <- all_nodes[new_nodes, on = "value_chr", nomatch = NULL] # get objects that do not going any deeper # those objects should be removed From 9ddfc1a7250054a2b681d68272faa43a1d3deb36 Mon Sep 17 00:00:00 2001 From: Hongyuan Jia Date: Fri, 10 Jul 2020 17:03:19 +0800 Subject: [PATCH 23/43] [refactor] Refactor impl-idf.R --- R/impl-idf.R | 5568 +++++++++++++++++--------------- man/add_idf_object.Rd | 49 + man/del_idf_object.Rd | 52 + man/dup_idf_object.Rd | 33 + man/duplicated_idf_object.Rd | 27 + man/expand_idf_dots_literal.Rd | 76 + man/expand_idf_dots_name.Rd | 36 + man/expand_idf_dots_object.Rd | 46 + man/expand_idf_dots_value.Rd | 78 + man/expand_idf_regex.Rd | 39 + man/get_idf_object.Rd | 47 + man/get_idf_relation.Rd | 79 + man/get_idf_value.Rd | 67 + man/init_idf_object.Rd | 45 + man/init_idf_value.Rd | 66 + man/make_idf_object_name.Rd | 50 + man/purge_idf_object.Rd | 28 + man/read_idfeditor_copy.Rd | 35 + man/rename_idf_object.Rd | 43 + man/set_idf_object.Rd | 41 + man/unique_idf_object.Rd | 26 + tests/testthat/test_impl-idf.R | 2192 +++++++++---- 22 files changed, 5487 insertions(+), 3236 deletions(-) create mode 100644 man/add_idf_object.Rd create mode 100644 man/del_idf_object.Rd create mode 100644 man/dup_idf_object.Rd create mode 100644 man/duplicated_idf_object.Rd create mode 100644 man/expand_idf_dots_literal.Rd create mode 100644 man/expand_idf_dots_name.Rd create mode 100644 man/expand_idf_dots_object.Rd create mode 100644 man/expand_idf_dots_value.Rd create mode 100644 man/expand_idf_regex.Rd create mode 100644 man/get_idf_object.Rd create mode 100644 man/get_idf_relation.Rd create mode 100644 man/get_idf_value.Rd create mode 100644 man/init_idf_object.Rd create mode 100644 man/init_idf_value.Rd create mode 100644 man/make_idf_object_name.Rd create mode 100644 man/purge_idf_object.Rd create mode 100644 man/read_idfeditor_copy.Rd create mode 100644 man/rename_idf_object.Rd create mode 100644 man/set_idf_object.Rd create mode 100644 man/unique_idf_object.Rd diff --git a/R/impl-idf.R b/R/impl-idf.R index c273d61f6..daefd008b 100644 --- a/R/impl-idf.R +++ b/R/impl-idf.R @@ -1,910 +1,40 @@ #' @importFrom cli cat_bullet cat_line cat_rule rule symbol -#' @importFrom data.table copy data.table dcast rbindlist +#' @importFrom checkmate assert assert_names assert_string assert_data_frame +#' @importFrom checkmate assert_count assert_character assert_subset +#' @importFrom checkmate test_integerish check_integerish test_character +#' @importFrom checkmate qassert qassertr qtestr +#' @importFrom data.table copy data.table dcast rbindlist transpose #' @importFrom data.table setattr setcolorder setnames setorder setorderv #' @importFrom stringi stri_locate_first_regex stri_replace_first_regex "stri_sub<-" #' @importFrom stringi stri_subset_regex stri_match_first_regex stri_rand_strings #' @include impl-idd.R NULL -# DOTS -# ...elt(n) to get the nth element in dots (after evaluation) -# ...length() to get the total number of element in dots (without evaluation) -# dot_string {{{ -dot_string <- function (dt, collapse = "\n") { - dt[, string := paste0(" #", lpad(rleid, "0"), "| ", dot)] - dt[!is.na(dot_nm), string := paste0(" #", lpad(rleid, "0"), "| ", dot_nm, " = ", dot, collapse = collapse)] - on.exit(set(dt, NULL, "string", NULL), add = TRUE) - str_trunc(stri_replace_all_fixed(paste0(dt$string, collapse = collapse), "", "")) -} -# }}} -# find_dot {{{ -find_dot <- function (dot, dt) dt[dot, on = "rleid", mult = "first", nomatch = 0L] -# }}} -# old_input {{{ -old_input <- function (which, value = NULL, comment = NULL, type = c("add", "set")) { - assert_valid_input_format(class, value, comment, default, type) - - input <- rep(list(list()), length(which)) - - if (!is.null(value)) { - if (is_scalar(which)) { - input <- list(value) - } else { - null <- vapply(value, is.null, logical(1L)) - input[null] <- rep(list(list()), sum(null)) - input[!null] <- value[!null] - } - } - - setattr(input, "names", which) -} -# }}} -# sep_name_dots {{{ -sep_name_dots <- function (..., .can_name = TRUE) { - l <- list(...) - - # stop if empty input - if (!length(l)) abort("error_empty_input", "Please give object(s) to modify.") - - # check type of each element - get_type <- function (x) { - if (is.null(x) || !length(x)) { - 3L - } else if (all(are_count(x)) && all(is.finite(x))) { - 1L - } else if (is.character(x) && !anyNA(x)) { - 2L - } else { - 3L - } - } - type <- viapply(l, get_type) - - # put all data into a data.table - dt_dot <- data.table(rleid = seq_along(l), dot = l, dot_nm = names2(l), type = type) - - # stop if invalid depth or type found - if (any(type == 3L)) { - abort("error_wrong_type", - paste0("Each element must be a character vector or a positive integer", - " vector. Invalid input:\n", dot_string(dt_dot[J(3L), on = "type"]) - ) - ) - } - - empty_input <- list( - id = data.table(rleid = integer(), object_rleid = integer(), - object_id = integer(), new_object_name = character() - ), - name = data.table(rleid = integer(), object_rleid = integer(), - object_name = character(), new_object_name = character() - ) - ) - - nest_nmd <- integer() - - flatten <- function (dt, type) { - t <- type - empty <- if (type == 1L) "id" else "name" - - dt[J(t), on = "type", { - if (all(is.na(rleid))) return(empty_input[[empty]]) - - len <- each_length(dot) - rleid <- rep(rleid, len) - obj <- unlist(dot, use.names = TRUE) - if (.can_name) { - new_nms <- names2(obj) - dot_nm <- rep(dot_nm, len) - nest_nmd <<- c(nest_nmd, unique(rleid[!is.na(dot_nm) & !is.na(new_nms)])) - new_nms[is.na(new_nms)] <- dot_nm[is.na(new_nms)] - } else { - new_nms <- rep(NA_character_, sum(len)) - } - - res <- list(rleid = rleid, - object_rleid = unlist(lapply(len, seq.int), use.names = FALSE), - object = obj, - new_object_name = new_nms - ) - - setattr(res, "names", names(empty_input[[empty]])) - }] - } - - res <- list(id = flatten(dt_dot, 1L), name = flatten(dt_dot, 2L), dot = dt_dot) - - if (length(nest_nmd)) { - warn("warning_nest_named", - paste0( - "Named vectors found in named input element. ", - "Names of vectors will be used instead of element's name for:\n", - dot_string(dt_dot[nest_nmd]) - ) - ) - } - - res -} -# }}} -# sep_value_dots {{{ -sep_value_dots <- function (..., .empty = !in_final_mode(), .scalar = TRUE, .null = TRUE, .env = parent.frame()) { - l <- eval(substitute(alist(...))) - - # stop if empty input - if (!length(l)) abort("error_empty_input", "Please give object(s) to modify.") - - dot_nm <- as.list(names2(l)) - is_cls <- rep(FALSE, length(l)) - - # only the first depth is supported - for (i in seq_along(l)) { - if (!is.null(l[[i]]) && length(l[[i]]) > 2L && is.call(l[[i]]) && as.character(l[[i]][[1L]]) == ":=") { - if (length(l[[i]][[2L]]) > 1L && l[[i]][[2L]][[1L]] == ".") { - dot_nm[[i]] <- as.list(l[[i]][[2L]][-1L]) - # for ..x - dot_nm[[i]] <- unlist(lapply(dot_nm[[i]], function (d) { - if (grepl("\\.\\.\\d+", as.character(d))) { - as.character(d) - } else { - eval(d, envir = .env) - } - })) - } else { - dot_nm[[i]] <- as.character(l[[i]][[2L]]) - is_cls[[i]] <- TRUE - } - l[[i]] <- l[[i]][-c(1:2)][[1L]] - } - l[i] <- list(eval(l[[i]], envir = .env)) - } - - dt_dot <- data.table(rleid = seq_along(l), - object_rleid = as.list(rep(1L, length(l))), - dep = vapply(l, vec_depth, integer(1L)), - dot = l, dot_nm = dot_nm, class = is_cls - ) - - if (.scalar) { - empty_input <- list( - object = data.table(rleid = integer(), object_rleid = integer(), - name = character(), comment = list(), empty = logical() - ), - value = data.table(rleid = integer(), object_rleid = integer(), - field_name = character(), value_chr = character(), value_num = double(), - defaulted = logical() - ) - ) - } else { - empty_input <- list( - object = data.table(rleid = integer(), object_rleid = integer(), - name = character(), comment = list(), empty = logical() - ), - value = data.table(rleid = integer(), object_rleid = integer(), - field_name = character(), value_chr = list(), value_num = list(), - defaulted = logical() - ) - ) - } - - is_empty_list <- function (x) is.list(x) && length(x) == 0L - - # abort invalid {{{ - abort_invalid_input <- function (id, err_type, mes) { - abort(paste0("error_dot_", err_type), - paste0(paste0(mes, collapse = ""), " Invalid input:\n", - dot_string(dt_dot[J(id), on = "rleid"]) - ) - ) - } - - abort_invalid_name <- function (id) { - abort_invalid_input(id, "invalid_name", "Object ID and name connot contains NA") - } - - abort_invalid_format <- function (id) { - if (.null) { - if (.scalar) { - fmt <- "NULL, a non-NA single string or number." - } else { - fmt <- "NULL, a non-NA character or numeric vector." - } - } else { - if (.scalar) { - fmt <- "a non-NA single string or number." - } else { - fmt <- "non-NA a character or numeric vector." - } - } - if (.empty) { - abort_invalid_input(id, "invalid_format", - c("Each object must be an empty list or a list where ", - "each element being ", fmt) - ) - } else { - abort_invalid_input(id, "invalid_format", - c("Each object must be a list where ", - "each element being ", fmt) - ) - } - } - - abort_empty_dot <- function (id) { - abort_invalid_input(id, "empty", - "Empty input found. Please give field values to add or set." - ) - } - - abort_multi_comment <- function (id) { - abort_invalid_input(id, "multi_comment", - "Each object can only have one `.comment` element." - ) - } - - abort_duplicated_name <- function (id) { - abort_invalid_input(id, "dup_field_name", "Field names must be unique.") - } - - abort_comment_value <- function (id) { - abort_invalid_input(id, "comment_value", "Field value cannot start with `!`.") - } - # }}} - - # flatten {{{ - flatten <- function (dt, minus = 0L) { - dt[, { - len <- viapply(dot, length, use.names = FALSE) - dot <- unlist(dot, recursive = FALSE) - # in case list() - if (!length(dot)) dot <- rep(list(), len) - list(rleid = rep(rleid, len), - object_rleid = as.list(unlist(object_rleid, use.names = FALSE)), - dep = rep(dep - minus, len), - dot = dot, - dot_nm = names2(dot) - ) - }] - } - # }}} - - # flatten_input {{{ - flatten_input <- function (dt) { - if (!nrow(dt)) return(empty_input) - - dep <- unique(dt$dep) - - # empty object, e.g. Construction = list() - if (dep == 1L) { - # {{{ - if (any(!vlapply(dt$dot, is.list) | is.na(dt$dot_nm))) { - abort_invalid_format(dt[!vlapply(dot, is.list) | is.na(dot_nm), rleid]) - } - - set(dt, NULL, "object_rleid", unlist(dt$object_rleid, use.names = FALSE)) - set(dt, NULL, "dot_nm", unlist(dt$dot_nm, use.names = FALSE)) - set(dt, NULL, "dep", NULL) - setnames(dt, "dot_nm", "name") - - if (nrow(dt) == 1L) { - set(dt, NULL, "comment", list(list(NULL))) - } else { - set(dt, NULL, "comment", rep(list(NULL), nrow(dt))) - } - set(dt, NULL, "empty", vlapply(dt$dot, is_empty_list)) - - if ((!.empty || !.null) && any(dt$empty)) abort_empty_dot(dt$rleid[dt$empty]) - - if (all(dt$empty)) { - val <- empty_input$value - } else { - val <- dt[empty == FALSE, { - # field number of each object - len <- each_length(dot) - - # init field name - field_name <- rep("", sum(len)) - - # get field name and value - fld_val <- unlist(dot, recursive = FALSE, use.names = TRUE) - - # set field name and value - field_name <- names2(fld_val) - - # duplicated field name: "cls = list(a = 1, a = 2)" - if (anyDuplicated(stri_trans_tolower(field_name))) { - abort_duplicated_name(rleid) - } - - value_chr <- rep(NA_character_, len) - value_num <- rep(NA_real_, len) - if (!.scalar) { - value_chr <- as.list(value_chr) - value_num <- as.list(value_num) - } - - list(rleid = rep(rleid, len), - object_rleid = rep(object_rleid, len), - field_name = field_name, - value_chr = value_chr, - value_num = value_num, - defaulted = rep(TRUE, .N) - ) - }] - } - - res <- list(object = set(dt, NULL, "dot", NULL), value = val) - # }}} - } else if (dep == 2L) { - # {{{ - # check if is format "list(cls = list(NULL), cls = list())" - dot_nmd <- vlapply(dt$dot_nm, function (x) !anyNA(x)) - len_nm <- each_length(dt$dot_nm) - - # stop if input name contains NA - if (any(len_nm > 1L & !dot_nmd)) { - abort_invalid_name(dt$rleid[len_nm > 1L & !dot_nmd]) - } - - # correct object rleid - dt[!dot_nmd, `:=`(object_rleid = list(seq.int(each_length(dot))) ), by = "rleid"] - if (any(len_nm > 1L & dot_nmd)) { - dt[len_nm > 1L & dot_nmd, `:=`(object_rleid = list(seq.int(dot_nm[[1L]]))), by = "rleid"] - } - - # flatten format: "list(cls = list(), cls = list(NULL, NULL))" - dt_unnmd <- flatten(dt[!dot_nmd]) - dt_multi <- dt[len_nm > 1L & dot_nmd][, { - len <- each_length(object_rleid) - object_rleid <- unlist(object_rleid) - dot_nm <- unlist(lapply(dot_nm, function (x) if (is.numeric(x)) paste0("..", x) else x)) - if (is.null(object_rleid)) object_rleid <- integer() - if (is.null(dot_nm)) dot_nm <- character() - list(rleid = rep(rleid, len), - object_rleid = object_rleid, - dep = rep(dep, len), - dot = rep(dot, len), - dot_nm = dot_nm - ) - }] - - # stop if object without names: "list(list(), list(NULL), list(NULL, NULL))" - if (anyNA(dt_unnmd$dot_nm) | any(vlapply(dt_unnmd$dot, is.null))) { - abort_invalid_format(dt_unnmd[is.na(dot_nm) | vlapply(dt_unnmd$dot, is.null), unique(rleid)]) - } - - # combine - obj <- rbindlist(list(dt_unnmd, dt_multi, dt[len_nm == 1L & dot_nmd])) - obj[, dot_nm := unlist(dot_nm)] - - # check if empty object - set(obj, NULL, "empty", vlapply(obj$dot, is_empty_list)) - - # stop if empty object is not allowed - if ((!.empty || !.null) && any(obj$empty)) abort_empty_dot(unique(obj$rleid[obj$empty])) - - # change object_rleid into integer vector - set(obj, NULL, "object_rleid", unlist(obj$object_rleid, use.names = FALSE)) - - # reorder - setorderv(obj, c("rleid", "object_rleid")) - - set(obj, NULL, "dep", NULL) - set(obj, NULL, "comment", list(rep(list(NULL), nrow(obj)))) - setnames(obj, "dot_nm", "name") - - if (all(obj$empty)) { - val <- empty_input$value - } else { - val <- obj[empty == FALSE, { - # field number of each object - len <- each_length(dot) - - # get an unique id for each object - uni_id <- .I - - # init rleid and object_rleid - rleid <- rep(rleid, len) - object_rleid <- rep(object_rleid, len) - uni_id <- rep(uni_id, len) - - # set all values to NULL by default - value_list <- rep(list(NULL), sum(len)) - - # init field name - field_name <- rep("", sum(len)) - - # get field name and value - fld_val <- unlist(dot, recursive = FALSE, use.names = TRUE) - - # set field name and value - field_name <- names2(fld_val, "") - value_list <- unname(fld_val) - - each_len <- each_length(value_list) - - # init value in character and numeric format - value_chr <- apply2(as.list(rep(NA_character_, sum(len))), each_len, rep) - value_num <- apply2(as.list(rep(NA_real_, sum(len))), each_len, rep) - - # init default value indicator - defaulted <- each_len == 0L - if (!.null && any(defaulted)) { - abort_invalid_format(rleid[defaulted]) - } - # init defaulted values - value_chr[defaulted] <- NA_character_ - value_num[defaulted] <- NA_real_ - - # contains NA: "cls = list(NA), list(cls = list(NA))" {{{ - # put this before check comment to make sure there is no NA - # in comments - if (anyNA(value_list, recursive = TRUE)) { - abort_invalid_format(unique(rleid[vlapply(value_list, anyNA)])) - } - # }}} - - # duplicated comment: "cls = list(.comment = c("a"), .comment = NULL)" {{{ - is_cmt <- field_name == ".comment" - if (any(is_cmt)) { - cmt_id <- uni_id[is_cmt] - # stop if multiple .comments found - if (anyDuplicated(cmt_id)) { - abort_multi_comment(unique(rleid[duplicated(uni_id[is_cmt])])) - } - - # check if there is only comment in the input - len[cmt_id] <- len[cmt_id] - 1L - - if (any(len == 0L)) set(obj, .I[len == 0L], "empty", TRUE) - - # update comment, coerce to character - set(obj, cmt_id, "comment", - list(lapply(value_list[is_cmt], - function (x) { - x <- as.character(x); - if (length(x)) x else NULL - } - )) - ) - - # if all are comments, no value - if (all(len == 0L)) {return(empty_input$value)} - - rleid <- rleid[!is_cmt] - object_rleid <- object_rleid[!is_cmt] - uni_id <- uni_id[!is_cmt] - field_name <- field_name[!is_cmt] - value_list <- value_list[!is_cmt] - value_chr <- value_chr[!is_cmt] - value_num <- value_num[!is_cmt] - defaulted <- defaulted[!is_cmt] - - # update length - each_len <- each_length(value_list) - } - # }}} - - - # not scalar: "cls = list(1:5)" {{{ - if (.scalar & any(each_len > 1L)) { - abort_invalid_format(unique(rep(rleid, each_len)[each_len > 1L])) - } - # }}} - - # not NULL, character or numeric {{{ - # this will find out "list()" - is_num <- vlapply(value_list, is.numeric) - if (any(vlapply(value_list, function (x) !is.null(x) && !is.character(x)) & !is_num)) { - id <- rleid[vlapply(value_list, function (x) !is.null(x) && !is.character(x)) & !is_num] - abort_invalid_format(unique(id)) - } - # }}} - - # check if field names are given - no_nm <- stri_isempty(field_name) - - # duplicated field name: "cls = list(a = 1, a = 2)" {{{ - if (any(!no_nm) && anyDuplicated(data.table(uni_id[!no_nm], stri_trans_tolower(underscore_name(field_name[!no_nm]))))) { - dt <- data.table(id = uni_id[!no_nm], field_name = stri_trans_tolower(underscore_name(field_name[!no_nm]))) - abort_duplicated_name(obj$rleid[dt$id[duplicated(dt)]]) - } - # }}} - - # comment value: "cls = list(a = "!b")" {{{ - if (any(stri_startswith_fixed(unlist(value_list, use.names = FALSE), "!"))) { - abort_comment_value( - unique(rleid[!defaulted][ - vlapply(value_list[!defaulted], stri_startswith_fixed, "!") - ]) - ) - } - # }}} - - # get value in both character and numeric format - # change empty strings to NA - value_chr[!defaulted] <- lapply(value_list[!defaulted], function (val) { - val <- as.character(val) - val[stri_isempty(stri_trim_both(val))] <- NA_character_ - val - }) - - value_num[!defaulted & is_num] <- lapply(value_list[!defaulted & is_num], as.double) - - # change empty field names to NA - field_name[no_nm] <- NA_character_ - - if (.scalar) { - value_num <- unlist(value_num) - value_chr <- unlist(value_chr) - } - - list(rleid = rleid, - object_rleid = object_rleid, - field_name = field_name, - value_chr = value_chr, - value_num = value_num, - defaulted = defaulted - ) - }] - } - - set(obj, NULL, "dot", NULL) - res <- list(object = obj, value = val) - # }}} - } else if (dep == 3L) { - if (any(!is.na(dt$dot_nm))) abort_invalid_format(dt[!is.na(dot_nm), rleid]) - dt[, `:=`(object_rleid = list(seq.int(each_length(dot)))), by = "rleid"] - res <- flatten_input(flatten(dt, 1L)) - } else { - abort_invalid_format(dt$rleid) - } - - res - } - # }}} - - flat <- lapply(split(copy(dt_dot)[, class := NULL], by = "dep"), flatten_input) - - list(object = rbindlist(lapply(flat, .subset2, "object"), use.names = TRUE), - value = rbindlist(lapply(flat, .subset2, "value"), use.names = TRUE), - dot = dt_dot - ) -} -# }}} -# sep_object_dots {{{ -sep_object_dots <- function (...) { - l <- list(...) - - # stop if empty input - if (!length(l)) abort("error_empty_input", "Please give object(s) to insert.") - - .t <- list(idf = 1L, idfobject = 2L, list = 3L, invalid = 0L) - # check type of each element - get_depth <- function (x) { - if (is_idf(x)) { - .t$idf - } else if (is_idfobject(x)) { - .t$idfobject - } else if (is.list(x) & length(x) > 0) { - .t$list - } else { - .t$invalid - } - } - depth <- viapply(l, get_depth) - - # put all data into a data.table - dt_dot <- data.table(rleid = seq_along(l), dot = l, dot_nm = names2(l), dep = depth) - - if (any(depth == 0L)) { - abort("error_wrong_type", - paste0("Each element must be an IdfObject or a list of IdfObjects. ", - "Invalid input:\n", dot_string(dt_dot[J(.t$invalid), on = "dep"]) - ) - ) - } - - # to avoid partial matching - if (any(depth == .t[["idf"]])) { - dt_idf <- dt_dot[J(.t[["idf"]]), on = "dep"] - } else { - dt_idf <- data.table() - } - - if (any(depth == .t$idfobject)) { - dt_idfobj <- dt_dot[J(.t$idfobject), on = "dep"] - } else { - dt_idfobj <- data.table() - } - - if (any(depth == .t$list)){ - dt_list <- dt_dot[J(.t$list), on = "dep", - { - len <- each_length(dot) - lst <- unlist(dot, recursive = FALSE, use.names = TRUE) - dep <- viapply(lst, get_depth) - list(dot = lst, dot_nm = names2(lst), dep = dep) - }, by = "rleid"] - } else { - dt_list <- data.table() - } - - dt <- rbindlist(list(dt_idf, dt_idfobj, dt_list), use.names = TRUE) - setorderv(dt, "rleid") - add_rleid(dt, "object") - - dt[, c("version", "uuid", "object_id", "idd_env", "idf_env") := { - if (is_idf(dot[[1L]])) { - list(._get_private(dot[[1L]])$m_version, - ._get_private(dot[[1L]])$m_log$uuid, - # use a negative integer to indicate this is an Idf - -1L, - list(._get_private(dot[[1L]])$idd_env()), - list(._get_private(dot[[1L]])$idf_env()) - ) - } else if (is_idfobject(dot[[1L]])) { - list(._get_private(._get_private(dot[[1L]])$m_parent)$m_version, - ._get_private(._get_private(dot[[1L]])$m_parent)$m_log$uuid, - ._get_private(dot[[1L]])$m_object_id, - list(._get_private(dot[[1L]])$idd_env()), - list(._get_private(dot[[1L]])$idf_env()) - ) - } else { - abort("error_wrong_type", - paste0("Each element must be an Idf or an IdfObject, or a list of Idfs or IdfObjects. ", - "Invalid input:\n", dot_string(copy(.SD)) - ) - ) - } - }, by = "object_rleid"] - - # remove duplicated - if (any(dup <- duplicated(dt, by = c("uuid", "object_id")))) { - # give info - verbose_info( - "Duplicated objects in input have been removed:\n", - get_object_info(dt[dup], "id", collapse = "\n", name_prefix = FALSE) - ) - - dt <- dt[!dup] - } - - list(data = dt, dot = dt_dot) -} -# }}} -# sep_definition_dots {{{ -sep_definition_dots <- function (..., .version = NULL, .update = FALSE) { - l <- list(...) - - # stop if empty input - if (!length(l)) { - if (.update) { - abort("error_empty_input", "Please give object(s) to update.") - } else { - abort("error_empty_input", "Please give object(s) to load.") - } - } - - # check type of each element - get_depth <- function (x) { - if (is.character(x)) { - if (anyNA(x)) 0L else 1L - } else if (is.data.frame(x)) { - if (.update) { - if (has_name(x, c("id", "class", "index", "value"))) 2L else 0L - } else { - if (has_name(x, c("class", "index", "value"))) 2L else 0L - } - } else { - 0L - } - } - depth <- viapply(l, get_depth) - - # put all data into a data.table - dt_dot <- data.table(rleid = seq_along(l), dot = l, dot_nm = names2(l), depth = depth) - - if (any(depth == 0L)) { - cols <- c("class", "index", "value") - if (.update) cols <- c("id", cols) - abort("error_wrong_type", - paste0("Each element must be a character vector with no NA or ", - "a data frame with column ", collapse(cols), ". ", - "Invalid input:\n", str_trunc(dot_string(dt_dot[J(0L), on = "depth"])) - ) - ) - } - - if (!any(depth == 1L)) { - parsed <- list() - } else { - str_in <- unlist(dt_dot[J(1L), on = "depth", dot], use.names = FALSE) - - # get total line number in each dot - l <- dt_dot[J(1L), on = "depth", - { - list(line_rleid = seq.int(length(dot[[1L]]) + stri_count_fixed(dot[[1L]], "\n"))) - }, - by = "rleid" - ] - - # here insert an version string - # if there is version definition in the input, there will be an - # `error_multi_idf_ver` error - str_in <- c(paste0("Version,", .version, ";"), str_in) - - parsed <- withCallingHandlers( - parse_idf_file(paste0(str_in, collapse = "\n"), ref = FALSE), - - # ignore the warning of using given IDD - warning_given_idd_used = function (w) invokeRestart("muffleWarning"), - - # modify messages if any error occurs - error_parse_idf = function (e) { - set(l, NULL, "line", seq.int(nrow(l))) - - data <- e$data[, line := line - 1L] - - # remove inserted version - if (class(e)[[1L]] == "error_multiple_version") { - data <- data[!J(0L), on = "line"] - } - - add_joined_cols(l, data, "line", c("rleid", "line_rleid")) - set(data, NULL, "msg_each", paste0("[Input #", data$rleid, "]")) - - # use line in each input - set(data, NULL, "line", data$line_rleid) - - # get line number in each object - t <- switch(class(e)[[1L]], - error_multiple_version = "Adding Version object is prohibited", - error_unknown_line = "Invalid line found", - error_incomplete_object = "Incomplete object", - error_invalid_class = "Invalid class name", - error_invalid_field_number = "Invalid field number" - ) - - parse_issue(class(e)[[1L]], "idf", t, data) - } - ) - - # remove inserted version object - parsed$object <- parsed$object[!J(1L), on = "object_id"] - parsed$value <- parsed$value[!J(1L), on = "object_id"] - parsed$object[, `:=`(object_id = object_id - 1L)] - parsed$value[, `:=`(object_id = object_id - 1L, value_id = value_id - 1L)] - - # after parsing all input character as a whole, there is no way to know - # how many objects are extracted from each input - # object ID should be sufficent for distinguishing all objects - # add rleid for latter error printing - set(parsed$object, NULL, "rleid", 1L) - set(parsed$value, NULL, "rleid", 1L) - } - - # extract_dt_input {{{ - extract_dt_input <- function (dt, id) { - dt <- as.data.table(dt) - # check field index duplication - if (has_name(dt, "id")) { - if (anyDuplicated(dt, by = c("id", "class", "index"))) { - abort("error_dot_def_index_dup", - paste0("When input is a data.frame, `id`, `class` and `index` ", - " column combined should not contain any duplication. ", - "Invalid input:\n", - str_trunc(dot_string(dt_dot[J(id), on = "rleid"])) - ) - ) - } - if (.update) { - setnames(dt, "id", "object_id") - } else { - dt[, object_id := .GRP, by = c("id", "class")] - } - } else if (anyDuplicated(dt, by = c("class", "index"))) { - abort("error_dot_def_index_dup", - paste0("When input is a data.frame, `class` and `index` column ", - "combined should not contain any duplication. Invalid input:\n", - str_trunc(dot_string(dt_dot[J(id), on = "rleid"])) - ) - ) - } else { - set(dt, NULL, "object_id", rleid(dt$class)) - } - - # value column should be either character or list - if (!is.character(dt$value) && !is.list(dt$value)) { - abort("error_dot_def_value_type", - paste0("When input is a data.frame, `value` column should be ", - "either a character vector or a list. Invalid input:\n", - str_trunc(dot_string(dt_dot[J(id), on = "rleid"])) - ) - ) - } - - defaulted <- rep(FALSE, nrow(dt)) - - # if value is character, trim spaces and convert them into NAs - if (is.character(dt$value)) { - value_chr <- stri_trim_both(dt$value) - value_chr[stri_isempty(value_chr)] <- NA_character_ - value_num <- suppressWarnings(as.double(value_chr)) - - # an indicator of input value type. 1: character, 2: list - type <- 1L - - # mark NA input as defaulted - defaulted[is.na(value_chr)] <- TRUE - # if value is a list, each element should be a single character or a - # number. - } else { - get_type <- function (x) { - if (is.null(x)) return(3L) - if (!is_scalar(x)) return(0L) - if (is.numeric(x)) 1L else if (is.character(x)) 2L else 0L - } - - type <- viapply(dt$value, get_type) - - if (any(type == 0L)) { - abort("error_dot_def_value_type", - paste0("When input is a data.frame and `value` column is a list, ", - "each element in that list should be a single string or number. ", - "Invalid input:\n", - str_trunc(dot_string(dt_dot[J(id), on = "rleid"])) - ) - ) - } - - # change NULL to NA - dt$value[type == 3] <- NA_character_ - - # change empty strings to NA - value_chr <- unlist(dt$value, use.names = FALSE) - value_chr <- stri_trim_both(value_chr) - value_chr[stri_isempty(value_chr)] <- NA_character_ - - value_num <- rep(NA_real_, nrow(dt)) - value_num[type == 1L] <- unlist(dt$value[type == 1L], use.names = FALSE) - - defaulted[is.na(value_chr)] <- TRUE - - # value cannot start with "!" - if (any(stri_startswith_fixed(value_chr[!defaulted], "!"))) { - abort("error_dot_def_value_type", - paste0("When input is a data.frame and `value` column is a list, ", - "string value should not be IDF comment, i.e. starts with `!`. ", - "Invalid input:\n", - str_trunc(dot_string(dt_dot[J(id), on = "rleid"])) - ) - ) - } - - # an indicator of input value type. 1: character, 2: list - type <- 2L - } - - list(object_id = dt$object_id, class_name = dt$class, - field_index = dt$index, value_chr = value_chr, - value_num = value_num, defaulted = defaulted, type = type - ) - } - # }}} - - if (!any(depth == 2L)) { - dt_dt <- data.table() - } else { - # copy them before convert them to data.table - dt_dt <- dt_dot[J(2L), on = "depth", extract_dt_input(dot[[1L]], rleid), by = "rleid"] - } - - list(parsed = parsed, value = dt_dt, dot = dt_dot) -} -# }}} - # OBJECT # get_idf_object {{{ +#' Get object data +#' +#' @param idd_env An environment or list contains IDD tables including class, +#' field, and reference. +#' @param idf_env An environment or list contains IDF tables including object, +#' value, and reference. +#' @param class An integer vector of valid class indexes or a character vector +#' of valid class names. Default: `NULL`. +#' @param object An integer vector of valid object IDs or a character vector +#' of valid object names. Default: `NULL`. +#' @param property A character vector of column names in class table to return. +#' @param underscore If `TRUE`, input class name will be converted into +#' underscore style name first and column `class_name_us` will be used +#' for matching. Default: `FALSE`. +#' @param ignore_case If `TRUE`, input object name will be converted into lower +#' case and column `object_name_lower` will be used for matching. +#' converted into underscore style name first and column `class_name_us` +#' and `field_name_us` will be used for matching. Default: `FALSE`. +#' +#' @return A data.table. +#' +#' @keywords internal +#' @export get_idf_object <- function (idd_env, idf_env, class = NULL, object = NULL, property = NULL, underscore = FALSE, ignore_case = FALSE) { # if no object is specified @@ -913,7 +43,7 @@ get_idf_object <- function (idd_env, idf_env, class = NULL, object = NULL, prope if (is.null(class)) { obj <- add_class_name(idd_env, copy(idf_env$object)) if (!is.null(property)) { - obj <- add_class_property(idd_env, idf_env$object, property) + obj <- add_class_property(idd_env, obj, property) } # add rleid add_rleid(obj) @@ -928,21 +58,18 @@ get_idf_object <- function (idd_env, idf_env, class = NULL, object = NULL, prope } else { # get class id cls_in <- join_from_input( - idd_env$class[, .SD, .SDcols = c("class_id", unique(c("class_name", col_on)))], + idd_env$class[, .SD, .SDcols = c("group_id", "class_id", unique(c("class_name", col_on)))], cls_in, "group_id" ) + set(cls_in, NULL, "group_id", NULL) col_on <- "class_id" } col_add <- setdiff(names(idf_env$object), names(cls_in)) - if (!length(col_add)) { - obj <- cls_in - } else { - obj <- idf_env$object[, .SD, .SDcols = c(col_on, col_add)][, check := .I][cls_in, on = col_on] - check_bad_key(obj, "check", col_key) - set(obj, NULL, "check", NULL) - } + obj <- idf_env$object[, .SD, .SDcols = c(col_on, col_add)][, check := .I][cls_in, on = col_on] + check_bad_key(obj, "check", col_key) + set(obj, NULL, "check", NULL) if (!is.null(property)) obj <- add_class_property(idd_env, obj, property) } @@ -966,9 +93,10 @@ get_idf_object <- function (idd_env, idf_env, class = NULL, object = NULL, prope } else { # get class id cls_in <- join_from_input( - idd_env$class[, .SD, .SDcols = c("class_id", unique(c("class_name", names(cls_in)[[1L]])))], + idd_env$class[, .SD, .SDcols = c("group_id", "class_id", unique(c("class_name", names(cls_in)[[1L]])))], cls_in, "group_id" ) + set(cls_in, NULL, "group_id", NULL) } # add property if necessary @@ -978,7 +106,7 @@ get_idf_object <- function (idd_env, idf_env, class = NULL, object = NULL, prope # if only one class is specified, recycle if (nrow(cls_in) == 1L) cls_in <- cls_in[rep(1L, nrow(obj_in))] - assert(have_same_len(cls_in, obj_in), prefix = "class and object") + assert_same_len(cls_in, obj_in, .var.name = "class and object") col_on <- names(obj_in)[[1L]] @@ -996,7 +124,7 @@ get_idf_object <- function (idd_env, idf_env, class = NULL, object = NULL, prope } # stop if there are objects that have the same name {{{ - if (!have_same_len(obj, object)) { + if (!test_same_len(obj, object)) { mult_rleid <- obj[, .N, by = rleid][N > 1L, rleid] mult <- obj[J(mult_rleid), on = "rleid"] @@ -1007,13 +135,8 @@ get_idf_object <- function (idd_env, idf_env, class = NULL, object = NULL, prope m <- mult[, list(m = paste("Name", surround(object_name[1L]), "matches", collapse(object, NULL))), by = c("rleid", "object_name_lower")][, m := paste0(" #", rpad(rleid), "| ",m)]$m - abort("error_multiple_matched", - paste0( - "Input object name matched multiple results. Please use object ID instead:\n", - paste0(m, collapse = "\n") - ), - data = obj - ) + abort(paste0("Input object name matched multiple results. Please use object ID instead:\n", + paste0(m, collapse = "\n")), "multi_match_by_name") } # }}} } @@ -1072,9 +195,7 @@ get_idf_object_num <- function (idd_env, idf_env, class = NULL) { col_on <- names(cls_in)[[1L]] if (any(!cls_in[[col_on]] %in% idd_env$class[[col_on]])) { col_key <- if (col_on == "class_id") "class index" else "class name" - abort_bad_key("error_invalid_class", col_key, - idd_env$class[cls_in, on = col_on][is.na(group_id), .SD, .SDcols = col_on][[col_on]] - ) + abort_bad_key(col_key, idd_env$class[cls_in, on = col_on][is.na(group_id), .SD, .SDcols = col_on][[col_on]]) } if (col_on == "class_name") cls_in <- add_class_id(idd_env, cls_in) @@ -1087,7 +208,7 @@ get_idf_object_num <- function (idd_env, idf_env, class = NULL) { get_object_info <- function (dt_object, component = c("id", "name", "class"), by_class = FALSE, numbered = TRUE, collapse = NULL, prefix = NULL, name_prefix = TRUE) { - assert(component %in% c("id", "name", "class")) + assert_subset(component, c("id", "name", "class")) if (is.null(prefix)) { key_obj <- "Object" @@ -1107,7 +228,7 @@ get_object_info <- function (dt_object, component = c("id", "name", "class"), mes_id <- dt_object[, ifelse(object_id < 0L, paste0("Input #", lpad(-object_id, "0")), - paste0("ID [", lpad(object_id, " "), "]") + paste0("ID [", lpad(object_id, "0"), "]") ) ] mes <- mes_id @@ -1146,17 +267,16 @@ get_object_info <- function (dt_object, component = c("id", "name", "class"), if (order_cls != 0L) { # If none of ID or name is required if (is.null(mes)) { - mes <- dt_object[, paste0(key_cls, ": ", surround(class_name))] + mes <- dt_object[, paste(key_cls, surround(class_name))] } else { set(dt_object, NULL, "mes_object", mes) - dt_object[!stri_isempty(mes_object), mes_object := paste0(" ", mes_object)] if (by_class) { mes <- dt_object[, { - paste0(key_obj, collapse(mes_object, NULL), " in class ", surround(class_name[1L])) + paste0(key_obj, " ", collapse(mes_object, NULL), " in class ", surround(class_name[1L])) }, by = class_name]$V1 } else { mes <- dt_object[, { - paste0(key_obj, mes_object, " in class ", surround(class_name)) + paste0(key_obj, " ", mes_object, " in class ", surround(class_name)) }] } set(dt_object, NULL, "mes_object", NULL) @@ -1170,7 +290,7 @@ get_object_info <- function (dt_object, component = c("id", "name", "class"), mes <- paste0(prefix, mes) if (numbered) { - if (has_name(dt_object, "rleid")) { + if (has_names(dt_object, "rleid")) { if (by_class) { num <- paste0(" #", lpad(dt_object[, unique(rleid), by = class_name]$V1, "0"), "| ") } else { @@ -1185,10 +305,275 @@ get_object_info <- function (dt_object, component = c("id", "name", "class"), paste0(mes, collapse = collapse) } # }}} +# init_idf_object {{{ +#' Initialize object data +#' +#' @param idd_env An environment or list contains IDD tables including class, +#' field, and reference. +#' @param idf_env An environment or list contains IDF tables including object, +#' value, and reference. +#' @param class An integer vector of valid class indexes or a character vector +#' of valid class names. Default: `NULL`. +#' @param property A character vector of column names in class table to return. +#' @param underscore If `TRUE`, input class name will be converted into +#' underscore style name first and column `class_name_us` will be used +#' for matching. Default: `FALSE`. +#' @param id If `TRUE`, new object IDs will be added in column `object_id` based +#' on current existing objects found in `idf_env`. Default: `TRUE`. +#' @param name If `TRUE`, column `object_name` and `object_name_lower` will be +#' filled using [make_idf_object_name()]. Default: `TRUE`. +#' +#' @return A [data.table::data.table()] +#' +#' @keywords internal +#' @export +init_idf_object <- function (idd_env, idf_env, class, property = NULL, underscore = FALSE, id = TRUE, name = TRUE) { + obj <- get_idd_class(idd_env, class, underscore = underscore, property = property) + set(obj, NULL, c("object_name", "object_name_lower", "comment"), + list(NA_character_, NA_character_, list()) + ) + + id <- if (id) { + if (NROW(idf_env$object)) { + obj$rleid + max(idf_env$object$object_id) + } else { + obj$rleid + } + } else NA_integer_ + + set(obj, NULL, "object_id", id) + + if (name) { + obj <- make_idf_object_name(idd_env, idf_env, obj, use_old = FALSE, keep_na = FALSE, include_ori = TRUE) + set(obj, NULL, c("object_name", "object_name_lower"), NULL) + setnames(obj, c("new_object_name", "new_object_name_lower"), c("object_name", "object_name_lower")) + } + + setcolorder(obj, + c(setdiff(names(obj), c("object_id", "object_name", "object_name_lower", "comment")), + c("object_id", "object_name", "object_name_lower", "comment") + ) + ) +} +# }}} +# make_idf_object_name {{{ +#' Initialize object data +#' +#' @param idd_env An environment or list contains IDD tables including class, +#' field, and reference. +#' @param idf_env An environment or list contains IDF tables including object, +#' value, and reference. +#' @param dt_object A [data.table::data.table()] containing object data. +#' @param use_old If `TRUE`, new object names are based on the original object +#' names in column `object_name`. If `FALSE`, new object names are +#' created based on the class name it belongs to. Default: `TRUE`. +#' @param prefix_col An character vector of column names in input `dt_object` +#' whose values will be combined together as the prefix of the new object +#' names. Default: `NULL`. +#' @param prefix_sep A single string specifying the separation character among +#' prefix columns. Default: `NULL`. +#' @param keep_na If `TRUE`, new object names will be `NA` if the original +#' object names in column `object_name` are `NA`s. Default: `TRUE`. +#' @param include_ori If `TRUE`, make sure new object names are not the same as +#' the original object names in the `object_name` column. Default: `FALSE`. +#' +#' @return A [data.table::data.table()] +#' +#' @keywords internal +#' @export +make_idf_object_name <- function (idd_env, idf_env, dt_object, use_old = TRUE, + prefix_col = NULL, prefix_sep = " ", + keep_na = TRUE, include_ori = FALSE) { + add_hasname <- FALSE + if (!has_names(dt_object, "has_name")) { + add_class_property(idd_env, dt_object, "has_name") + add_hasname <- TRUE + } + + if (!has_names(dt_object, "new_object_name")) { + set(dt_object, NULL, "new_object_name", NA_character_) + } + + if (!has_names(dt_object, "new_object_name_lower")) { + set(dt_object, NULL, "new_object_name_lower", stri_trans_tolower(dt_object[["new_object_name"]])) + } + + # sep objects with/without name attr + can_nm <- dt_object$has_name + dt_obj_nm <- .Call(data.table:::CsubsetDT, dt_object, which(can_nm), seq_along(dt_object)) + dt_obj_no <- .Call(data.table:::CsubsetDT, dt_object, which(!can_nm), seq_along(dt_object)) + + # stop if trying to assign names to objects that do not have name attribute + if (any(!is.na(dt_obj_no$new_object_name))) { + invld <- dt_obj_no[!is.na(new_object_name)] + abort(paste0("Object in class that does not have name attribute cannot be renamed. Invalid input:\n", + get_object_info(invld, numbered = TRUE, collapse = "\n")), + "cannot_name") + } + + # check duplications in new names + if (any(invld <- duplicated(dt_obj_nm[!J(NA_character_), on = "new_object_name_lower"], + by = c("class_id", "new_object_name_lower")))) { + abort(paste0("Input new object names cannot contain duplications. Duplicated names:\n", + paste0(dt_obj_nm[invld, sprintf(" #%s| '%s'", lpad(rleid, "0"), new_object_name)], collapse = "\n")), + "duplicated_name") + } + + dt_all <- fast_subset(idf_env$object, c("class_id", "object_id", "object_name", "object_name_lower")) + + # auto-generate object names if necessary + autoname <- is.na(dt_obj_nm$new_object_name) + dt_obj_nm_auto <- .Call(data.table:::CsubsetDT, dt_obj_nm, which(autoname), seq_along(dt_obj_nm)) + dt_obj_nm_input <- .Call(data.table:::CsubsetDT, dt_obj_nm, which(!autoname), seq_along(dt_obj_nm)) + + # check if input new names are the same as existing ones + if (nrow(invld <- dt_all[dt_obj_nm_input, on = c("class_id", object_name_lower = "new_object_name_lower"), nomatch = 0L])) { + obj <- get_object_info(invld, numbered = FALSE) + abort(paste0("Input new object names cannot be the same as existing object. Conflicting object names:\n", + paste0(sprintf(" #%s| '%s' --> %s", lpad(invld$rleid), invld$new_object_name, obj), collapse = "\n")), + "conflict_name") + } + + # auto generate names and append integer suffix for auto-names if necessary + if (nrow(dt_obj_nm_auto)) { + # extract component names from class names + if (!use_old) { + set(dt_obj_nm_auto, NULL, "new_object_name", get_class_component_name(dt_obj_nm_auto$class_name)) + + if (!is.null(prefix_col)) { + dt_obj_nm_auto[, new_object_name := do.call(paste, c(.SD, sep = prefix_sep)), .SDcols = c(prefix_col, "new_object_name")] + } + # use the original object name if possible + } else { + dt_obj_nm_auto[, "new_object_name" := { + # fill missing object name with extracted component name + # from class name + if (!keep_na) { + object_name[is.na(object_name)] <- get_class_component_name(class_name[is.na(object_name)]) + } + object_name + }] + + if (!is.null(prefix_col)) { + if (keep_na) { + dt_obj_nm_auto[!J(NA_character_), on = "object_name", + new_object_name := do.call(paste, c(.SD, sep = prefix_sep)), .SDcols = c(prefix_col, "new_object_name")] + } else { + dt_obj_nm_auto[, new_object_name := do.call(paste, c(.SD, sep = prefix_sep)), .SDcols = c(prefix_col, "new_object_name")] + } + } + } + + set(dt_obj_nm_auto, NULL, "new_object_name_lower", stri_trans_tolower(dt_obj_nm_auto$new_object_name)) + + # get all names in existing objects + dt_nm <- dt_all[J(unique(dt_obj_nm_auto$class_id)), on = "class_id", nomatch = 0L][ + !J(NA_character_), on = "object_name", by = "class_id", + list(all_name_lower = list(object_name_lower)) + ] + + if (nrow(dt_obj_nm_input)) { + # NOTE: + # (a) When include_ori is FALSE, old object name should be excluded while + # the new names should be included + # (b) Otherwise, both old object names and new names should be + # considered + + # user specified new names and original names + inclu <- dt_obj_nm_input[J(unique(dt_obj_nm_auto$class_id)), on = "class_id", nomatch = 0L, + .SD, .SDcols = c("class_id", "object_name_lower", "new_object_name_lower")] + + if (include_ori) { + dt_nm[inclu, on = "class_id", by = .EACHI, all_name_lower := { + list(list(c(all_name_lower[[1L]], i.new_object_name_lower))) + }] + } else { + dt_nm[inclu, on = "class_id", by = .EACHI, all_name_lower := { + list(list(c(setdiff(all_name_lower[[1L]], i.object_name_lower), i.new_object_name_lower))) + }] + } + } + + add_joined_cols(dt_nm, dt_obj_nm_auto, "class_id", "all_name_lower") + + dt_obj_nm_auto[!J(NA_character_), on = "new_object_name", by = c("class_id", "new_object_name_lower"), + c("new_object_name", "new_object_name_lower") := { + + # check if trying to duplicate same object several times + time <- seq_len(.N) + + # get the duplicated times before + if (is.null(all_name_lower[[1L]])) { + num <- 0L + } else { + num <- apply2_int(all_name_lower, new_object_name_lower, + function (all, new) { + same <- sum(all == new) + num <- stri_match_first_regex(all, paste0("^", new, " (\\d+)$"))[, 2L] + num[is.na(num)] <- "0" + max(as.integer(num)) + same + } + ) + } + + n <- time + num - 1L + if (.N == 1L && n == 0L) { + list(new_object_name, new_object_name_lower) + } else { + suffix <- character(.N) + suffix[n > 0L] <- paste("", n[n > 0L]) + list(paste0(new_object_name, suffix), + paste0(new_object_name_lower, suffix) + ) + } + }] + + set(dt_obj_nm_auto, NULL, "all_name_lower", NULL) + } + + dt <- rbindlist(list(dt_obj_no, dt_obj_nm_input, dt_obj_nm_auto), use.names = TRUE) + setorderv(dt, "rleid") + if (add_hasname) set(dt, NULL, "has_name", NULL) + setcolorder(dt, setdiff(names(dt), c("new_object_name", "new_object_name_lower"))) +} +# }}} # VALUE # get_idf_value {{{ -# Return all object value data in a object +#' Get value data +#' +#' @param idd_env An environment or list contains IDD tables including class, +#' field, and reference. +#' @param idf_env An environment or list contains IDF tables including object, +#' value, and reference. +#' @param class An integer vector of valid class indexes or a character vector +#' of valid class names. Default: `NULL`. +#' @param object An integer vector of valid object IDs or a character vector +#' of valid object names. Default: `NULL`. +#' @param field An integer vector of valid field indexes or a character +#' vector of valid field names (can be in in underscore style). `class` +#' and `field` should have the same length. +#' @param property A character vector of column names in field table to return. +#' @param underscore If `TRUE`, input class name will be converted into +#' underscore style name first and column `class_name_us` will be used +#' for matching. Default: `FALSE`. +#' @param ignore_case If `TRUE`, input object name will be converted into lower +#' case and column `object_name_lower` will be used for matching. +#' converted into underscore style name first and column `class_name_us` +#' and `field_name_us` will be used for matching. Default: `FALSE`. +#' @param align If `TRUE`, all objects in the same class will have the same +#' field number. The number of fields is the same as the object that have +#' the most fields among objects specified. Default: `FALSE`. +#' @param complete If `TRUE`, at least fields till the current whole extensible +#' group will be returned. A new column named "matched_rleid" will be +#' created (when `property` is NULL) indicating if given field has been +#' matched or not. +#' @param all If `TRUE`, all available fields defined in IDD for the class that +#' objects belong to will be returned. Default: `FALSE`. +#' +#' @return A data.table containing specified columns. +#' @keywords internal +#' @export get_idf_value <- function (idd_env, idf_env, class = NULL, object = NULL, field = NULL, property = NULL, underscore = FALSE, ignore_case = FALSE, align = FALSE, complete = FALSE, all = FALSE) { @@ -1229,16 +614,18 @@ get_idf_value <- function (idd_env, idf_env, class = NULL, object = NULL, field } # if field is specified } else { - assert(!is.null(class) || !is.null(object), - msg = "When `field` is not NULL, either `class` or `object` should be not NULL." - ) + if (is.null(class) && is.null(object)) { + abort("When 'field' is specified, either 'class' or 'object' should also be specified", + "missing_class_or_object" + ) + } # as class name already exist in fld set(obj, NULL, "class_name", NULL) # if class or object is a scalar, then this means that field should be # applied to every target object - if (is_scalar(class) || is_scalar(object)) { + if (length(class) == 1L || length(object) == 1L) { obj <- obj[, list(rleid = rep(rleid, length(field)), object_name = rep(object_name, length(field)), @@ -1247,7 +634,11 @@ get_idf_value <- function (idd_env, idf_env, class = NULL, object = NULL, field by = c("class_id", "object_id") ] } else { - assert(have_same_len(class, field) || have_same_len(object, field)) + if (!test_same_len(class, field) && !test_same_len(object, field)) { + abort("'field' should have same length as 'class' or 'object'", + "invalid_field_length" + ) + } obj[, num := field[[.GRP]], by = "rleid"] } } @@ -1271,9 +662,9 @@ get_idf_value <- function (idd_env, idf_env, class = NULL, object = NULL, field set(fld, NULL, "rleid", obj$rleid[fld$rleid]) # remove these columns as them already exist in fld - set(val, NULL, c("rleid", "class_id", "class_name", "object_name"), NULL) + set(val, NULL, c("class_id", "class_name", "object_name"), NULL) - val <- val[fld, on = c("object_id", "field_id")] + val <- val[fld, on = c("rleid", "object_id", "field_id")] } else { # if special treatment is required, use the max field number if (align) { @@ -1296,1847 +687,2583 @@ get_idf_value <- function (idd_env, idf_env, class = NULL, object = NULL, field val } # }}} +# init_idf_value {{{ +#' Initialize value data +#' +#' @param idd_env An environment or list contains IDD tables including class, +#' field, and reference. +#' @param idf_env An environment or list contains IDF tables including object, +#' value, and reference. +#' @param class An integer vector of valid class indexes or a character vector +#' of valid class names. Default: `NULL`. +#' @param object An integer vector of valid object IDs or a character vector +#' of valid object names. Default: `NULL`. +#' @param field An integer vector of valid field indexes or a character +#' vector of valid field names (can be in in underscore style). `class` +#' and `field` should have the same length. +#' @param property A character vector of column names in field table to return. +#' @param underscore If `TRUE`, input class name will be converted into +#' underscore style name first and column `class_name_us` will be used +#' for matching. Default: `FALSE`. +#' @param complete If `TRUE`, at least fields till the current whole extensible +#' group will be returned. A new column named "matched_rleid" will be +#' created (when `property` is NULL) indicating if given field has been +#' matched or not. Default: `FALSE`. +#' @param all If `TRUE`, all available fields defined in IDD for the class that +#' objects belong to will be returned. Default: `FALSE`. +#' @param default If `TRUE`, column `value_chr` and `value_num` will be filled +#' with default values. Default: `TRUE`. +#' @param id If `TRUE`, new value id will be added in column `value_id` based +#' on current existing value ids found in `idf_env`. Default: `TRUE`. +#' +#' @note 'object_id' and 'object_name' are added as all `NA`s. +#' +#' @return A data.table containing specified columns. +#' @keywords internal +#' @export +init_idf_value <- function (idd_env, idf_env, class, field = NULL, property = NULL, + underscore = FALSE, complete = FALSE, all = FALSE, default = TRUE, + id = TRUE) { + prop <- c("type_enum", "units", "ip_units", "default_chr", "default_num") + # get empty object + val <- get_idd_field(idd_env, class, field, underscore = underscore, + complete = complete, all = all, property = unique(c(prop, property))) + + # get default value + set(val, NULL, "defaulted", TRUE) + val <- assign_idf_value_default(idd_env, idf_env, val) + set(val, NULL, "defaulted", NULL) + + # clean + if (!is.null(property)) prop <- setdiff(prop, property) + if (length(prop)) set(val, NULL, prop, NULL) + + id <- if (id) { + if (NROW(idf_env$value)) { + seq_len(nrow(val)) + max(idf_env$value$value_id) + } else { + seq_len(nrow(val)) + } + } else NA_integer_ + set(val, NULL, "value_id", id) -# ASSERT -# FOR BACK COMPATIBILITY -# SHOULD BE REMOVED IN NEXT RELEASE -# assert_valid_input_format {{{ -assert_valid_input_format <- function (class_name, value, comment, default, type = c("add", "set")) { - type <- match.arg(type) - key <- switch(type, add = "class", set = "object") + set(val, NULL, c("object_id", "object_name"), list(NA_integer_, NA_character_)) + + setcolorder(val, c("rleid", "class_id", "class_name", + "object_id", "object_name", + "field_id", "field_index", "field_name", + "value_id", "value_chr", "value_num")) +} +# }}} - is_valid_input <- function (x) is.null(x) || is_normal_list(x) +# DOTS EXPANSION +# expand_idf_dots_name {{{ +#' Parse object ID or name specifications given in list format +#' +#' @param idd_env An environment or list contains IDD tables including class, +#' field, and reference. +#' +#' @param idf_env An environment or list contains IDF tables including object, +#' value, and reference. +#' +#' @param ... Lists of object ID or name pair, e.g. `c(Name1, Name2)`, `c(ID1, +#' ID2)`, `NewName = OldName` and `NewName = ID`. `NewName` is optional. +#' +#' @param .keep_name If `TRUE`, input new names will be kept in a column named +#' `new_object_name`, otherwise they will be dropped. Default: `TRUE`. +#' +#' @param .property A character vector of column names in class table to return. +#' Default: `NULL`. +#' +#' @return A [data.table::data.table()] containing extracted object data. +#' +#' @keywords internal +#' @export +expand_idf_dots_name <- function (idd_env, idf_env, ..., .keep_name = TRUE, .property = NULL) { + l <- list(...) - if (length(class_name) > 1L && - ((!is.null(value) && !have_same_len(class_name, value)) || - (!is.null(comment) && !have_same_len(class_name, comment)))) - stop("`value` and `comment` should have the same length as ", - surround(key), ".", call. = FALSE) + # see https://github.com/mllg/checkmate/issues/146 + # For list, only NULL is treated as "missing" value + assert_list(l, c("character", "integerish"), any.missing = FALSE, all.missing = FALSE, .var.name = "Input") + qassertr(l, "V", "Input") + + is_nm <- vlapply(l, is.character, use.names = FALSE) + rleid <- seq_along(l) + # object name + l_nm <- l[is_nm] + rleid_nm <- rleid[is_nm] + # object ID + l_id <- l[!is_nm] + rleid_id <- rleid[!is_nm] + + if (!length(l_nm)) { + obj_nm <- data.table() + } else { + # in order to keep input order + rleid_nm <- rep(rleid_nm, each_length(l_nm)) - if (is_scalar(class_name)) { - if (!is_valid_input(value) || !is_valid_input(comment)) { - stop("Invalid `value` or `comment` format found. Each value or ", - "comment for a single object should be NULL or a list in format ", - "'list(a = 1, b = 2)' or 'list(1, 2)'.", call. = FALSE) + if (.keep_name) { + l_nm <- unlist(l_nm, FALSE, TRUE) + nm_nm <- names2(l_nm) + } else { + l_nm <- unlist(l_nm, FALSE, FALSE) } + + obj_nm <- get_idf_object(idd_env, idf_env, object = l_nm, ignore_case = TRUE, property = .property) + setnames(obj_nm, "rleid", "object_rleid") + + if (.keep_name) set(obj_nm, NULL, "new_object_name", stri_trim_both(nm_nm)) + } + + if (!length(l_id)) { + obj_id <- data.table() } else { - if (!all(vapply(value, is_valid_input, logical(1))) || - !all(vapply(comment, is_valid_input, logical(1)))) { - stop("Invalid `value` or `comment` format found. Each value or ", - "comment for a single object should be NULL or a list in format ", - "'list(a = 1, b = 2)' or 'list(1, 2)'.", call. = FALSE) + # in order to keep input order + rleid_id <- rep(rleid_id, each_length(l_id)) + + if (.keep_name) { + l_id <- unlist(l_id, FALSE, TRUE) + nm_id <- names2(l_id) + } else { + l_id <- unlist(l_id, FALSE, FALSE) } + storage.mode(l_id) <- "integer" + + obj_id <- get_idf_object(idd_env, idf_env, object = l_id, property = .property) + setnames(obj_id, "rleid", "object_rleid") + + if (.keep_name) set(obj_id, NULL, "new_object_name", stri_trim_both(nm_id)) } + + # remain the input order + obj <- rbindlist(list(obj_id, obj_nm)) + set(obj, NULL, "input_rleid", list(c(rleid_id, rleid_nm))) + setorderv(obj, "input_rleid") + set(obj, NULL, "rleid", rleid(obj$input_rleid, obj$object_rleid)) + set(obj, NULL, c("input_rleid", "object_rleid"), NULL) + setcolorder(obj, "rleid") } # }}} -# assert_can_do {{{ -assert_can_do <- function (idd_env, idf_env, dot, object, - action = c("add", "dup", "set", "del", "rename", "insert")) { - # stop attempting to touch Version {{{ - if (any(object$class_id == 1L)) { - invld <- find_dot(dot, object[class_id == 1L]) - - m <- paste0(dot_string(invld, NULL), " --> Class ", invld$class_name, collapse = "\n") - - abort(paste0("error_", action, "_version"), - paste0( - switch(action, - add = "Adding", - dup = "Duplicating", - set = "Modifying", - del = "Deleting", - rename = "Modifying", - insert = "Inserting"), - " Version object is prohibited. Invalid input:\n", m - ), - dot = dot, object = object - ) - } - # }}} +# parse_dots_value {{{ +#' @inheritParams expand_idf_dots_value +#' @export +parse_dots_value <- function (..., .scalar = TRUE, .pair = FALSE, + .ref_assign = TRUE, .unique = FALSE, + .empty = FALSE, .env = parent.frame()) { + l <- eval(substitute(alist(...))) + rules <- if (.scalar) "V1" else "V" + + assert_list(l, any.missing = FALSE, all.missing = FALSE, .var.name = "Input") + + nm <- name <- names2(l) + ll <- vector("list", length(l)) + + i <- j <- 1L + # if is a variable, directly evaluate it + while (i <= length(l)) { + if (!is.symbol(l[[i]])) { + ll[[j]] <- l[[i]] + nm[[j]] <- name[[i]] + i <- i + 1L + j <- j + 1L + next + } - if (level_checks()$unique_object && action %in% c("add", "dup", "del", "insert")) { - uni <- object[class_id %in% idd_env$class[unique_object == TRUE, class_id]] - if (nrow(uni)) { - # try to add or dup new unique object that already exists {{{ - if (action %in% c("add", "dup", "insert") && any(get_idf_object_num(idd_env, idf_env, uni$class_id) > 0L)) { - invld <- find_dot(dot, uni[get_idf_object_num(idd_env, idf_env, class_id) > 0L]) - # add object id and name - if (action %in% c("add", "insert")) { - invld <- idf_env$object[, list(class_id, object_id, object_name)][ - invld, on = c("class_id")] - } - info <- get_object_info(invld, collapse = NULL, numbered = FALSE) - - m <- paste0(dot_string(invld, NULL), " --> ", info, collapse = "\n") - invld[, paste0(" #", lpad(rleid, "0"), "| ", dot, collapse = "\n")] - - abort(paste0("error_", action, "_unique"), - paste0( - switch(action, - add = "Adding new object in existing unique-object class is prohibited.", - dup = "Existing unique object cannot be duplicated.", - insert = "Inserting new object in existing unique-object class is prohibited." - ), - " Invalid input:\n", m - ), - dot = dot, object = object - ) - } - # }}} - # try to add multi objects in unique classes {{{ - if (action %in% c("add", "insert") && anyDuplicated(uni$class_id)) { - invld <- find_dot(dot, uni[duplicated(class_id)]) + val <- eval(l[[i]], .env) - m <- paste0(dot_string(invld, NULL), " --> Class: ", invld$class_name, collapse = "\n") - act <- switch(action, add = "added", insert = "inserted") + # in case 'x <- quote(cls := list()); parse_dots_value(x)' + if (is.call(val)) { + ll[[j]] <- val + nm[[j]] <- name[[i]] + i <- i + 1L + j <- j + 1L + next + } - abort("error_add_multi_unique", - paste0("Unique object can only be ",act," once. Invalid input\n", m), - dot = dot, object = object - ) + # only one level: + # 'x <- list(Name = "name"); parse_dots_value(obj = x)' + if (qtestr(val, rules, depth = 1L)) { + if (is.na(name[[i]])) { + abort("Assertion on 'Input' failed: Must be named.", "dots_no_name") } - # }}} - # try do del unique object {{{ - if (action == "del" && any(get_idf_object_num(idd_env, idf_env, uni$class_id) == 0L)) { - - invld <- find_dot(dot, uni[get_idf_object_num(idd_env, idf_env, class_id) == 0L]) - - info <- get_object_info(invld, collapse = NULL) - m <- paste0(dot_string(invld, NULL), " --> ", info, collapse = "\n") + ll[[j]] <- val + nm[[j]] <- name[[i]] + i <- i + 1L + j <- j + 1L + # in case 'x <- list(Name = list()); parse_dots_value(x)' + } else { + assert_list(val, "list", .var.name = "Input", names = if (.unique) "unique" else "named") - abort("error_del_exist_unique", - paste0("Existing unique object can not be deleted. Invalid input\n", m), - dot = dot, object = object - ) - } - # }}} + len <- length(val) + ll[j:(j+len-1L)] <- val + nm[j:(j+len-1L)] <- names2(val) + j <- j + len + i <- i + 1L } } - # stop attempting to delete required objects {{{ - if (action == "del" && level_checks()$required_object && - any(object$class_id %in% idd_env$class[required_object == TRUE, class_id])) { - invld <- find_dot(dot, object[class_id %in% idd_env$class[required_object == TRUE, class_id]]) - - info <- get_object_info(invld, numbered = FALSE, collapse = NULL) + dt_in <- data.table( + rleid = seq_along(ll), + id = list(NA_integer_), name = as.list(nm), comment = list(), + field_index = list(NA_integer_), field_name = list(NA_character_), + value_chr = list(NA_character_), value_num = list(NA_real_), + is_empty = FALSE, is_ref = FALSE, lhs_sgl = FALSE, rhs_sgl = TRUE, is_id = FALSE + ) - m <- paste0(dot_string(invld, NULL), " --> ", info, collapse = "\n") + i <- 1L + for (i in dt_in$rleid) { + li <- ll[[i]] + # symbol has already evaluated in previous step + if (!is.call(li)) { + evaluated <- TRUE + # stop if not named + if (is.na(dt_in$name[[i]])) { + abort("Assertion on 'Input' failed: Must be named.", "dots_no_name") + } + val <- li + # if `-`, `{`, `(` and other special function calls, len will be 2 + } else { + evaluated <- FALSE + # 'Name = list()', '..ID = list()' + if (li[[1L]] == "list") { + # stop if not named + if (is.na(nm[[i]])) { + abort("Assertion on 'Input' failed: Must be named.", "dots_no_name") + } - abort("error_del_required", - paste0("Deleting a required object is prohibited. Invalid input:\n", m), - dot = dot, object = object - ) - } - # }}} + # for '..ID = list()' + name <- nm[[i]] + if (stri_detect_regex(name, "^\\.\\.\\d+$")) { + id <- stri_sub(name, 3L) + storage.mode(id) <- "integer" + set(dt_in, i, "id", list(id)) + set(dt_in, i, "name", list(NA_character_)) + # for 'Name = list()' + } else { + set(dt_in, i, "name", list(name)) + } + } else if (li[[1L]] == ":=") { + if (!.ref_assign) abort("Assertion on 'Input' failed: ':=' is not allowed in this context", "dots_ref") + # for 'ClassName := list()' + if (length(li[[2L]]) == 1L) { + set(dt_in, i, "name", list(as.character(li[[2L]]))) + # indicate that LHS is a single name + set(dt_in, i, "lhs_sgl", TRUE) + # for 'c(Obj, Obj) := list()' + } else if (as.character(li[[2L]][[1L]]) %in% c("c", ".")) { + li[[2L]][[1L]] <- as.name("c") + name <- eval(li[[2L]], envir = .env) + name <- assert_valid_type(name, "ID | Name | Index") + if (is.character(name)) { + set(dt_in, i, "name", list(name)) + set(dt_in, i, "id", list(rep(NA_integer_, length(name)))) + } else { + set(dt_in, i, "id", list(name)) + set(dt_in, i, "name", list(rep(NA_character_, length(name)))) + } + } else { + abort("Assertion on 'Input' failed: LHS of ':=' must start with '.()' or 'c()'", "dots_ref_lhs") + } - # stop if modifying same object multiple times {{{ - if (action %in% c("set", "del", "rename") && anyDuplicated(object$object_id)) { - invld <- find_dot(dot, object[duplicated(object_id)]) - info <- get_object_info(invld, numbered = FALSE) - m <- paste0(dot_string(invld, NULL), " --> ", info, collapse = "\n") + li <- li[[3L]] + set(dt_in, i, "is_ref", TRUE) + } + } - abort(paste0("error_", action, "_multi_time"), - paste0("Cannot modify same object multiple times. Invalid input:\n", m), - dot = dot, object = object + if (!evaluated) val <- eval(li, envir = .env) + assert_list(val, c("character", "integer", "double", "null"), .var.name = "Input", + all.missing = .empty ) - } - # }}} - # stop if no new name is provided when renaming {{{ - if (action == "rename" && anyNA(object$new_object_name)) { - invld <- find_dot(dot, object[is.na(new_object_name)]) - m <- paste0(dot_string(invld, NULL), - " --> ", - get_object_info(invld, collapse = NULL, numbered = FALSE), - collapse = "\n" - ) + # check if empty list: 'list()' + if (identical(val, list())) { + set(dt_in, i, "is_empty", TRUE) + next + } - mes <- paste0("Please give new object names. Invalid input:\n", m) - abort(paste0("error_", action, "_no_new_name"), mes, data = invld) - } - # }}} + fld_nm <- names(val) + if (is.null(fld_nm)) { + fld_nm <- character(length(val)) + } else { + assert_character(fld_nm[!stri_isempty(fld_nm)], unique = TRUE, .var.name = "Field Name") + } - # stop if tring to assign names to objects that do not have name attribute {{{ - if (action %chin% c("dup", "rename") && object[has_name == FALSE & !is.na(new_object_name), .N]) { - invld <- find_dot(dot, object[has_name == FALSE & !is.na(new_object_name)]) - m <- paste0(dot_string(invld, NULL), - " --> ", - get_object_info(invld, c("id", "class"), collapse = NULL, numbered = FALSE), - collapse = "\n" - ) + # handle '.comment' + iscmt <- which(fld_nm == ".comment") + if (length(iscmt)) { + set(dt_in, i, "comment", list(val[iscmt])) - mes <- paste0("Target object(s) in class that does not have name attribute ", - "cannot be renamed. Invalid input:\n", m - ) - abort(paste0("error_", action, "_cannot_rename"), mes, data = invld) - } - # }}} + val <- val[-iscmt] + fld_nm <- fld_nm[-iscmt] - TRUE -} -# }}} -# assert_valid {{{ -assert_valid <- function (idd_env, idf_env, object, value, action = c("dup", "add", "set", "rename", "insert")) { - action <- match.arg(action) - if (action %chin% c("dup", "rename")) { - validity <- validate_objects(idd_env, idf_env, - copy(object)[, object_id := -rleid], - # copy needed here to enable object id correction based on object id - copy(value)[, object_id := -rleid], - unique_name = level_checks()$unique_name - ) - } else { - # validate fields that do not use default values and all extensible fields - value <- value[required_field == TRUE | defaulted == FALSE | extensible_group > 0L] - if (action %in% c("add", "insert")) { - validity <- validate_on_level(idd_env, idf_env, - object[J(unique(value$object_id)), on = "object_id"][, object_id := -rleid], - value[, object_id := -rleid], - level = eplusr_option("validate_level") - ) - } else if (action == "set") { - validity <- validate_on_level(idd_env, idf_env, - object[J(unique(value$object_id)), on = "object_id"], - value, - level = eplusr_option("validate_level") - ) + # check if .comment only + if (identical(unname(val), list())) { + set(dt_in, i, "is_empty", TRUE) + next + } } - } - if (count_check_error(validity)) { - on.exit(options(warning.length = getOption("warning.length")), add = TRUE) - options(warning.length = 8170) - m <- paste0(capture.output(print_validity(validity)), collapse = "\n") - if (action == "dup") { - t <- paste0( - "Failed to duplicate object(s). ", - "Input new name(s) cannot be the same as target object(s) or ", - "any existing object in the same class." - ) - } else { - t <- paste0("Failed to ",action," object(s).") - } - abort("error_validity", paste0(t, "\n\n", m)) - } + fld_idx <- rep(NA_integer_, length(fld_nm)) - TRUE -} -# }}} + # check if ".." notation + isidx <- stri_detect_regex(fld_nm, "^\\.\\.\\d+$") + fld_idx[isidx] <- {id <- stri_sub(fld_nm[isidx], 3L);storage.mode(id) <- "integer";id} + fld_nm[stri_isempty(fld_nm)] <- NA_character_ + fld_nm[isidx] <- NA_character_ -# OBJECT MUNIPULATION -# dup_idf_object {{{ -dup_idf_object <- function (idd_env, idf_env, ...) { - l <- sep_name_dots(..., .can_name = TRUE) - obj <- get_object_input(idd_env, idf_env, l, property = "has_name", keep_duplicate = TRUE) + set(dt_in, i, "field_name", list(fld_nm)) + set(dt_in, i, "field_index", list(fld_idx)) - # stop if cannot add objects in specified classes - assert_can_do(idd_env, idf_env, l$dot, obj, "dup") + # check if NULL + isnull <- vlapply(val, is.null) - # make sure rleid column as the unique id - set(obj, NULL, "rleid", rleid(obj$rleid, obj$object_rleid)) - set(obj, NULL, "object_rleid", NULL) + # make sure no NA and scalar if necessary + qassertr(val[!isnull], rules, .var.name = "Field Value") - # check input new names {{{ - # get value data - val <- get_idf_value(idd_env, idf_env, object = obj$object_id, - property = c("is_name", "type_enum", "src_enum") - ) - set(val, NULL, "rleid", obj[val$rleid, rleid]) - - # NOTE: - # (a) restore old value id for updating reference - # (b) Assign new value id in order to correctly print validate message - setnames(val, "value_id", "old_value_id") - set(val, NULL, "value_id", new_id(idf_env$value, "value_id", nrow(val))) - - # NOTE: - # (a) Store old id and name for logging - # (b) Change object names for validation - setnames(obj, c("object_id", "object_name", "object_name_lower"), - c("old_object_id", "old_object_name", "old_object_name_lower") - ) - set(obj, NULL, c("object_name", "object_name_lower"), - list(obj$new_object_name, stri_trans_tolower(obj$new_object_name))) + # separate character and numeric value + if (.scalar) { + val[isnull] <- list(NA_character_) + isnum <- vlapply(val, is.numeric) - # assign name field in order to make sure new object name is used during - # error printing - val[is_name == TRUE, `:=`(value_chr = obj[has_name == TRUE, object_name])] + val_chr <- stri_trim_both(unlist(val, FALSE, FALSE)) + val_chr[stri_isempty(val_chr)] <- NA_character_ + val_num <- rep(NA_real_, length(val_chr)) + val_num[isnum] <- unlist(val[isnum], FALSE, FALSE) - assert_valid(idd_env, idf_env, obj, val, "dup") - # }}} + set(dt_in, i, "value_chr", val_chr) + set(dt_in, i, "value_num", val_num) - # assign new object id after validation - obj <- assign_new_id(idf_env, obj, "object") - set(val, NULL, "object_id", obj[J(val$rleid), on = "rleid", object_id]) - - # get new object name {{{ - # get indicator of whether user input new names are used - set(obj, NULL, "use_input_name", FALSE) - obj[has_name == TRUE & !is.na(object_name_lower) & - (object_name_lower != old_object_name_lower | is.na(old_object_name_lower)), - `:=`(use_input_name = TRUE) - ] + } else if (!.pair) { + val[isnull] <- list(NA_character_) + isnum <- vlapply(val, is.numeric) - # get all name in the same class - obj[, `:=`(all_name_lower = get_idf_object_name(idd_env, idf_env, class_id, lower = TRUE)), by = "rleid"] - - # check if trying to duplicate same object several times - set(obj, NULL, "dup_time", 0L) - obj[use_input_name == FALSE, `:=`(dup_time = seq_along(object_id)), - by = list(class_id, old_object_name_lower)] - - # get the duplicated times before - obj[!is.na(old_object_name), `:=`( - max_suffix_num = apply2_int(all_name_lower, old_object_name_lower, - function (x, y) { - num <- stri_match_first_regex(x, paste0("^", y, "_(\\d+)$"))[,2L] - num[is.na(num)] <- "0" - max(as.integer(num)) + len <- each_length(val) + + # indicate if vector value input + if (any(len > 1L)) set(dt_in, i, "rhs_sgl", FALSE) + + val_chr <- lapply(val, function (x) {x <- stri_trim_both(x); x[stri_isempty(x)] <- NA_character_;x}) + val_num <- lapply(len, function (n) rep(NA_real_, n)) + val_num[isnum] <- lapply(val[isnum], as.double) + + set(dt_in, i, "value_chr", list(list(val_chr))) + set(dt_in, i, "value_num", list(list(val_num))) + + # make sure id/name are paired with field values + } else { + len_obj <- length(.subset2(dt_in$name, i)) + len_val <- each_length(val) + len <- max(len_obj, len_val) + + # indicate if vector value input + if (any(len_val > 1L)) set(dt_in, i, "rhs_sgl", FALSE) + + # check the length of objects + if (len_obj != len) { + if (len_obj != 1L) { + abort(paste0("Assertion on 'Field Value' failed, element ", + i, " at position ", which(len_val > 1L & len_obj != len)[[1L]], ": ", + "Length of field value {", len_val[len_val > 1L & len_obj != len_val][[1L]], "} ", + "must be the same as the ", "length of ID/Name {", len_obj, "}."), + "dots_pair_length" + ) + # 'Object = list(Fld = c(Val1, Val2))' + } else if (!.subset2(dt_in$is_ref, i)) { + abort(paste0("Assertion on 'Field Value' failed, element ", + i, " at position ", which(len_val > 1L)[[1L]], ". ", + "Must be of length == 1, but has length ", len_val[len_val > 1L][[1L]], "."), + "dots_pair_length" + ) + } + set(dt_in, i, "id", list(rep(dt_in$id[[i]], len))) + set(dt_in, i, "name", list(rep(dt_in$name[[i]], len))) } - ) - )] - # assign new object name - set(obj, NULL, "auto_assigned", FALSE) - obj[!is.na(old_object_name) & use_input_name == FALSE, - `:=`(object_name = paste0(old_object_name, "_", max_suffix_num + dup_time), - auto_assigned = TRUE - ) - ] - set(obj, NULL, "object_name_lower", stri_trans_tolower(obj$object_name)) - val[is_name == TRUE, `:=`(value_chr = obj[has_name == TRUE, object_name])] + # check the length of values + val_lst <- apply2(val, len_val, function (v, l) { + if (is.null(v)) { + chr <- rep(NA_character_, len) + num <- rep(NA_real_, len) + } else if (l == 1L) { + if (is.character(v)) { + chr <- rep(v, len) + num <- rep(NA_real_, len) + } else { + chr <- rep(as.character(v), len) + num <- rep(as.double(v), len) + } + } else if (l == len) { + if (is.character(v)) { + chr <- v + num <- rep(NA_real_, len) + } else { + chr <- as.character(v) + num <- as.double(v) + } + } else { + abort(paste0("Assertion on 'Field Value' failed, element ", + i, " at position ", which(len_val == l)[1L], ": ", + "Length of field value {", l, "} ", + "must be the same as the ", "length of ID/Name {", len, "}."), + "dots_pair_length" + ) + } + list(chr = chr, num = num) + }) - # logging - if (nrow(obj[auto_assigned == TRUE])) { - auto <- obj[auto_assigned == TRUE] - id <- get_object_info(auto, "id") - name <- get_object_info(auto, "name", prefix = " --> New ", numbered = FALSE) - verbose_info( - "New names of duplicated objects not given are automatically generated:\n", - paste0(id, name, collapse = "\n") - ) + # only one field + if (length(len_val) == 1L) { + set(dt_in, i, "value_chr", list(list(as.list(val_lst[[1L]]$chr)))) + set(dt_in, i, "value_num", list(list(as.list(val_lst[[1L]]$num)))) + } else { + set(dt_in, i, "value_chr", list(list(transpose(lapply(val_lst, .subset2, "chr"))))) + set(dt_in, i, "value_num", list(list(transpose(lapply(val_lst, .subset2, "num"))))) + } + } } - # }}} - # value reference - ## directly copy old field references excepting the name field - ref <- idf_env$reference[J(val$old_value_id[!val$is_name]), on = "value_id", nomatch = 0L] - set(ref, NULL, c("object_id", "value_id"), - val[match(ref$value_id, val$old_value_id), .SD, .SDcols = c("object_id", "value_id")]) - ## for original objects whose fields are referred by others, just keep the - ## original relation and no new relation needs to be created as one value - ## can only refer to one other value - ## however, it is possible that new input object names can be referred by - ## other existing objects - src <- get_value_reference_map(idd_env$reference, - append_dt(idf_env$value, val), val[is_name == TRUE] - ) - new_ref <- rbindlist(list(ref, src)) + # make sure id/name is unique + if (.unique) { + id <- viapply(dt_in$id, .subset2, 1L) + assert_integer(id[!is.na(id)], unique = TRUE, .var.name = "Input ID") + + nm <- vcapply(dt_in$name, .subset2, 1L) + assert_character(nm[!is.na(nm)], unique = TRUE, .var.name = "Input Name") + } + + len_obj <- each_length(dt_in$id) + len_fld <- each_length(dt_in$field_index) + rep_each <- function (x, len) rep(x, each = len) + + obj <- dt_in[, list( + rleid = rep(rleid, len_obj), + each_rleid = unlist(lapply(len_obj, seq_len), FALSE, FALSE), + id = unlist(id, FALSE, FALSE), + name = unlist(name, FALSE, FALSE), + comment = rep(comment, len_obj), + is_ref = rep(is_ref, len_obj), + lhs_sgl = rep(lhs_sgl, len_obj), + rhs_sgl = rep(rhs_sgl, len_obj), + is_empty = rep(is_empty, len_obj) + )] + + each_rleid <- unlist(apply2(len_obj, len_fld, function (lo, lf) rep_each(seq_len(lo), lf)), FALSE, FALSE) + if (.scalar) { + val <- dt_in[, list( + rleid = unlist(rep(rleid, len_obj * len_fld), FALSE, FALSE), + each_rleid = each_rleid, + id = unlist(apply2(id, len_fld, rep_each), FALSE, FALSE), + name = unlist(apply2(name, len_fld, rep_each), FALSE, FALSE), + field_index = unlist(rep(field_index, len_obj), FALSE, FALSE), + field_name = unlist(rep(field_name, len_obj), FALSE, FALSE), + value_chr = unlist(rep(value_chr, len_obj), FALSE, FALSE), + value_num = unlist(rep(value_num, len_obj), FALSE, FALSE) + )] + } else if (!.pair) { + # Should treat one-row input specially. Otherwise, vector field value input + # will be unlisted + if (length(len_fld) == 1L && len_fld == 1L) { + val <- dt_in[, list( + rleid = unlist(rep(rleid, len_obj * len_fld), FALSE, FALSE), + each_rleid = each_rleid, + id = unlist(apply2(id, len_fld, rep_each), FALSE, FALSE), + name = unlist(apply2(name, len_fld, rep_each), FALSE, FALSE), + field_index = unlist(rep(field_index, len_obj), FALSE, FALSE), + field_name = unlist(rep(field_name, len_obj), FALSE, FALSE), + value_chr = rep(unlist(value_chr, FALSE, FALSE), len_obj), + value_num = rep(unlist(value_num, FALSE, FALSE), len_obj) + )] + } else { + val <- dt_in[, list( + rleid = unlist(rep(rleid, len_obj * len_fld), FALSE, FALSE), + each_rleid = each_rleid, + id = unlist(apply2(id, len_fld, rep_each), FALSE, FALSE), + name = unlist(apply2(name, len_fld, rep_each), FALSE, FALSE), + field_index = unlist(rep(field_index, len_obj), FALSE, FALSE), + field_name = unlist(rep(field_name, len_obj), FALSE, FALSE), + value_chr = unlist(rep(value_chr, len_obj), FALSE, FALSE), + value_num = unlist(rep(value_num, len_obj), FALSE, FALSE) + )] + } + } else { + val <- dt_in[, list( + rleid = unlist(rep(rleid, len_obj * len_fld), FALSE, FALSE), + each_rleid = each_rleid, + id = unlist(apply2(id, len_fld, rep_each), FALSE, FALSE), + name = unlist(apply2(name, len_fld, rep_each), FALSE, FALSE), + field_index = unlist(rep(field_index, len_obj), FALSE, FALSE), + field_name = unlist(rep(field_name, len_obj), FALSE, FALSE), + value_chr = unlist(value_chr, TRUE, FALSE), + value_num = unlist(value_num, TRUE, FALSE) + )] + } - list(object = del_unuseful_cols(idf_env$object, obj), - value = del_unuseful_cols(idf_env$value, val), - reference = append_dt(idf_env$reference, new_ref) - ) + list(object = obj, value = val) } # }}} -# add_idf_object {{{ -add_idf_object <- function (idd_env, idf_env, ..., .default = TRUE, .all = FALSE, .env = parent.frame()) { - # .null in sep_value_dots controls whether list(field = NULL) is acceptable - l <- sep_value_dots(..., .empty = TRUE, .null = TRUE, .env = .env) +# expand_idf_dots_value {{{ +#' Parse object field values given in list format +#' +#' @param idd_env An environment or list contains IDD tables including class, +#' field, and reference. +#' +#' @param idf_env An environment or list contains IDF tables including object, +#' value, and reference. +#' +#' @param ... Lists of object definitions. Each list should be named +#' with a valid class/object id/name. ID should be denoted in style +#' `..ID`. There is a special element `.comment` in each list, which will +#' be used as new comments of the object. If `.ref_assign` is `TRUE`, +#' `:=` can be used to group multiple id/name wrapped by `.()` or `c()`. +#' +#' @param .type Should be either `"class"` or `"object"`. If `"class"`, +#' id/name of each input will be treated as class index/name. If `"object"`, +#' id/name of each input will be treated as object id/name. +#' +#' @param .complete If `TRUE`, make sure the returned field number meets the +#' `\min-fields` requirement. Default: `TRUE` +#' +#' @param .all If `TRUE`, make sure the all possible fields are returned. +#' Default: `FALSE`. +#' +#' @param .scalar If `TRUE`, make sure the value of each field in the object is a +#' scalar value. If `FALSE`, `value_chr` and `value_num` column will be +#' list type. Default: `TRUE`. +#' +#' @param .pair Only works when `.scalar` is `FALSE`. If `.pair` is `TRUE`, +#' vector field values will be paired to each id/name on the LHS. In this +#' case, `value_chr` and `value_num` will be character type and double +#' type, respectively. When there is only one id/name on the LHS, it will +#' be replicated to match the length of the value vector. Default: `FALSE`. +#' +#' @param .ref_assign If `TRUE`, allow using `:=` to gather multiple +#' classes/objects on the LHS when defining the objects. Default: `TRUE`. +#' +#' @param .unique If `TRUE`, make sure there are no duplicated classes/objects in +#' the input. Default: `FALSE`. +#' +#' @param .empty If `TRUE`, allow using an empty list, i.e. `list()` to define an +#' object with all default values. Default: `TRUE`. +#' +#' @param .default If `TRUE`, all empty fields will be filled with default +#' values if possible. Default: `TRUE`. +#' +#' @param .env An environment specifying the environment to evaluate the `...`. +#' Default: [parent.frame()]. +#' +#' @return A named list of 2 element `object` and `value` which is a +#' [data.table::data.table()] with object data and value data respectively. +#' +#' @keywords internal +#' @export +expand_idf_dots_value <- function (idd_env, idf_env, ..., + .type = "class", .complete = TRUE, .all = FALSE, + .scalar = TRUE, .pair = FALSE, .ref_assign = TRUE, + .unique = TRUE, .empty = TRUE, .default = TRUE, + .env = parent.frame()) { + l <- parse_dots_value(..., + .scalar = .scalar, .pair = .pair, .ref_assign = .ref_assign, + .unique = .unique, .empty = .empty, .env = .env) + + .type <- match.arg(.type, c("class", "object")) + # indicate if single field value + .sgl <- .scalar || (!.scalar && .pair) + + obj <- l$object + val <- l$value + + # add new objects in specified classes {{{ + if (.type == "class") { + # update rleid + set(obj, NULL, "rleid", rleid(obj$rleid, obj$each_rleid)) + set(val, NULL, "rleid", rleid(val$rleid, val$each_rleid)) + set(obj, NULL, "each_rleid", NULL) + set(val, NULL, "each_rleid", NULL) + + setnames(obj, c("id", "name"), c("class_id", "class_name")) + setnames(val, c("id", "name"), c("class_id", "class_name")) + + # verify class index and name + if (!length(i <- which(!is.na(obj$class_name)))) { + add_class_name(idd_env, obj) + check_bad_key(obj, "class_name", "class_id") + } else { + set(obj, i, c("class_id", "class_name"), + fast_subset(get_idd_class(idd_env, obj$class_name[i], underscore = TRUE), + c("class_id", "class_name") + ) + ) - # stop if `:=` - if (any(l$dot$class)) { - abort("error_invalid_add_class", "`:=` can only be used when setting objects not adding.") - } + i <- setdiff(seq_len(nrow(obj)), i) - # new object table - obj <- get_idd_class(idd_env, setnames(l$object, "name", "class_name")$class_name, underscore = TRUE) - set(obj, NULL, c("rleid", "object_rleid", "comment", "empty"), - l$object[obj$rleid, .SD, .SDcols = c("rleid", "object_rleid", "comment", "empty")] - ) + set(obj, i, "class_name", + get_idd_class(idd_env, obj$class_id[i], underscore = TRUE)$class_name + ) + } - # stop if cannot add objects in specified classes - assert_can_do(idd_env, idf_env, l$dot, obj, "add") + # if unique, should compare after class name has been matched + if (.unique && anyDuplicated(obj$class_id)) { + abort(paste0("Assertion on 'Input' failed: Must have unique class names, but element ", + which(duplicated(obj$class_id))[[1L]], " {", obj$class_name[duplicated(obj$class_id)][[1L]], + "} is duplicated."), + "dots_dup_name" + ) + } - # add object id - obj <- assign_new_id(idf_env, obj, "object") + add_joined_cols(obj, val, "rleid", c("class_id", "class_name")) - # make sure rleid column as the unique id - set(obj, NULL, "new_rleid", rleid(obj$rleid, obj$object_rleid)) + # handle empty objects + if (!.empty) { + val_emp <- data.table() + } else if (!length(i <- which(obj$is_empty))){ + val_emp <- data.table() + } else { + val_emp <- init_idf_value(idd_env, idf_env, obj$class_name[i], + underscore = TRUE, complete = .complete, all = .all, default = .default, + id = FALSE + ) + # keep original rleid + add_joined_cols(data.table(rleid = i, object_rleid = seq_along(i)), + val_emp, c(rleid = "object_rleid"), "rleid" + ) + val <- val[!J(i), on = "rleid"] + } - # new value table - val <- l$value[obj[, -c("empty", "comment", "group_id")], - on = c("rleid", "object_rleid"), nomatch = 0L - ] + if (nrow(val)) { + val <- match_idd_field(idd_env, val) - # clean old rleid - set(obj, NULL, c("rleid", "object_rleid"), NULL) - set(val, NULL, c("rleid", "object_rleid"), NULL) - setnames(obj, "new_rleid", "rleid") - setnames(val, "new_rleid", "rleid") + # complete fields if necessary {{{ + if (.all || .complete) { + # get maximum field index per object + fld_in <- val[, list(class_id = class_id[[1L]], num = max(field_index)), by = "rleid"] - prop <- c("units", "ip_units", "default_chr", "default_num", "is_name", - "required_field", "src_enum", "type_enum", "extensible_group" - ) + # get all necessary fields + fld_out <- get_idd_field(idd_env, class = fld_in$class_id, field = fld_in$num, + all = .all, complete = TRUE + ) + set(fld_out, NULL, "field_in", NULL) - # get empty objects {{{ - val_empty <- obj[J(TRUE), on = "empty", nomatch = 0L] - if (!nrow(val_empty)) { - val_empty <- data.table() - } else { - set(val_empty, NULL, c("empty", "comment", "group_id"), NULL) - val_empty_fld <- get_idd_field(idd_env, val_empty$class_id, all = .all, underscore = FALSE, property = prop) - # insert rleid and object id back - val_empty <- val_empty_fld[val_empty[, object_rleid := .I], on = c("rleid" = "object_rleid"), - `:=`(object_id = i.object_id, rleid = i.rleid) - ] + # add a temp rleid for matching field data + add_rleid(fld_in, "object") - # add input field index indicator - set(val_empty, NULL, "field_in", NA_integer_) + # restore the original rleid + add_joined_cols(fld_in, fld_out, c("rleid" = "object_rleid"), "rleid") - # add value and value in number - set(val_empty, NULL, c("value_chr", "value_num"), list(NA_character_, NA_real_)) + # match + val <- fld_out[val, on = c("rleid", "field_index"), `:=`( + value_chr = i.value_chr, value_num = i.value_num + )] + } + # }}} - # find fields to be filled with default values - set(val_empty, NULL, "defaulted", TRUE) - } - # }}} + # assign default value if necessary + # only possible for scalar field value + if (.default && .sgl) { + val <- assign_idf_value_default(idd_env, idf_env, val) + } - # get non-empty objects {{{ - if (!nrow(val)) { - val <- val_empty[0L] - } else { - if (any(is.na(val$field_name))) { - val <- fill_unnamed_field_index(idd_env, idf_env, val) - # all named - } else { - # just to verify field names - fld_out <- get_idd_field(idd_env, class = val$class_id, field = val$field_name) - # set matched field index - set(val, NULL, "field_index", fld_out$field_index) - # remove input field name - if (has_name(val, "field_in")) set(val, NULL, "field_in", NULL) + # complete id column + set(val, NULL, c("object_id", "object_name", "value_id"), list(NA_integer_, NA_character_, NA_integer_)) } - # now all field indices have been detected - fld_in <- val[, list(class_id = class_id[[1L]], num = max(field_index)), by = c("rleid", "object_id")] - fld_out <- get_idd_field(idd_env, class = fld_in$class_id, field = fld_in$num, - all = .all, complete = TRUE, property = prop - ) - # reset rleid in fld_out - set(fld_out, NULL, c("rleid", "object_id"), fld_in[fld_out$rleid, list(rleid, object_id)]) + # combine + if (nrow(val_emp)) { + if (nrow(val)) { + val <- rbindlist(list(val, val_emp), use.names = TRUE) + # keep input order + setorderv(val, "rleid") + } else { + val <- val_emp + } + } - # remove duplicated columns - set(val, NULL, c("class_id", "class_name"), NULL) - val <- val[fld_out, on = c("rleid", "object_id", "field_index")] + # complete object table + set(obj, NULL, c("is_ref", "lhs_sgl", "rhs_sgl", "is_empty"), NULL) + set(obj, NULL, c("object_id", "object_name", "object_name_lower"), list(NA_integer_, NA_character_, NA_character_)) - if (.default) val[is.na(defaulted), defaulted := TRUE] - } + # keep column order + setcolorder(obj, c("rleid", "class_id", "class_name", "object_id", "object_name", "object_name_lower", "comment")) + setcolorder(val, c("rleid", "class_id", "class_name", "object_id", "object_name", + "field_id", "field_index", "field_name", "value_id", "value_chr", "value_num")) # }}} + # modify existing objects {{{ + } else if (.type == "object") { + # separate class input namd object input + # for class input {{{ + if (!(.ref_assign && any(obj$lhs_sgl))) { + cls_obj <- data.table() + cls_val <- data.table() + obj_val <- val + } else { + # separate class input and object input + cls <- .Call(data.table:::CsubsetDT, obj, which(obj$lhs_sgl), seq_along(obj)) + obj <- .Call(data.table:::CsubsetDT, obj, which(!obj$lhs_sgl), seq_along(obj)) + + # match class name + cls_in <- cls[, list(class_name = name[[1L]], is_empty = is_empty[[1L]], rhs_sgl = rhs_sgl[[1L]], num = .N), by = "rleid"] + add_rleid(cls_in, "class") + cls_obj <- get_idf_object(idd_env, idf_env, cls_in$class_name, underscore = TRUE) + add_joined_cols(cls_in, cls_obj, c("rleid" = "class_rleid"), "rleid") + set(cls_obj, NULL, "class_name_us", NULL) + + # update class id and class name + add_joined_cols( + cls_obj[, list(class_id = class_id[[1L]], class_name = class_name[[1L]], num = .N), by = "rleid"], + cls_in, + "rleid", + c("class_id" = "class_id", "class_name" = "class_name", "obj_num" = "num") + ) - # combine empty and non-empty objects - val <- rbindlist(list(val_empty, val), use.names = TRUE) - - # order - setorderv(val, c("rleid", "field_index")) - - # assign default values if needed - if (.default) val <- assign_default_value(idd_env, idf_env, val) - set(val, NULL, c("default_chr", "default_num"), NULL) - - # assign new value id - val <- assign_new_id(idf_env, val, "value") - - # update object name - obj <- update_object_name(obj, val) - set(val, NULL, "is_name", NULL) - # add lower name - set(obj, NULL, "object_name_lower", stri_trans_tolower(obj$object_name)) + # when paired, if multiple field values, the length of field value + # vector should be the same as number of objects in that class + if (!.scalar && .pair && nrow(invld <- cls_in[num > 1L & num != obj_num])) { + abort(paste0("Assertion on 'Field Value' failed on element ", + invld$rleid[[1L]], ". When LHS of ':=' is a class name, ", + "the length of each field value vector {", invld$num[[1L]], + "} must be the same as number of objects in that class {", invld$obj_num[[1L]], "}. "), + "dots_pair_length" + ) + } - # validate - assert_valid(idd_env, idf_env, obj, val, action = "add") + # separate class value input and object value input + cls_val <- .Call(data.table:::CsubsetDT, val, which(val$rleid %in% cls_in$rleid), seq_along(val)) + obj_val <- .Call(data.table:::CsubsetDT, val, which(!val$rleid %in% cls_in$rleid), seq_along(val)) + + # extract values for empty input + # empty here means to extract all objects in that class + if (!.empty) { + cls_obj_emp <- data.table() + cls_val_emp <- data.table() + } else if (!any(cls_in$is_empty)) { + cls_obj_emp <- data.table() + cls_val_emp <- data.table() + } else { + cls_obj_emp <- .Call(data.table:::CsubsetDT, cls_obj, which(cls_obj$rleid %in% cls_in$rleid[cls_in$is_empty]), seq_along(cls_obj)) + cls_obj <- .Call(data.table:::CsubsetDT, cls_obj, which(!cls_obj$rleid %in% cls_in$rleid[cls_in$is_empty]), seq_along(cls_obj)) - list(object = obj[, .SD, .SDcols = names(idf_env$object)], - value = val[, .SD, .SDcols = names(idf_env$value)], - reference = update_value_reference(idd_env, idf_env, obj, val) - ) -} -# }}} -# set_idf_object {{{ -set_idf_object <- function (idd_env, idf_env, ..., .default = TRUE, .empty = FALSE, .env = parent.frame()) { - # .null in sep_value_dots controls whether list(field = NULL) is acceptable - l <- sep_value_dots(..., .empty = .empty, .null = TRUE, .env = .env) - - obj_val <- match_set_idf_data(idd_env, idf_env, l) - obj <- obj_val$object - val <- obj_val$value - - # incase only want to reset object comments - if (nrow(obj) && !nrow(val)) { - return( - list(object = obj[, .SD, .SDcols = names(idf_env$object)], - value = data.table(), - reference = idf_env$reference - ) - ) - } + cls_val_emp <- get_idf_value(idd_env, idf_env, cls_in$class_id[cls_in$is_empty], + complete = .complete, all = .all + ) + set(cls_val_emp, NULL, "rleid", rep(cls_in$rleid[cls_in$is_empty], table(cls_val_emp$rleid))) - # in order to delete field values, here get all value numbers in current class - fld_in <- val[, list(num = max(field_index)), by = c("rleid", "object_id")] - fld_cur <- idf_env$value[J(fld_in$object_id), on = "object_id", - list(object_id = object_id[[1L]], num = .N), by = "object_id" - ] - # get the max field number - fld_in$num <- pmax(fld_in$num, fld_cur$num) + # assign default value if necessary + if (.sgl) { + if (.default) { + cls_val_emp <- assign_idf_value_default(idd_env, idf_env, cls_val_emp) + } + } else { + set(cls_val_emp, NULL, c("value_chr", "value_num"), + list(as.list(cls_val_emp$value_chr), as.list(cls_val_emp$value_num)) + ) + } - prop <- c("units", "ip_units", "default_chr", "default_num", "is_name", - "required_field", "src_enum", "type_enum", "extensible_group" - ) + # exclude empty value input + cls_val <- .Call(data.table:::CsubsetDT, cls_val, which(!cls_val$rleid %in% cls_in$rleid[cls_in$is_empty]), seq_along(cls_val)) + } - val_out <- get_idf_value(idd_env, idf_env, object = fld_in$object_id, field = fld_in$num, - complete = TRUE, property = prop - ) - # reset rleid in val_out - set(val_out, NULL, c("rleid"), unique(val$rleid)[val_out$rleid]) - set(val_out, NULL, c("new_value", "new_value_num", "defaulted"), - val[val_out, on = c("rleid", "field_index"), - .SD, .SDcols = c("new_value", "new_value_num", "defaulted") - ] - ) - val <- val_out + if (!nrow(cls_val)) { + cls_obj <- data.table() + cls_val <- data.table() + } else { + # update id and name column + add_joined_cols(cls_in, cls_val, "rleid", c("class_id", "class_name")) + + # extract field input by class + cls_fld_in <- unique(fast_subset(cls_val, c("rleid", "class_id", "field_index", "field_name")), + by = c("rleid", "field_index", "field_name")) + # store input before matching + set(cls_fld_in, NULL, c("field_index_in", "field_name_in"), list(cls_fld_in$field_index, cls_fld_in$field_name)) + # match field id + cls_fld_in <- match_idd_field(idd_env, cls_fld_in) + + # if no duplicated fields, unique will just return the + # the original data.table + # in this case, cls_val is modified when matching + if (nrow(cls_fld_in) == nrow(cls_val)) { + set(cls_val, NULL, c("field_id", "field_index", "field_name"), fast_subset(cls_fld_in, c("field_id", "field_index", "field_name"))) + # match field in the original value input + } else { + cls_val[cls_fld_in, on = c("rleid", "field_index" = "field_index_in", "field_name" = "field_name_in"), + `:=`(field_index = i.field_index, field_name = i.field_name, field_id = i.field_id)] + } - if (.default) val[is.na(value_chr) & is.na(defaulted), defaulted := TRUE] - val[is.na(defaulted), defaulted := FALSE] + # assign default value if necessary + if (.default && .sgl) { + cls_val <- assign_idf_value_default(idd_env, idf_env, cls_val) + } - # exclude name field if it has been already set before in order to - # prevent name conflict checking error - val[is_name == TRUE & !is.na(value_chr) & is.na(new_value), - `:=`(required_field = FALSE) - ] + # add object number + add_joined_cols(cls_in, cls_val, "rleid", "obj_num") - # order - setorderv(val, c("rleid", "field_index")) + # get object id + obj_id <- unlist(apply2( + split(cls_obj$object_id, cls_obj$rleid), + cls_val[, by = "rleid", data.table::uniqueN(field_id)]$V1, rep + ), FALSE, FALSE) - # assign default values if needed - if (.default) { - val <- assign_default_value(idd_env, idf_env, val) - } else { - # remove - val[defaulted == TRUE, `:=`(value_chr = NA_character_, value_num = NA_real_)] - } - set(val, NULL, c("default_chr", "default_num"), NULL) + add_joined_cols(cls_in, cls_val, "rleid", "rhs_sgl") - # assign new values - val[!is.na(new_value), `:=`(value_chr = new_value, value_num = new_value_num)] - set(val, NULL, c("new_value", "new_value_num"), NULL) + # each field should be replicated by object number + if (!.sgl) { + cls_val <- cls_val[, lapply(.SD, function (x) rep(x, obj_num)), + .SDcols = -c("obj_num", "rhs_sgl"), by = "rleid"] + } else { + cls_val <- rbindlist(list( + # if Class := list(Fld1 = Val1, Fld2 = Val2), each field should + # be replicated by object number + cls_val[J(TRUE), on = "rhs_sgl", nomatch = 0L, lapply(.SD, function (x) rep(x, obj_num)), + .SDcols = -c("obj_num", "rhs_sgl"), by = "rleid"], + + # if Class := list(Fld1 = c(Val1, Val2, Val3, ...)), no + # replication is needed + cls_val[J(FALSE), on = "rhs_sgl", nomatch = 0L, .SD, .SDcols = -c("obj_num", "rhs_sgl")] + )) + } - # assign new value id - val[value_id < 0L, value_id := new_id(idf_env$value, "value_id", .N)] + setnames(cls_val, "id", "object_id") + setorderv(cls_val, c("rleid", "field_id")) + set(cls_val, NULL, "object_id", obj_id) - # update object name - obj <- update_object_name(obj, val) - set(val, NULL, "is_name", NULL) - # add lower name - set(obj, NULL, "object_name_lower", stri_trans_tolower(obj$object_name)) + # complete fields if necessary + if (.all || .complete) { + fld_in <- cls_fld_in[, by = "rleid", list(class_id = class_id[[1L]], field_index = max(field_index))] + cls_val_out <- get_idf_value(idd_env, idf_env, + class = fld_in$class_id, field = fld_in$field_index, + complete = .complete, all = .all + ) + # add a temp rleid for matching field data + add_rleid(fld_in, "field") - # delete fields - add_joined_cols(idd_env$class, val, "class_id", c("min_fields", "num_extensible")) - if (!.empty) val <- remove_empty_fields(val) + # restore the original rleid + add_joined_cols(fld_in, cls_val_out, c("rleid" = "field_rleid"), "rleid") - # validate - assert_valid(idd_env, idf_env, obj, val, action = "set") + # make the original value as a list if necessary + if (!.sgl) { + set(cls_val_out, NULL, c("value_chr", "value_num"), + list(as.list(cls_val_out$value_chr), as.list(cls_val_out$value_num)) + ) + } - list(object = obj[, .SD, .SDcols = names(idf_env$object)], - value = val[, .SD, .SDcols = names(idf_env$value)], - reference = update_value_reference(idd_env, idf_env, obj, val) - ) -} -# }}} -# match_set_idf_data {{{ -match_set_idf_data <- function (idd_env, idf_env, l) { - # get object ID in `..X` format - setnames(l$object, c("name", "comment"), c("object_name", "new_comment")) - set(l$object, NULL, "object_id", as.integer(stri_match_first_regex(l$object$object_name, "^\\.\\.(\\d+)$")[, 2L])) - - # separate - obj_id_in <- l$object[!is.na(object_id)] - set(obj_id_in, NULL, "object_name", NULL) - - # handle when trying to match whole class - if (nrow(l_cls <- l$dot[J(TRUE), on = "class", nomatch = 0L])) { - set(l_cls, NULL, "object_rleid", unlist(l_cls$object_rleid)) - obj_nm_in <- l$object[is.na(object_id)][!l_cls, on = c("rleid", "object_rleid")] - set(obj_nm_in, NULL, "object_id", NULL) - cls_nm_in <- l$object[is.na(object_id)][!obj_nm_in, on = c("rleid", "object_rleid")] - set(cls_nm_in, NULL, "object_id", NULL) - } else { - obj_nm_in <- l$object[is.na(object_id)] - set(obj_nm_in, NULL, "object_id", NULL) - cls_nm_in <- obj_nm_in[0L] - } + # assign input value + cls_val_out[cls_val, on = c("rleid", "object_id", "field_index"), + `:=`(value_chr = i.value_chr, value_num = i.value_num)] + cls_val <- cls_val_out + } else { + setnames(cls_val, "name", "object_name") + # add object name + add_joined_cols(idf_env$object, cls_val, "object_id", "object_name") + cls_val[idf_env$value, on = c("object_id", "field_id"), value_id := i.value_id] + } + setorderv(cls_val, c("rleid", "object_id")) + } - # get object data - obj_id <- get_idf_object(idd_env, idf_env, object = obj_id_in$object_id) - set(obj_id, NULL, names(obj_id_in), obj_id_in) - obj_nm <- get_idf_object(idd_env, idf_env, object = obj_nm_in$object_name, ignore_case = TRUE) - set(obj_nm, NULL, setdiff(names(obj_nm_in), "object_name"), obj_nm_in[, -"object_name"]) - - if (!nrow(cls_nm_in)) { - cls_nm <- obj_nm[0L] - # make sure each object can be matched in value table - l$value[obj_id, on = c("rleid", "object_rleid"), `:=`(object_id = i.object_id)] - l$value[obj_nm, on = c("rleid", "object_rleid"), `:=`(object_id = i.object_id)] - } else { - # get all objects in class - cls_nm <- get_idf_object(idd_env, idf_env, class = cls_nm_in$object_name, underscore = TRUE) - # make sure each object can be matched in object table - cls_nm_in[, new_rleid := .GRP, by = c("rleid", "object_rleid")] - cls_nm <- cls_nm[cls_nm_in[, -c("object_name")], on = c(rleid = "new_rleid")][ - , `:=`(rleid = i.rleid, i.rleid = NULL, class_name_us = NULL)][ - , object_rleid := seq_len(.N), by = "rleid"] - - # make sure each object can be matched in value table - l$value[obj_id, on = c("rleid", "object_rleid"), `:=`(sgl_object_id = i.object_id)] - l$value[obj_nm, on = c("rleid", "object_rleid"), `:=`(sgl_object_id = i.object_id)] - l$value <- cls_nm[, list(rleid, object_id)][l$value, on = "rleid", allow.cartesian = TRUE][ - !is.na(sgl_object_id), object_id := sgl_object_id] - set(l$value, NULL, "sgl_object_id", NULL) - } + # combine empty + cls_obj <- rbindlist(list(cls_obj_emp, cls_obj), use.names = TRUE) + cls_val <- rbindlist(list(cls_val_emp, cls_val), use.names = TRUE) + } + # }}} - # combine - obj <- rbindlist(list(obj_id, obj_nm, cls_nm), use.names = TRUE) - setorderv(obj, c("rleid", "object_rleid")) + # for object input {{{ + if (!nrow(obj)) { + obj <- data.table() + obj_val <- data.table() + } else { + # columns not used + set(obj, NULL, c("is_ref", "lhs_sgl", "rhs_sgl"), NULL) - # update comment - # NOTE: have to use `:=` format here as comment is a list - obj[!vlapply(new_comment, is.null), `:=`(comment = new_comment)] - set(obj, NULL, c("new_comment", "empty"), NULL) + # add a new unique rleid + set(obj, NULL, "each_rleid", rleid(obj$rleid, obj$each_rleid)) + set(obj_val, NULL, "each_rleid", rleid(obj_val$rleid, obj_val$each_rleid)) - # stop if cannot set objects - assert_can_do(idd_env, idf_env, l$dot, obj, "set") + setnames(obj, c("id", "name"), c("object_id", "object_name")) + setnames(obj_val, c("id", "name"), c("object_id", "object_name")) - # make sure rleid column as the unique id - set(obj, NULL, "new_rleid", rleid(obj$rleid, obj$object_rleid)) + # verify object id and name + if (!length(i <- which(!is.na(obj$object_name)))) { + set(obj, NULL, c("class_id", "class_name", "object_name", "object_name_lower"), + fast_subset(get_idf_object(idd_env, idf_env, object = obj$object_id), + c("class_id", "class_name", "object_name", "object_name_lower") + ) + ) + } else { + set(obj, i, c("class_id", "class_name", "object_id", "object_name", "object_name_lower"), + fast_subset(get_idf_object(idd_env, idf_env, object = obj$object_name[i], ignore_case = TRUE), + c("class_id", "class_name", "object_id", "object_name", "object_name_lower") + ) + ) - # new value table - val <- l$value[obj[, -c("object_rleid", "comment")], on = c("rleid", "object_id"), nomatch = 0L] + i <- setdiff(seq_len(nrow(obj)), i) - # clean old rleid - setnames(obj, c("new_rleid", "rleid", "object_rleid"), c("rleid", "input_rleid", "input_object_rleid")) - setnames(val, c("new_rleid", "rleid", "object_rleid"), c("rleid", "input_rleid", "input_object_rleid")) + set(obj, i, c("class_id", "class_name", "object_name", "object_name_lower"), + fast_subset(get_idf_object(idd_env, idf_env, object = obj$object_id[i]), + c("class_id", "class_name", "object_name", "object_name_lower") + ) + ) + } - setnames(val, c("value_chr", "value_num"), c("new_value", "new_value_num")) + # stop if trying to modifying same object multiple times + if (.unique && anyDuplicated(c(cls_obj$object_id, obj$object_id))) { + invld <- setorderv(rbindlist(list(cls_obj[, list(rleid, object_id)], obj[, list(rleid, object_id)]), use.names = TRUE), + "rleid")[duplicated(object_id)][1L] + abort(paste0("Assertion on 'Object ID' failed: Contains duplicated values, position ", + invld$rleid, " {ID: ", invld$object_id, "}."), + "dots_dup_name" + ) + } - if (any(is.na(val$field_name))) { - val <- fill_unnamed_field_index(idd_env, idf_env, val) - } else { - # just to verify field names - fld_out <- get_idd_field(idd_env, class = val$class_id, field = val$field_name) - # set matched field index - set(val, NULL, "field_index", fld_out$field_index) - # remove input field name - if (has_name(val, "field_in")) set(val, NULL, "field_in", NULL) - } + # extract values for empty input + # empty here means to extract all objects in that class + if (!.empty) { + obj_emp <- data.table() + val_emp <- data.table() + } else if (!any(obj$is_empty)) { + obj_emp <- data.table() + val_emp <- data.table() + } else { + obj_emp <- .Call(data.table:::CsubsetDT, obj, which(obj$rleid %in% obj$rleid[obj$is_empty]), seq_along(obj)) + obj <- .Call(data.table:::CsubsetDT, obj, which(!obj$rleid %in% obj$rleid[obj$is_empty]), seq_along(obj)) - list(object = obj, value = val) -} -# }}} -# del_idf_object {{{ -del_idf_object <- function (idd_env, idf_env, ..., .ref_to = FALSE, .ref_by = FALSE, - .recursive = FALSE, .force = FALSE) { - l <- sep_name_dots(..., .can_name = TRUE) - obj <- get_object_input(idd_env, idf_env, l, keep_duplicate = TRUE) - set(obj, NULL, c("object_name_lower", "comment", "new_object_name"), NULL) - - # enable to delete even required objects if .force is TRUE - if (!.force) { - assert_can_do(idd_env, idf_env, l$dot, obj, "del") - } else { - ori <- eplusr_option("validate_level") - on.exit(eplusr_option(validate_level = ori), add = TRUE) + set(obj_emp, NULL, c("is_empty", "each_rleid"), NULL) - # disable required-object and unique-object checking - chks <- level_checks(ori) - chks$required_object <- FALSE - chks$unique_object <- FALSE - eplusr_option(validate_level = chks) + val_emp <- get_idf_value(idd_env, idf_env, object = obj_emp$object_id, + complete = .complete, all = .all + ) + set(val_emp, NULL, "rleid", rep(obj_emp$rleid, table(val_emp$rleid))) - assert_can_do(idd_env, idf_env, l$dot, obj, "del") - } + # assign default value if necessary + if (.sgl) { + if (.default) { + val_emp <- assign_idf_value_default(idd_env, idf_env, val_emp) + } + } else { + set(cls_val_emp, NULL, c("value_chr", "value_num"), + list(as.list(cls_val_emp$value_chr), as.list(cls_val_emp$value_num)) + ) + } - # get objects to be deleted - id_del <- obj$object_id + # exclude empty value input + obj_val <- .Call(data.table:::CsubsetDT, obj_val, which(obj_val$rleid %in% obj$rleid), seq_along(obj_val)) + } - # always check if targets objects are referred by others - dir <- if (.ref_to) "all" else "ref_by" + if (!nrow(obj_val)) { + obj <- data.table() + obj_val <- data.table() + } else { + set(obj, NULL, "is_empty", NULL) - depth <- if (.recursive) NULL else 0L - rel <- get_idfobj_relation(idd_env, idf_env, id_del, direction = dir, - depth = depth, name = eplusr_option("verbose_info") - ) + add_joined_cols(obj, obj_val, "each_rleid", c("object_id", "object_name", "class_id", "class_name")) + # after this, each_rleid is not needed + set(obj, NULL, "each_rleid", NULL) - if (eplusr_option("verbose_info")) { - msg <- paste0("Deleting object(s) [ID: ", paste(id_del, sep = ", ", collapse = ", "), "]") - } + if (.sgl) { + # match field id + obj_sgl <- obj_val[, by = "rleid", list(each_rleid = max(each_rleid), n = length(unique(each_rleid)))] + obj_sgl <- match_idd_field(idd_env, obj_val[obj_sgl, on = c("rleid", "each_rleid")]) - id_ref_by <- c() + obj_sgl <- obj_sgl[, by = "rleid", + list(field_id = rep(field_id, n[[1L]]), + field_index = rep(field_index, n[[1L]]), + field_name = rep(field_name, n[[1L]]) + ) + ] - # do not delete objects that reference input class names except the whole - # class are included in the value-reference relation, or input object is the - # only existing one in input class - # get_exclude_class {{{ - get_exclude_class <- function (dt) { - whole <- NULL - if (!has_name(dt, "src_class_id")) { - add_joined_cols(idf_env$object, dt, c(src_object_id = "object_id"), - c(src_class_id = "class_id") - ) - } - dt[, - { - # check if class-name reference exists - if (!any(src_enum == 1L)) { - list(whole = FALSE) + set(obj_val, NULL, c("field_id", "field_index", "field_name"), + set(obj_sgl, NULL, "rleid", NULL) + ) } else { - cls <- src_class_id - # get all object IDs in target class - all <- idf_env$object[J(cls), on = "class_id", object_id] - - # only delete if there is only one object existing in input - # class or all objects in input class are extracted by - # value reference - list(whole = length(all) == 1L || !as.logical(length(setdiff(all, src_object_id[src_enum == 2L])))) + # match field id + obj_val <- match_idd_field(idd_env, obj_val) } - }, - by = "src_class_id"][ - whole == FALSE, src_class_id - ] - } - # }}} - # ref by {{{ - # exclude invalid reference - if (nrow(rel$ref_by)) { - rel$ref_by <- rel$ref_by[!J(NA_integer_), on = "object_id"] + # assign default value if necessary + if (.default && .sgl) { + obj_val <- assign_idf_value_default(idd_env, idf_env, obj_val) + } - exclude <- get_exclude_class(rel$ref_by) - if (length(exclude)) { - rel$ref_by <- rel$ref_by[!J(1L, exclude), on = c("src_enum", "src_class_id")] - } + # complete fields if necessary + if (.all || .complete) { - # stop if objects are referred {{{ - # should be able to delete targets objects in at least one condition: - # 1. current validate level does not includ reference checking - # 2. want to delete both targets and referees - # 3. `.force` is TRUE - if (level_checks()$reference && !.ref_by && !.force && nrow(rel$ref_by)) { - rel$ref_by <- rel$ref_by[!J(id_del), on = "object_id"] + fld_in <- obj_val[, by = c("rleid", "each_rleid"), list(object_id = object_id[[1L]], field_index = max(field_index))] - if (!eplusr_option("verbose_info")) { - rel$ref_by <- add_idf_relation_format_cols(idd_env, idf_env, rel$ref_by) - } - abort("error_del_referenced", - paste0( - "Cannot delete object(s) that are referred by others:\n", - "\n", - paste0(" ", unlist(format_idf_relation(rel$ref_by, "ref_by")$fmt, use.names = FALSE), collapse = "\n") - ) - ) - } - # }}} + # complete fields if necessary + obj_val_out <- get_idf_value(idd_env, idf_env, + object = fld_in$object_id, field = fld_in$field_index, + complete = .complete, all = .all + ) + add_rleid(fld_in, "field") + add_joined_cols(fld_in, obj_val_out, c("rleid" = "field_rleid"), c("rleid", "each_rleid")) - if (.ref_by && nrow(rel$ref_by)) { - # check if objects that refer to targets are also referred by other - # objects - id_ref_by <- setdiff(unique(rel$ref_by$object_id), id_del) - id_src <- id_ref_by[id_ref_by %in% idf_env$reference$src_object_id] - if (!.force && length(id_src)) { - id_ref_by <- setdiff(id_ref_by, id_src) - if (eplusr_option("verbose_info")) { - if (length(id_ref_by)) { - msg <- c(msg, - paste0( - "Including object(s) [ID:", paste(id_ref_by, collapse = ", "), "] that refer to it, ", - "skipping object(s) [ID: ", paste0(id_src, collapse = ","), "] that is referred by other objects." - ) - ) - } else { - msg <- c(msg, - paste0("Skipping object(s) [ID: ", paste0(id_src, collapse = ","), "] that is referred by other objects.") + # make the original value as a list if necessary + if (!.sgl) { + set(obj_val_out, NULL, c("value_chr", "value_num"), + list(as.list(obj_val_out$value_chr), as.list(obj_val_out$value_num)) ) } + + # assign input value + obj_val_out[obj_val, on = c("each_rleid", "object_id", "field_id"), + `:=`(value_chr = i.value_chr, value_num = i.value_num)] + obj_val <- obj_val_out + } else { + # add object name + obj_val[idf_env$value, on = c("object_id", "field_id"), value_id := i.value_id] } - } else { - if (eplusr_option("verbose_info")) { - msg <- c(msg, - paste0("Including object(s) [ID:", paste(id_ref_by, collapse = ", "), "] that refer to it.") - ) - } + + setorderv(obj_val, "each_rleid") + set(obj_val, NULL, "each_rleid", NULL) } + + # combine empty + obj <- rbindlist(list(obj_emp, obj), use.names = TRUE) + obj_val <- rbindlist(list(val_emp, obj_val), use.names = TRUE) } + # }}} + + # combine all + obj <- rbindlist(list(cls_obj, obj), use.names = TRUE) + val <- rbindlist(list(cls_val, obj_val), use.names = TRUE) + setorderv(obj, "rleid") + setorderv(val, "rleid") + + # keep column order + setcolorder(obj, c("rleid", "class_id", "class_name", "object_id", "object_name", "object_name_lower", "comment")) + setcolorder(val, c("rleid", "class_id", "class_name", "object_id", "object_name", + "field_id", "field_index", "field_name", "value_id", "value_chr", "value_num")) } # }}} - # if .ref_to is TRUE and rel$ref_to has contents - # ref to {{{ - if (NROW(rel$ref_to)) { - # exclude invalid reference - rel$ref_to <- rel$ref_to[!J(NA_integer_), on = "src_object_id"] + list(object = obj, value = val) +} +# }}} +# match_idd_field {{{ +match_idd_field <- function (idd_env, dt_field) { + # need to verify field name + i <- which(!is.na(dt_field$field_name)) + # need to verify field index + j <- which(!is.na(dt_field$field_index)) + + # verify field name + if (length(i)) { + set(dt_field, i, c("field_id", "field_index", "field_name"), + fast_subset(get_idd_field(idd_env, dt_field$class_id[i], dt_field$field_name[i], underscore = TRUE), + c("field_id", "field_index", "field_name") + ) + ) + } + + # verify field index + if (length(j)) { + set(dt_field, j, c("field_id", "field_name"), + fast_subset(get_idd_field(idd_env, dt_field$class_id[j], dt_field$field_index[j]), + c("field_id", "field_name") + ) + ) + } - # same as ref_by, if input refers to a class name, delete objects in - # that class only if there is only one object left in that class - exclude <- get_exclude_class(rel$ref_to) - if (length(exclude)) { - rel$ref_to <- rel$ref_to[!J(1L, exclude), on = c("src_enum", "src_class_id")] + # need to fill field index + k <- which(is.na(dt_field$field_index)) + dt_field[, by = "rleid", field_index := { + # stop if trying to modify same field multiple times + matched <- !is.na(field_index) + + if (anyDuplicated(field_index[matched])) { + wh <- which(duplicated(field_index[matched])) + idx <- field_index[matched][wh] + nm <- field_name[matched][wh] + abort(paste0("Assertion on 'Field Index & Name' failed, element ", .BY$rleid, ": ", + "Field index must not match an input field name: ", + paste0(sprintf("{%i --> %s} at position %i", idx, nm, wh), collapse = "\n")), + "dots_multi_match") } - id_ref_to <- setdiff(unique(rel$ref_to$src_object_id), id_del) + # all matched + if (all(matched)) { + field_index + } else { + # what are left after excluding detected field indices + idx <- setdiff(seq_len(.N), field_index[matched]) + field_index[!matched] <- idx[seq.int(sum(!matched))] + field_index + } + }] + if (length(k)) { + set(dt_field, k, c("field_id", "field_name"), + fast_subset(get_idd_field(idd_env, dt_field$class_id[k], dt_field$field_index[k]), + c("field_id", "field_name") + ) + ) + } - # check if objects that target refers to are also referred by other - # objects - id_src <- idf_env$reference[!J(id_del), on = "object_id"][ - J(unique(rel$ref_to$src_object_id)), on = "src_object_id", nomatch = 0L, unique(src_object_id) - ] - id_src <- setdiff(id_src, id_del) - if (!.force && length(id_src)) { - id_ref_to <- setdiff(id_ref_to, id_src) - if (eplusr_option("verbose_info")) { - if (length(id_ref_to)) { - msg <- c(msg, - paste0( - "Including object(s) [ID:", paste(id_ref_to, collapse = ", "), "] that is referred by it, ", - "skipping object(s) [ID: ", paste0(id_src, collapse = ","), "] that is also referred by other objects." - ) - ) - } else { - msg <- c(msg, - paste0("Skipping object(s) [ID: ", paste0(id_src, collapse = ","), "] that is also referred by other objects.") - ) - } - } + dt_field +} +# }}} +# expand_idf_dots_object {{{ +#' Parse object values given in a list of Idf or IdfObject format +#' +#' @param idd_env An environment or list contains IDD tables including class, +#' field, and reference. +#' +#' @param idf_env An environment or list contains IDF tables including object, +#' value, and reference. +#' +#' @param ... Lists of [Idf]s or [IdfObject]s. +#' +#' @param .unique If `TRUE`, make sure there are no duplicated objects in the +#' input. If `FALSE`, duplicates are kept. If `NULL`, duplicates are +#' removed. Default: `TRUE`. +#' +#' @param .complete If `TRUE`, make sure the returned field number meets the +#' `\min-fields` requirement. Default: `TRUE` +#' +#' @param .all If `TRUE`, make sure the all possible fields are returned. +#' Default: `FALSE`. +#' +#' @param .strict If `TRUE`, make sure all input objects come from the same +#' verion as that from `idf_env`. Default: `TRUE`. +#' +#' @return A named list of 3 [data.table::data.table()]: `meta`, `object` and +#' `value`. +#' +#' @keywords internal +#' @export +expand_idf_dots_object <- function (idd_env, idf_env, ..., .unique = TRUE, .strict = TRUE, .complete = TRUE, .all = FALSE) { + l <- list(...) + + # stop if empty input + if (!length(l)) abort("Assertion on 'Input' failed: Contains only missing values.", "dots_empty") + + # extract Idf meta + extract_idf <- function (x) { + list(version = get_priv_env(x)$m_version, + uuid = get_priv_env(x)$m_log$uuid, + object_id = NA_integer_, + idd_env = list(get_priv_env(x)$idd_env()), + idf_env = list(get_priv_env(x)$idf_env()) + ) + } + # extract IdfObject meta + extract_idfobj <- function (x) { + list(version = get_priv_env(get_priv_env(x)$m_parent)$m_version, + uuid = get_priv_env(get_priv_env(x)$m_parent)$m_log$uuid, + object_id = get_priv_env(x)$m_object_id, + idd_env = list(get_priv_env(x)$idd_env()), + idf_env = list(get_priv_env(x)$idf_env()) + ) + } + extract_data <- function (x) { + if (is_idf(x)) extract_idf(x) else if (is_idfobject(x)) extract_idfobj(x) + } + + len <- rep(1L, length(l)) + is_nest <- logical(length(l)) + d <- lapply(seq_along(l), function (i) { + ll <- .subset2(l, i) + if (is_idf(ll)) { + extract_idf(ll) + } else if (is_idfobject(ll)) { + extract_idfobj(ll) } else { - if (eplusr_option("verbose_info")) { - msg <- c(msg, - paste0("Including object(s) [ID:", paste(id_ref_by, collapse = ", "), "] that is referred by it.") - ) + if (!test_list(ll, c("Idf", "IdfObject"), any.missing = FALSE, all.missing = FALSE)) { + abort(paste0("Assertion on 'Input' failed, element ", i, ": ", + "Must be an 'Idf' or 'IdfObject', or a list of them."), "dots_format") } + d <- lapply(ll, extract_data) + # update actual object number + len[[i]] <<- length(d) + is_nest[[i]] <<- TRUE + d + } + }) + + # store all meta data in a table + meta <- c() + for (i in seq_along(d)) { + if (is_nest[[i]]) meta <- c(meta, d[[i]]) else meta <- c(meta, d[i]) + } + meta <- rbindlist(meta) + set(meta, NULL, "rleid", rep(seq_along(d), len)) + add_rleid(meta, "object") + + if (.strict) { + # get current version + ver <- standardize_ver(get_idf_value(idd_env, idf_env, "Version")$value_chr) + same_ver <- Reduce(c, meta$version)[, c(1:2)] == ver[, c(1:2)] + if (!any(same_ver)) { + abort(paste0("Assertion on 'Input' failed, element ", meta$rleid[!same_ver][1L], ": ", + "Must have a version of ", surround(ver[, c(1:2)]), "."), "dots_format") } } - # }}} - if (eplusr_option("verbose_info") && - ((.ref_to && NROW(rel$ref_to)) || (.ref_by && NROW(rel$ref_by)) || - (.force && (NROW(rel$ref_to) || NROW(rel$ref_by))))) { - msg <- paste0(c(msg, "", "Object relation is shown below:", ""), collapse = "\n") - msg_rel <- paste0(" ", capture.output(print.IdfRelation(rel)), collapse = "\n") - verbose_info(paste0(msg, msg_rel, collapse = "\n")) + # stop if duplicates + has_dup <- FALSE + if (anyDuplicated(meta, by = c("uuid", "object_id"))) { + has_dup <- TRUE + if (is.null(.unique)) { + meta <- unique(meta, by = c("uuid", "object_id")) + } else if (isTRUE(.unique)) { + i <- meta[duplicated(meta, by = c("uuid", "object_id")), rleid[1L]] + abort(paste0("Assertion on 'Input' failed, element ", i, ": Input must be all unique."), "dots_format") + } } - id_del <- if (NROW(rel$ref_to)) c(id_del, id_ref_by, id_ref_to) else c(id_del, id_ref_by) - - # delete rows in object table - dt_object <- idf_env$object[!J(id_del), on = "object_id"] - dt_value <- idf_env$value[!J(id_del), on = "object_id"] - # keep invalid reference - dt_reference <- idf_env$reference[!J(id_del), on = "object_id"][ - J(id_del), on = "src_object_id", - `:=`(src_object_id = NA_integer_, src_value_id = NA_integer_) - ] + # hand Idf and IdfObject differently + set(meta, NULL, "type_rleid", meta$object_id) + meta[J(NA_integer_), on = "type_rleid", type_rleid := -seq_len(.N), by = "uuid"] - list(object = dt_object[, .SD, .SDcols = names(idf_env$object)], - value = dt_value[, .SD, .SDcols = names(idf_env$value)], - reference = dt_reference - ) -} -# }}} -# purge_idf_object {{{ -purge_idf_object <- function (idd_env, idf_env, object = NULL, class = NULL, group = NULL) { - obj <- get_idf_object_from_multi_level(idd_env, idf_env, object, class, group) + obj_val <- meta[, by = c("uuid", "type_rleid"), { + # Idf object + if (type_rleid[[1L]] < 0L) { + obj_per <- get_idf_object(idd_env[[1L]], idf_env[[1L]]) + val_per <- get_idf_value(idd_env[[1L]], idf_env[[1L]], complete = .complete, all = .all) - # exclude objects that cannot be resources - src <- obj[J(unique(idd_env$reference$src_class_id)), on = "class_id", nomatch = 0L] + set(obj_per, NULL, "rleid", object_rleid) + set(val_per, NULL, "rleid", object_rleid) + } else { + obj_per <- get_idf_object(idd_env[[1L]], idf_env[[1L]], object = object_id) + val_per <- get_idf_value(idd_env[[1L]], idf_env[[1L]], object = object_id, complete = .complete, all = .all) - if (eplusr_option("verbose_info")) { - norm <- obj[!src, on = "class_id"] - if (nrow(norm)) { - verbose_info("Non-resource objects are ignored:\n", get_object_info(norm, collapse = "\n")) + set(obj_per, NULL, "rleid", rep(object_rleid, table(obj_per$rleid))) + set(val_per, NULL, "rleid", rep(object_rleid, table(val_per$rleid))) } - } - # get references - ref <- get_idf_relation(idd_env, idf_env, src$object_id, depth = 0L, direction = "ref_by") + list(object = list(obj_per), value = list(val_per)) + }] - # get objects that can be removed directly - id_del <- setdiff(src$object_id, ref$src_object_id) + obj <- rbindlist(obj_val$object, use.names = TRUE) + val <- rbindlist(obj_val$value, use.names = TRUE) - # take into account references inside inputs, i.e. an resource object can - # be purged if all objects referencing it can be purged and have already - # been captured in 'id_del' - id_rec <- setdiff( - # resources that are used by objects to be purged - ref[J(id_del), on = "object_id", nomatch = 0L, src_object_id], - # resources that are not used by objects to be purged - ref[!J(id_del), on = "object_id", src_object_id] - ) + # clean + set(meta, NULL, c("rleid", "type_rleid"), NULL) + setnames(meta, "object_rleid", "rleid") - # should do above step again to catch the deepest resources - id_del <- c(id_del, id_rec) - id_rec <- setdiff( - # resources that are used by objects to be purged - ref[J(id_del), on = "object_id", nomatch = 0L, src_object_id], - # resources that are not used by objects to be purged - ref[!J(id_del), on = "object_id", src_object_id] - ) + # keep column order + setcolorder(meta, c("rleid", "version", "uuid", "object_id", "idd_env", "idf_env")) + setcolorder(obj, c("rleid", "class_id", "class_name", "object_id", "object_name", "object_name_lower", "comment")) + setcolorder(val, c("rleid", "class_id", "class_name", "object_id", "object_name", + "field_id", "field_index", "field_name", "value_id", "value_chr", "value_num")) - # for a class-name-only reference, i.e. only object name is used as - # reference but none of its fields are, only purge it if there is multiple - # objects existing in the same class - # - # whether a object that both its class name and fields are referenced by - # others can be purged or not has been checked in 'id_rec', also for - # a class-name-only reference, the object references it can be purged or not - # has also been check in 'id_rec' - ref_cls <- ref[!J(id_rec), on = "src_object_id"] - - if (!nrow(ref_cls)) { - id_cls <- NULL - } else { - id_cls <- ref_cls[, by = "src_object_id", list(class = all(src_enum == IDDFIELD_SOURCE$class))][ - class == TRUE, src_object_id] + list(meta = meta, object = obj, value = val) +} +# }}} +# expand_idf_dots_literal {{{ +#' Parse object values given in literal character vectors or data.frames +#' +#' @details +#' For object definitions in character vector format, they follow the +#' same rules as a normal IDF file: +#' +#' * Each object starts with a class name and a comma (`,`); +#' * Separates each values with a comma (`,`); +#' * Ends an object with a semicolon (`;`) for the last value. +#' +#' Each character vector can contain: +#' +#' * One single object, e.g. `c("Building,", "MyBuilding;")`, or "Building, MyBuilding;". +#' * Multiple objects, e.g. `c("Building, MyBuilding;", "SimulationControl, Yes")`. +#' +#' You can also provide an option header to indicate if input objects are +#' presented in IP units, using `!-Option ViewInIPunits`. If this header does +#' not exist, then all values are treated as in SI units. +#' +#' For object definitions in data.frame format, a valid definition requires at +#' least three columns described below. Note that column order does not matter. +#' +#' * `class`:Character type. Valid class names in the underlying +#' [Idd] object. +#' * `index`:Integer type. Valid field indices for each class. +#' * `value`:Character type or list type. Value for each field +#' to be added. +#' - If character type, each value should be given as a string even if the +#' corresponding field is a numeric type. +#' - If list type, each value should have the right type as the corresponding +#' field definition. +#' * `id`: **Optional** when `.exact` is `FALSE`. Integer type. +#' If input data.frame includes multiple object definitions in a same class, +#' values in `id` column will be used to distinguish each definition. If `id` +#' column does not exists, it assumes that each definition is separated by +#' `class` column and will issue an error if there is any duplication in the +#' `index` column. +#' +#' @param idd_env An environment or list contains IDD tables including class, +#' field, and reference. +#' +#' @param idf_env An environment or list contains IDF tables including object, +#' value, and reference. +#' +#' @param ... Character vectors or data.frames. +#' +#' @param .default If `TRUE`, all empty fields will be filled with default +#' values if possible. Default: `TRUE`. +#' +#' @param .exact If `TRUE`, all inputs should match existing objects in the +#' [Idf]. In this case, `id` column is require for data.frame input. +#' Default: `FALSE`. +#' +#' @return A named list of 2 element `object` and `value` which is a +#' [data.table::data.table()] with object data and value data respectively. +#' +#' @note +#' Objects from character vectors will always be at the top of each table. +#' +#' @keywords internal +#' @export +expand_idf_dots_literal <- function (idd_env, idf_env, ..., .default = TRUE, .exact = FALSE) { + l <- list(...) + ver <- standardize_ver(get_idf_value(idd_env, idf_env, "Version")$value_chr) - if (length(id_cls)) { - # get object number in that class - obj_num <- get_idf_object_num(idd_env, idf_env, obj[J(id_cls), on = "object_id", class_id]) - id_cls <- id_cls[obj_num > 1L] + assert_list(l, c("character", "data.frame"), .var.name = "Input") - # add field id for updating reference table later - val_cls <- ref_cls[J(id_cls, IDDFIELD_SOURCE$class), on = c("src_object_id", "src_enum"), - list(src_value_id = unique(src_value_id))] - add_joined_cols(idf_env$value, val_cls, c(src_value_id = "value_id"), "field_id") + is_chr <- vlapply(l, is.character) + # character input {{{ + if (!any(is_chr)) { + obj_chr <- data.table() + val_chr <- data.table() + } else { + # parse {{{ + chr <- l[is_chr] + qassertr(chr, "S", .var.name = "Character Input") + + # get total line number + ln_chr <- vector("list", length(chr)) + for (i in seq_along(chr)) { + if (i == 1L) { + ln_chr[[i]] <- seq_along(chr[[i]]) + stri_count_fixed(chr[[i]], "\n") + } else { + ln_chr[[i]] <- seq_along(chr[[i]]) + stri_count_fixed(chr[[i]], "\n") + max(ln_chr[[i - 1L]]) + } } - } - id <- unique(c(id_del, id_rec, id_cls)) + chr <- unlist(chr, FALSE, FALSE) + chr_one <- paste0(chr, collapse = "\n") - if (!length(id)) { - verbose_info("None of specified object(s) can be purged. Skip.") - dt_object <- idf_env$object - dt_value <- idf_env$value - dt_reference <- idf_env$reference - } else { - verbose_info("Object(s) below have been purged:\n", - get_object_info(add_rleid(obj[J(id), on = "object_id"]), collapse = "\n")) + # indicate whether trying to add different Version object + same_ver <- TRUE - # delete rows in object table - dt_object <- idf_env$object[!J(id), on = "object_id"] - dt_value <- idf_env$value[!J(id), on = "object_id"] - dt_reference <- idf_env$reference[!J(id), on = "object_id"] - - # update class-reference - if (nrow(ref_cls) && length(id_cls)) { - val_cls[dt_value, on = "field_id", `:=`(object_id = i.object_id, value_id = i.value_id)] - dt_reference[val_cls, on = "src_value_id", `:=`(src_object_id = i.object_id, src_value_id = i.value_id)] - } - } + # parse as an IDF file + parsed <- withCallingHandlers( + parse_idf_file(chr_one, idd = ver, ref = FALSE), - list(object = dt_object, value = dt_value, reference = dt_reference) -} -# }}} -# duplicated_idf_object {{{ -duplicated_idf_object <- function (idd_env, idf_env, object = NULL, class = NULL, group = NULL) { - dup <- get_idf_duplicated_object(idd_env, idf_env, object, class, group) + eplusr_warning_use_hard_coded_idd = function (w) invokeRestart("muffleWarning"), + eplusr_warning_use_mismatch_idd = function (w) {same_ver <<- FALSE; invokeRestart("muffleWarning")}, - set(dup$object, NULL, "duplicated", FALSE) - dup$object[J(dup$duplicated$object_id_dup), on = "object_id", duplicated := TRUE] + # modify messages if any error occurs + eplusr_error_parse_idf = function (e) { + data <- e$data - dup -} -# }}} -# unique_idf_object {{{ -unique_idf_object <- function (idd_env, idf_env, object = NULL, class = NULL, group = NULL) { - dup <- get_idf_duplicated_object(idd_env, idf_env, object, class, group) + # get the input number + rle <- rep(seq_along(ln_chr), each_length(ln_chr)) + rle <- rle[unlist(ln_chr, FALSE, FALSE) %in% data$line] - if (!nrow(dup$duplicated)) { - verbose_info("None duplicated objects found. Skip.") - return(list(object = idf_env$object, value = idf_env$value, reference = idf_env$reference)) - } + set(data, NULL, "msg_each", paste0("[Character Input #", rle, "] ")) - obj <- dup$object - val <- dup$value - dup <- dup$duplicated + # get line number in each object + title <- switch(class(e)[[1L]], + eplusr_error_parse_idf_ver = "Invalid IDF version found", + eplusr_error_parse_idf_line = "Invalid line found", + eplusr_error_parse_idf_object = "Incomplete object", + eplusr_error_parse_idf_class = "Invalid class name", + eplusr_error_parse_idf_field = "Invalid field number" + ) - # get referenced field index of object to be deleted - ref <- get_idf_relation(idd_env, idf_env, object_id = dup$object_id_dup, direction = "ref_by", depth = 0L) - ref[val, on = c("src_object_id" = "object_id", "src_value_id" = "value_id"), field_index := i.field_index] - # update the referenced object id - ref[dup, on = c("src_object_id" = "object_id_dup"), src_object_id := i.object_id] - # update the reference value id - ref[val, on = c("src_object_id" = "object_id", "field_index"), `:=`( - src_value_id = i.value_id, src_value_chr = i.value_chr, - src_value_num = i.value_num - )] + parse_error("idf", title, data, subtype = gsub("eplusr_error_parse_idf_", "", class(e)[[1L]], fixed = TRUE)) + } + ) - # update referenced value - idf_env$value[ref, on = c("object_id", "value_id"), `:=`( - value_chr = i.src_value_chr, value_num = i.src_value_num - )] - # update reference dict - idf_env$reference[ref, on = c("object_id", "value_id"), `:=`( - src_object_id = i.src_object_id, src_value_id = i.src_value_id - )] + if (!same_ver) { + # locate the Version line + data <- read_lines(chr) + set(data, NULL, "rleid", rep(seq_along(ln_chr), each_length(ln_chr))) + data <- data[J(c(attr(get_idf_ver(data), "line"))), on = "line"] + set(data, NULL, "msg_each", paste0("[Character Input #", data$rleid, "] ")) + parse_error("idf", "Adding a different Version object is prohibited", data, subtype = "ver") + } - if (eplusr::eplusr_option("verbose_info")) { - dup[obj, on = "object_id", `:=`(class_name = i.class_name, object_name = i.object_name)] - set(dup, NULL, "merged", get_object_info(dup, numbered = FALSE, prefix = "")) + # remove inserted version object + id <- parsed$object[J(1L), on = "class_id", object_id] + obj_chr <- parsed$object[!J(id), on = "object_id"] + val_chr <- parsed$value[!J(id), on = "object_id"] - setnames(dup, c("object_id", "object_id_dup"), c("merged_object_id", "object_id")) - dup[obj, on = "object_id", `:=`(object_name = i.object_name)] - dup[, by = c("class_id", "merged_object_id"), removed := get_object_info(.SD, c("id", "name"), numbered = TRUE)] + # after parsing all input character as a whole, there is no way to know + # how many objects are extracted from each input + # object ID should be sufficent for distinguishing all objects + # add rleid for latter error printing + set(obj_chr, NULL, "rleid", obj_chr$object_id) + set(val_chr, NULL, "rleid", val_chr$object_id) + # }}} + # match {{{ + add_class_name(idd_env, obj_chr) + add_joined_cols(obj_chr, val_chr, "object_id", c("class_id", "class_name")) + add_field_property(idd_env, val_chr, c("field_index", "field_name")) + + if (.exact) { + # if all class are valid, each object in class that has name attribute + # should has a valid name + if (anyNA(obj_chr$object_name)) { + cls <- obj_chr[J(NA_character_), on = "object_name", paste0("'", class_name, "'", collapse = "\n")] + abort(paste0("Assertion on 'Character Input' failed: Must be objects with names, ", + "but specified class with no name attribute {", cls, "}."), + "dots_format") + } - msg <- dup[, by = c("class_id", "merged_object_id"), list(list( - sprintf("Duplications for %s have been removed:\n %s", - merged[[1L]], paste0(removed, collapse = "\n ") + # verify object name + obj_chr_match <- tryCatch( + get_idf_object(idd_env, idf_env, obj_chr$class_id, obj_chr$object_name_lower, "has_name", ignore_case = TRUE), + eplusr_error_invalid_object_name = function (e) { + nm <- obj_chr[J(e$value), on = "object_name_lower", paste0("'", object_name[1], "' (Class '", class_name[1], "')")] + abort(paste0("Assertion on 'Character Input' failed: ", + "Must be valid object names in current IDF, but unable to match name ", nm, "."), + "dots_format") + } ) - ))]$V1 - setnames(dup, c("merged_object_id", "object_id"), c("object_id", "object_id_dup")) + # update object id + setnames(obj_chr, "object_id", "input_object_id") + set(obj_chr, NULL, "object_id", obj_chr_match$object_id) + add_joined_cols(obj_chr, val_chr, c("object_id" = "input_object_id"), "object_id") + set(obj_chr, NULL, "input_object_id", NULL) + } + # }}} - verbose_info(paste0(unlist(msg), collapse = "\n\n")) + # set rleid to negative in order to distinguish from data.frame input + set(obj_chr, NULL, "rleid", -obj_chr$rleid) + set(val_chr, NULL, "rleid", -val_chr$rleid) + + if (!.exact) { + set(obj_chr, NULL, c("object_id", "object_name", "object_name_lower"), list(NA_integer_, NA_character_, NA_character_)) + set(val_chr, NULL, c("value_id", "object_id", "object_name"), list(NA_integer_, NA_integer_, NA_character_)) + } else { + val_chr[obj_chr, on = c("rleid", "object_id"), object_name := i.object_name] + } } + # }}} + # data.frame input {{{ + if (all(is_chr)) { + obj_dt <- data.table() + val_dt <- data.table() + } else { + # parse {{{ + # check types + if (.exact) { + n_col <- 4L + nm_col <- c("id", "class", "index", "value") + } else { + n_col <- 3L + nm_col <- c("class", "index", "value") + } - list(object = idf_env$object[!J(dup$object_id_dup), on = "object_id"], - value = idf_env$value[!J(dup$object_id_dup), on = "object_id"], - reference = idf_env$reference - ) -} -# }}} -# rename_idf_object {{{ -rename_idf_object <- function (idd_env, idf_env, ...) { - l <- sep_name_dots(..., .can_name = TRUE) + df <- l[!is_chr] + dt <- lapply(seq_along(df), function (i) { + dt <- as.data.table(.subset2(df, i)) + assert_names(names(dt), must.include = nm_col, .var.name = paste0("DataFrame Input #", i)) + + # check types + qassert(.subset2(dt, "class"), "S", paste0("class column in DataFrame Input #", i)) + qassert(.subset2(dt, "index"), "I", paste0("index column in DataFrame Input #", i)) + if (has_names(dt, "id")) { + qassert(.subset2(dt, "id"), "I", paste0("id column in DataFrame Input #", i)) + if (anyDuplicated(dt, by = c("id", "class", "index"))) { + abort(paste0("Assertion on 'DataFrame Input #", i, "' failed: ", + "Must no duplicates among value combinations of column 'id', 'class' and 'index'"), + "dots_format" + ) + } + } else { + if (anyDuplicated(dt, by = c("class", "index"))) { + abort(paste0("Assertion on 'DataFrame Input #", i, "' failed: ", + "Must no duplicates among value combinations of column 'class' and 'index'"), + "dots_format" + ) + } + set(dt, NULL, "id", NA_integer_) + } - obj <- get_object_input(idd_env, idf_env, l, property = "has_name", keep_duplicate = TRUE) + # if value is character, trim spaces and convert them into NAs + if (is.character(value <- .subset2(dt, "value"))) { + # indicates it's a character vector + type <- 1L - # stop if input object does not have name attribute - assert_can_do(idd_env, idf_env, l$dot, obj, "rename") + value_chr <- stri_trim_both(.subset2(dt, "value")) + value_chr[stri_isempty(value_chr)] <- NA_character_ + value_num <- suppressWarnings(as.double(value_chr)) + # if value is a list, each element should be a single character or a + # number. + } else { + # indicates it's a list + type <- 2L - # make sure rleid column as the unique id - set(obj, NULL, "rleid", rleid(obj$rleid, obj$object_rleid)) - set(obj, NULL, "object_rleid", NULL) + # check if NULL + isnull <- vlapply(value, is.null) - # check input new names {{{ - # get value data - val <- get_idf_value(idd_env, idf_env, object = obj$object_id, - property = c("is_name", "type_enum", "src_enum") - ) - val <- val[is_name == TRUE] - set(val, NULL, "rleid", obj$rleid[val$rleid]) + # make sure no NA and scalar + qassertr(value[!isnull], "V1", paste0("value column in DataFrame Input #", i)) - # check if input new name is the same as the old one - set(obj, NULL, "new_object_name_lower", stri_trans_tolower(obj$new_object_name)) - same <- obj$new_object_name_lower == obj$object_name_lower - # assign new object name - set(obj, NULL, c("object_name", "object_name_lower"), - list(obj$new_object_name, obj$new_object_name_lower)) + # change NULL to NA + value[isnull] <- NA_character_ - # assign name field in order to make sure new object name is used during - # error printing - set(val, NULL, "value_chr", obj$object_name) + # change empty strings to NA + value_chr <- stri_trim_both(unlist(value, FALSE, FALSE)) + value_chr[stri_isempty(value_chr)] <- NA_character_ - # only validate new object names - assert_valid(idd_env, idf_env, obj[!same], val[!same], "rename") - # }}} + isnum <- vlapply(value, is.numeric) + value_num <- rep(NA_real_, length(value)) + value_num[isnum] <- unlist(value[isnum], FALSE, FALSE) + } - # value reference - # if name is referred by other objects, update others - ref_by <- get_idf_relation(idd_env, idf_env, value_id = val$value_id, direction = "ref_by") - add_joined_cols(val, ref_by, c(src_value_id = "value_id"), c(src_value_chr = "value_chr")) + set(dt, NULL, c("rleid", "value_type", "value_chr", "value_num"), list(i, type, value_chr, value_num)) + set(dt, NULL, "value", NULL) - # if name itself is a reference, remove that relation for that depth - ref <- idf_env$reference[!J(ref_by$src_value_id), on = "value_id"] + if (length(extra_cols <- setdiff(names(dt), c("id", "class", "index", "rleid", "value_type", "value_chr", "value_num")))) { + set(dt, NULL, extra_cols, NULL) + } - # update values in main table - if (nrow(ref_by)) { - idf_env$value[J(ref_by$value_id), on = "value_id", `:=`(value_chr = ref_by$src_value_chr)] - idf_env$value[J(ref_by$src_value_id), on = "value_id", `:=`(value_chr = ref_by$src_value_chr)] - } + dt + }) - list(object = obj[, .SD, .SDcols = names(idf_env$object)], - value = val[, .SD, .SDcols = names(idf_env$value)], - reference = ref - ) -} -# }}} -# insert_idf_object {{{ -insert_idf_object <- function (idd_env, idf_env, version, ..., .unique = TRUE, .empty = FALSE) { - l <- sep_object_dots(...) - ver <- version - input <- l$data - - # stop if version is different - if (input[version != ver, .N]) { - abort("error_not_same_version", - paste0( - "Input object(s) should be Idfs or IdfObjects with version ", surround(ver), ". ", - "Invalid input:\n", - paste0(dot_string(l$dot[J(input[version != ver, unique(rleid)]), on = "rleid"], NULL), collapse = "\n") + dt <- rbindlist(dt, use.names = TRUE) + # }}} + # match {{{ + # rename + setnames(dt, c("id", "class", "index"), c("object_id", "class_name", "field_index")) + + # in this case, object_rleid is the unique identifier + set(dt, NULL, "object_rleid", rleid(dt$rleid, dt$class_name, dt$object_id)) + + # extract object table + obj_dt <- dt[, by = c("object_rleid"), + list(rleid = rleid[[1L]], object_id = object_id[[1L]], + class_name = class_name[[1L]], num = max(field_index) ) - ) - } + ] - # field properties needed - prop <- c("units", "ip_units", "default_chr", "default_num", "is_name", - "required_field", "src_enum", "type_enum", "extensible_group" - ) - n_obj <- 0L - # get object and value table - obj_val <- input[, { - # if there is one whole Idf input, just ignore other IdfObjects - if (-1L %in% object_id) { - obj_per <- get_idf_object(idd_env[[1L]], idf_env[[1L]], property = "has_name") - val_per <- get_idf_value(idd_env[[1L]], idf_env[[1L]], property = prop, complete = TRUE) - # for logging purpose - set(obj_per, NULL, "input_rleid", rleid[1L]) + # extract all necessary fields + if (!.exact) { + val_dt <- tryCatch( + get_idd_field(idd_env, obj_dt$class_name, obj_dt$num, complete = TRUE, property = "type_enum"), + eplusr_error_invalid_class_name = function (e) { + invld <- obj_dt[J(e$value[[1L]]), on = "class_name", mult = "first"] + abort(paste0("Assertion on 'class column in DataFrame Input #", invld$rleid, "' failed: ", + "Must contain valid class names, but invalid one found {'", invld$class_name, "'}."), + "dots_format") + }, + eplusr_error_invalid_field_index = function (e) { + invld <- obj_dt[J(e$data$class_name[1L], e$data$field_in[1L]), on = c("class_name", "num"), mult = "first"] + abort(paste0("Assertion on 'index column in DataFrame Input #", invld$rleid, "' failed: ", + "Must contain valid field indices, but invalid one found {'", invld$num, "' (Class: '", invld$class_name, "')}. ", + stri_replace_first_regex(errormsg_field_index(e$data[1L]), ".*\\. ", "")), + "dots_format") + } + ) + set(val_dt, NULL, "field_in", NULL) + set(val_dt, NULL, "value_id", NA_integer_) } else { - obj_per <- get_idf_object(idd_env[[1L]], idf_env[[1L]], object = object_id, property = "has_name") - val_per <- get_idf_value(idd_env[[1L]], idf_env[[1L]], object = object_id, complete = TRUE, property = prop) - # for logging purpose - set(obj_per, NULL, "input_rleid", rleid) + val_dt <- tryCatch( + get_idf_value(idd_env, idf_env, obj_dt$class_name, obj_dt$object_id, obj_dt$num, property = "type_enum", complete = TRUE), + eplusr_error_invalid_class_name = function (e) { + invld <- obj_dt[J(e$value[[1L]]), on = "class_name", mult = "first"] + abort(paste0("Assertion on 'class column in DataFrame Input #", invld$rleid, "' failed: ", + "Must contain valid class names, but invalid one found {'", invld$class_name, "'}."), + "dots_format") + }, + eplusr_error_invalid_object_id = function (e) { + invld <- obj_dt[J(e$value[[1L]]), on = "object_id", mult = "first"] + abort(paste0("Assertion on 'id column in DataFrame Input #", invld$rleid, "' failed: ", + "Must contain valid object IDs, but invalid one found {'", invld$object_id, "' (Class: '", invld$class_name, "')}."), + "dots_format") + }, + eplusr_error_invalid_field_index = function (e) { + invld <- obj_dt[J(e$data$class_name[1L], e$data$field_in[1L]), on = c("class_name", "num"), mult = "first"] + abort(paste0("Assertion on 'index column in DataFrame Input #", invld$rleid, "' failed: ", + "Must contain valid field indices, but invalid one found {'", invld$num, "' (Class: '", invld$class_name, "')}. ", + stri_replace_first_regex(errormsg_field_index(e$data[1L]), ".*\\. ", "")), + "dots_format") + } + ) } - # update object rleid to make it as an identifier - set(obj_per, NULL, "rleid", obj_per$rleid + n_obj) - set(val_per, NULL, "rleid", val_per$rleid + n_obj) - n_obj <<- nrow(obj_per) + n_obj + # update class id + set(obj_dt, NULL, "num", NULL) + obj_dt[val_dt, on = c("object_rleid" = "rleid"), class_id := i.class_id] - list(object = list(obj_per), value = list(val_per)) - }, by = "uuid"] + # assign input value + val_dt[dt, on = c(rleid = "object_rleid", "field_index"), + `:=`(value_chr = i.value_chr, value_num = i.value_num, + rleid = i.rleid, object_id = i.object_id, + value_type = i.value_type, object_rleid = i.object_rleid + ) + ] + # if value column is a character vector, need to reset values since + # all of them are coerced regardless of field types + val_dt[value_type == 1L & type_enum > IDDFIELD_TYPE$real, value_num := NA_real_] - obj <- rbindlist(obj_val$object) - val <- rbindlist(obj_val$value) + # add comment column + if (.exact) { + add_joined_cols(idf_env$object, obj_dt, "object_id", c("object_name", "object_name_lower", "comment")) + } else { + set(obj_dt, NULL, "comment", list(list(NULL))) + } - # ignore Version object - if (any(obj$class_id == 1L)) { - if (eplusr_option("verbose_info")) { - invld <- l$dot[obj[class_id == 1L], on = c("rleid" = "input_rleid"), mult = "first"] - m <- paste0(str_trunc(dot_string(invld, NULL), cli::console_width() - 20L), " --> Class 'Version'", collapse = "\n") - verbose_info("'Version' objects in input below have been automatically skipped:\n", m) + # clean + # at this point, rleid is not useful + set(obj_dt, NULL, "rleid", obj_dt$object_rleid) + set(obj_dt, NULL, "object_rleid", NULL) + set(val_dt, NULL, "rleid", val_dt$object_rleid) + set(val_dt, NULL, c("type_enum", "value_type", "object_rleid"), NULL) + if (!.exact) { + set(obj_dt, NULL, c("object_id", "object_name", "object_name_lower"), list(NA_integer_, NA_character_, NA_character_)) + set(val_dt, NULL, c("object_id", "object_name"), list(NA_integer_, NA_character_)) } - obj <- obj[!J(1L), on = "class_id"] - val <- val[J(obj$rleid), on = "rleid"] + # }}} } + # }}} - # set newly added fields to default value if possible - set(val, NULL, "defaulted", FALSE) - val[value_id < 0L, defaulted := TRUE] - val <- assign_default_value(idd_env, idf_env, val) + obj <- rbindlist(list(obj_chr, obj_dt), use.names = TRUE) + val <- rbindlist(list(val_chr, val_dt), use.names = TRUE) - # update object id - obj <- assign_new_id(idf_env, obj, "object") - add_joined_cols(obj, val, "rleid", "object_id") - # update value id - val <- assign_new_id(idf_env, val, "value") + # reset rleid + set(obj, NULL, "rleid", rleid(obj$rleid)) + set(val, NULL, "rleid", rleid(val$rleid)) - # remove empty fields - add_class_property(idd_env, val, c("min_fields", "num_extensible")) - if (!.empty) val <- remove_empty_fields(val) + # assign default value if necessary + if (.default) val <- assign_idf_value_default(idd_env, idf_env, val) - # remove duplicated objects - add_class_name(idd_env, obj) - if (.unique) { - obj_val <- remove_duplicated_objects(idd_env, idf_env, obj, val) - obj <- obj_val$object - val <- obj_val$value + # keep column order + setcolorder(obj, c("rleid", "class_id", "class_name", "object_id", "object_name", "object_name_lower", "comment")) + setcolorder(val, c("rleid", "class_id", "class_name", "object_id", "object_name", + "field_id", "field_index", "field_name", "value_id", "value_chr", "value_num")) + + list(object = obj, value = val) +} +# }}} +# expand_idf_regex {{{ +#' Parse regular expression of object field values +#' +#' @param idd_env An environment or list contains IDD tables including class, +#' field, and reference. +#' +#' @param idf_env An environment or list contains IDF tables including object, +#' value, and reference. +#' +#' @param pattern A single string of regular expression used to match field +#' values +#' +#' @param pattern,ignore.case,perl,fixed,useBytes All of them are +#' directly passed to [base::grepl][base::grep()] and +#' [base::gsub][base::grep()] with the same default values. +#' +#' @return A named list of 2 [data.table::data.table()]: `object` and `value`. +#' +#' @keywords internal +#' @export +expand_idf_regex <- function (idd_env, idf_env, pattern, replacement = NULL, + class = NULL, ignore.case = FALSE, perl = FALSE, + fixed = FALSE, useBytes = FALSE) { + assert_string(pattern) + + if (!is.null(class) && anyDuplicated(class)) { + abort("Class should not contain any duplication.") } - # for correctly reporting input rleid - set(obj, NULL, "rleid", NULL) - setnames(obj, "input_rleid", "rleid") - # stop if cannot insert objects in specified classes - assert_can_do(idd_env, idf_env, l$dot, obj, "insert") + val <- get_idf_value(idd_env, idf_env, class)[ + grepl(pattern, value_chr, ignore.case = ignore.case, perl = perl, + fixed = fixed, useBytes = useBytes) + ] + + # add object rleid + set(val, NULL, "rleid", rleid(val$object_id)) - # if all inputs are duplications - if (!nrow(obj)) { - return(list(object = idf_env$object[0L], value = idf_env$value[0L], reference = idf_env$reference)) + # get object data + if (!nrow(val)) { + obj <- get_idf_object(idd_env, idf_env, 1L)[0L] + } else { + obj <- get_idf_object(idd_env, idf_env, object = val[, by = "rleid", object_id]$object_id) } - # validate - assert_valid(idd_env, idf_env, obj, val, action = "insert") + if (!is.null(replacement)) { + assert_string(replacement) - list(object = obj[, .SD, .SDcols = names(idf_env$object)], - value = val[, .SD, .SDcols = names(idf_env$value)], - reference = update_value_reference(idd_env, idf_env, obj, val) - ) + set(val, NULL, "value_chr", + gsub(pattern, replacement, val$value_chr, ignore.case = ignore.case, + perl = perl, fixed = fixed, useBytes = useBytes + ) + ) + set(val, NULL, "value_num", suppressWarnings(as.double(val$value_chr))) + } + + # keep column order + setcolorder(obj, c("rleid", "class_id", "class_name", "object_id", "object_name", "object_name_lower", "comment")) + setcolorder(val, c("rleid", "class_id", "class_name", "object_id", "object_name", + "field_id", "field_index", "field_name", "value_id", "value_chr", "value_num")) + + list(object = obj, value = val) } # }}} -# paste_idf_object {{{ -paste_idf_object <- function (idd_env, idf_env, version, in_ip = FALSE, unique = TRUE, default = TRUE, empty = FALSE) { - parsed <- read_idfeditor_copy(version, in_ip) - # add class name - add_class_name(idd_env, parsed$object) - # add class id and field index - add_joined_cols(parsed$object, parsed$value, "object_id", c("class_id", "class_name")) - add_joined_cols(idd_env$field, parsed$value, "field_id", c("field_index", "field_name")) +# ASSERT +# assert_valid {{{ +assert_valid <- function (validity, action) { + if (count_check_error(validity)) { + m <- paste0(capture.output(print_validity(validity)), collapse = "\n") + t <- paste0("Failed to ", action ," object(s).") + abort(paste0(t, "\n\n", m), class = "validity_check") + } + + TRUE +} +# }}} + +# get_class_component_name {{{ +get_class_component_name <- function (class) { + nm <- stri_extract_first_regex(class, "^.+?(?=:)") + nm[is.na(nm)] <- class[is.na(nm)] + nm +} +# }}} + +# OBJECT MUNIPULATION +# dup_idf_object {{{ +#' Duplicate existing objects +#' +#' @param idd_env An environment or list contains IDD tables including class, +#' field, and reference. +#' @param idf_env An environment or list contains IDF tables including object, +#' value, and reference. +#' @param dt_object A [data.table::data.table()] that contains object data. +#' Usually created using [expand_idf_dots_value()]. +#' @param level Validate level. Default: `eplusr_option("validate_level")`. +#' +#' @return The duplicated object data in a named list of 3 +#' [data.table::data.table()]s, i.e. `object`, `value` and `reference`. +#' +#' @keywords internal +#' @export +dup_idf_object <- function (idd_env, idf_env, dt_object, level = eplusr_option("validate_level")) { + chk <- level_checks(level) + # transform input names to lower case + set(dt_object, NULL, "new_object_name_lower", stri_trans_tolower(dt_object$new_object_name)) - # remove version object - obj_ver <- parsed$object[class_name == "Version", object_id] - parsed$object <- parsed$object[!J(obj_ver), on = "object_id"] - parsed$value <- parsed$value[!J(obj_ver), on = "object_id"] + # stop if try to dup version + if (any(invld <- dt_object$class_id == 1L)) { + abort(paste0("Duplicating 'Version' object is prohibited.\n", + paste0(dt_object[invld, sprintf(" #%s| Object ID [%i] --> Class 'Version'", + lpad(rleid, "0"), object_id)], collapse = "\n")), + "dup_version") + } + # stop if trying to duplicate unique object + if (chk$unique_object && nrow(invld <- dt_object[J(get_idd_class_unique(idd_env)$class_id), on = "class_id", nomatch = 0L])) { + abort(paste0("Existing unique object cannot be duplicated. Invalid input:\n", + get_object_info(invld, numbered = TRUE, collapse = "\n")), + "dup_unique") + } - # delete empty fields - add_joined_cols(idd_env$class, parsed$value, "class_id", c("min_fields", "num_extensible")) - add_field_property(idd_env, parsed$value, "required_field") - if (!empty) parsed$value <- remove_empty_fields(parsed$value) + add_class_property(idd_env, dt_object, "has_name") + obj <- make_idf_object_name(idd_env, idf_env, dt_object, use_old = TRUE, include_ori = TRUE, keep_na = FALSE) - # add rleid for validation and message printing - add_rleid(parsed$object) + # update object name + set(obj, NULL, c("object_name", "object_name_lower"), NULL) + setnames(obj, c("new_object_name", "new_object_name_lower"), c("object_name", "object_name_lower")) - # remove duplicated objects - if (unique) { - parsed <- remove_duplicated_objects(idd_env, idf_env, parsed$object, parsed$value) - } + # get new object ID + id_obj <- new_id(idf_env$object, "object_id", nrow(obj)) - # if all inputs are duplications - if (!nrow(parsed$object)) { - return(list(object = idf_env$object[0L], value = idf_env$value[0L], reference = idf_env$reference)) + # logging + if (in_verbose() && any(auto <- is.na(dt_object$new_object_name))) { + auto <- set(copy(obj), NULL, "object_id", id_obj)[auto] + id <- get_object_info(auto, c("id", "class")) + name <- get_object_info(auto, "name", prefix = " --> New ", numbered = FALSE) + verbose_info( + "New names of duplicated objects not given are automatically generated:\n", + paste0(id, name, collapse = "\n") + ) } - # add rleid for validation - add_rleid(parsed$object) - add_rleid(parsed$object, "object") - - # update id - parsed$object <- assign_new_id(idf_env, parsed$object, "object") - parsed$value <- assign_new_id(idf_env, parsed$value, "value") - parsed$value <- correct_obj_id(parsed$object, parsed$value) - set(parsed$value, NULL, "rleid", parsed$value$object_id) - set(parsed$value, NULL, "object_rleid", parsed$value$object_id) - - # add field defaults if possible - set(parsed$value, NULL, "defaulted", FALSE) - if (default) { - parsed$value[is.na(value_chr), defaulted := TRUE] - add_field_property(idd_env, parsed$value, c("default_chr", "default_num", "units", "ip_units")) - parsed$value <- assign_default_value(idd_env, idf_env, parsed$value) - } + # extract value table + val <- get_idf_value(idd_env, idf_env, object = obj$object_id, property = "is_name") - # validate - # add necessary columns for validation - add_field_property(idd_env, parsed$value, c("extensible_group", "type_enum", "src_enum")) - assert_valid(idd_env, idf_env, parsed$object, parsed$value, action = "add") - - # get field reference in whole fields - add_joined_cols(idf_env$object, idf_env$value, "object_id", c("class_id")) - add_class_name(idd_env, idf_env$value) - add_field_property(idd_env, idf_env$value, c("type_enum", "src_enum")) - parsed$reference <- get_value_reference_map(idd_env$reference, - append_dt(idf_env$value, parsed$value, "value_id"), - append_dt(idf_env$value, parsed$value, "value_id") - ) - set(idf_env$value, NULL, c("class_id", "class_name", "type_enum", "src_enum"), NULL) + # assign new object id and value id + obj <- assign_new_id(idf_env, obj, "object") + add_joined_cols(obj, val, "rleid", "object_id") - list(object = parsed$object[, .SD, .SDcols = names(idf_env$object)], - value = parsed$value[, .SD, .SDcols = names(idf_env$value)], - reference = parsed$reference - ) + # assign new object name + val[obj, on = c("object_id", is_name = "has_name"), value_chr := i.object_name] + + # value reference + # extract value reference + # directly copy old field references excepting the name field + ref <- idf_env$reference[J(val$value_id[!val$is_name]), on = "value_id", nomatch = 0L] + + # assign new id + set(obj, NULL, "new_object_id", id_obj) + val[obj, on = "object_id", new_object_id := i.new_object_id] + set(val, NULL, "new_value_id", new_id(idf_env$value, "value_id", nrow(val))) + # update ids in ref + ref[val, on = c("object_id", "value_id"), `:=`(object_id = i.new_object_id, value_id = i.new_value_id)] + + # remove original ids + set(obj, NULL, "object_id", NULL) + setnames(obj, "new_object_id", "object_id") + set(val, NULL, c("object_id", "value_id"), NULL) + setnames(val, c("new_object_id", "new_value_id"), c("object_id", "value_id")) + + # NOTE: For original objects whose fields are referred by others, just keep + # the original relation and no new relation needs to be created as one value + # can only refer to one other value. However, it is possible that new input + # object names can be referred by other existing objects + add_field_property(idd_env, val, "src_enum") + if (nrow(src_val <- val[src_enum > IDDFIELD_SOURCE$none])) { + add_field_property(idd_env, idf_env$value, "type_enum") + src <- get_value_reference_map(idd_env, src_val, idf_env$value, all = FALSE)[ + !J(NA_integer_), on = "value_id"] + on.exit(set(idf_env$value, NULL, "type_enum", NULL), add = TRUE) + ref <- rbindlist(list(ref, src)) + } + + set(obj, NULL, "has_name", NULL) + set(val, NULL, c("src_enum", "is_name"), NULL) + setcolorder(obj, c("rleid", "class_id", "class_name", "object_id", "object_name", "object_name_lower", "comment")) + setcolorder(val, c("rleid", "class_id", "class_name", "object_id", "object_name", "field_id", "field_index", "field_name", "value_id", "value_chr")) + + list(object = obj, value = val, reference = ref) } # }}} -# load_idf_object {{{ -load_idf_object <- function (idd_env, idf_env, version, ..., .unique = TRUE, .default = TRUE, .empty = FALSE) { - l <- sep_definition_dots(..., .version = version) +# add_idf_object {{{ +#' Add new objects +#' +#' @param idd_env An environment or list contains IDD tables including class, +#' field, and reference. +#' @param idf_env An environment or list contains IDF tables including object, +#' value, and reference. +#' @param dt_object A [data.table::data.table()] that contains object data. +#' Usually created using [expand_idf_dots_value()]. +#' @param dt_value A [data.table::data.table()] that contains value data. +#' Usually created using [expand_idf_dots_value()]. +#' @param default If `TRUE`, default values are used for those blank +#' fields if possible. If `FALSE`, empty fields are kept blank. +#' Default: `TRUE`. +#' @param unique If `TRUE`, there are same objects in current [Idf] as input, +#' duplications in input are removed. Default: `FALSE`. +#' @param empty If `TRUE`, trailing empty fields are kept. Default: `FALSE`. +#' @param level Validate level. Default: `eplusr_option("validate_level")`. +#' +#' @return The newly added object data in a named list of 3 +#' [data.table::data.table()]s, i.e. `object`, `value` and `reference`. +#' +#' @keywords internal +#' @export +add_idf_object <- function (idd_env, idf_env, dt_object, dt_value, + default = TRUE, unique = FALSE, empty = FALSE, + level = eplusr_option("validate_level")) { + chk <- level_checks(level) + # stop if try to add version + if (any(invld <- dt_object$class_id == 1L)) { + abort(paste0("Adding 'Version' object is prohibited. Invalid input:\n", + paste0(sprintf(" #%s| Class 'Version'", lpad(dt_object$rleid[invld], "0")), collapse = "\n")), + "add_version") + } + # stop if trying to add another unique object + if (chk$unique_object && nrow(uni <- dt_object[J(get_idd_class_unique(idd_env)$class_id), on = "class_id", nomatch = 0L])) { + + # try to add multi objects in unique classes + if (anyDuplicated(uni$class_id)) { + abort(paste0("Unique object can only be added only once. Invalid input:\n", + paste0(uni[duplicated(class_id), sprintf(" #%s| Class '%s'", lpad(rleid, "0"), class_name)], collapse = "\n")), + "add_unique" + ) + } - prop <- c("is_name", "required_field", "src_enum", "type_enum", "extensible_group") - if (.default) prop <- c(prop, c("units", "ip_units", "default_chr", "default_num")) + if (nrow(invld <- idf_env$object[fast_subset(uni, c("rleid", "class_id", "class_name")), on = "class_id"])) { + abort(paste0("Adding new object in existing unique-object class is prohibited. Invalid input:\n", + get_object_info(invld[, object_id := -rleid], numbered = TRUE, collapse = "\n")), + "add_unique" + ) - # get object and value from data.frame input {{{ - if (!nrow(l$value)) { - obj_dt <- data.table() - val_dt <- data.table() - } else { - # verify class name and add class id - cls <- tryCatch(get_idd_class(idd_env, l$value$class_name, property = c("has_name")), - error_class_name = function (e) { - # get input with invalid class name - id <- l$value[J(unique(e$value)), on = "class_name", unique(rleid)] - abort("error_class_name", - paste0("Invalid class name ", collapse(unique(e$value)), " found in input:\n", - dot_string(l$dot[J(id), on = "rleid"]) - ) - ) - } - ) + } + } - set(l$value, NULL, c("class_id", "class_name", "has_name"), - list(cls$class_id, cls$class_name, cls$has_name) - ) + # assign object id + dt_object <- assign_new_id(idf_env, dt_object, "object") + add_joined_cols(dt_object, dt_value, "rleid", "object_id") - obj_dt <- l$value[, - list(rleid = rleid[[1L]], class_id = class_id[[1L]], - class_name = class_name[[1L]], has_name = has_name[[1L]], - num = max(field_index) - ), - by = "object_id" - ] + # assign value id + dt_value <- assign_new_id(idf_env, dt_value, "value") - # stop of trying to add Version object - if (any(obj_dt$class_id == 1L)) { - invld <- find_dot(l$dot, obj_dt[class_id == 1L]) - m <- paste0(dot_string(invld, NULL), " --> Class ", invld$class_name, collapse = "\n") - abort("error_add_version", - paste0("Adding Version object is prohibited. Invalid input:\n", m) - ) - } + # update object name + if (!has_names(dt_value, "is_name")) add_field_property(idd_env, dt_value, "is_name") + dt_object[dt_value[J(TRUE), on = "is_name", nomatch = 0L], on = c("rleid", "object_id"), object_name := i.value_chr] + set(dt_object, NULL, "object_name_lower", stri_trans_tolower(dt_object$object_name)) + set(dt_value, NULL, "is_name", NULL) + dt_value[dt_object, on = c("rleid", "object_id"), object_name := i.object_name] - # verify class name and add class id - fld_out <- tryCatch( - get_idd_field(idd_env, class = obj_dt$class_id, field = obj_dt$num, complete = TRUE, property = prop), - error_bad_field_index = function (e) { - # update rleid - e$data[, rleid := obj_dt$rleid[e$data$rleid]] - abort_bad_field("error_bad_field_index", "index", e$data) - } - ) + # assign default values + if (default) dt_value <- assign_idf_value_default(idd_env, idf_env, dt_value) - # reset rleid in fld_out - set(fld_out, NULL, c("rleid", "object_id"), obj_dt[fld_out$rleid, list(rleid, object_id)]) + # delete empty fields + if (!empty) dt_value <- remove_empty_fields(idd_env, idf_env, dt_value) - # remove unuseful column - set(fld_out, NULL, "field_in", NULL) + # remove duplications + if (unique) { + l <- remove_duplicated_objects(idd_env, idf_env, dt_object, dt_value) + dt_object <- l$object + dt_value <- l$value + } + # if all inputs are duplications + if (!nrow(dt_object)) { + return(list(object = dt_object[0L], value = dt_value[0L], reference = idf_env$reference[0L])) + } - # remove duplicated columns - set(l$value, NULL, c("class_id", "class_name", "has_name"), NULL) - val_dt <- l$value[fld_out, on = c("rleid", "object_id", "field_index")] + # validate {{{ + # skip unique object checking + chk$unique_object <- FALSE - # if input is character vectors, need to reset values since all of them - # are coerced regardless of field types - val_dt[type == 1L & type_enum > IDDFIELD_TYPE$real, `:=`(value_num = NA_real_)] - set(val_dt, NULL, "type", NULL) + # temporarily change object id for error printing + id_obj <- dt_object$object_id + id_val <- dt_value$object_id + set(dt_object, NULL, "object_id", -dt_object$rleid) + set(dt_value, NULL, "object_id", -dt_value$rleid) - if (.default) val_dt[is.na(defaulted), defaulted := TRUE] + # validate + validity <- validate_on_level(idd_env, idf_env, dt_object, dt_value, level = chk) + assert_valid(validity, "add") - # order - setorderv(val_dt, c("rleid", "field_index")) + set(dt_object, NULL, "object_id", id_obj) + set(dt_value, NULL, "object_id", id_val) + # }}} - # remove unuseful columns - set(obj_dt, NULL, "num", NULL) + # add reference {{{ + # Since 'check_invalid_reference()' will add new field references in idf_env$reference + # only check new sources + if (chk$reference) { + i <- idf_env$reference[object_id < 0L, which = TRUE] + if (length(i)) { + rle <- idf_env$reference$object_id[i] + set(idf_env$reference, i, "object_id", dt_object$object_id[-rle]) + } - # add comment column - set(obj_dt, NULL, "comment", list(list(NULL))) - } - # }}} + j <- idf_env$reference[src_object_id < 0L, which = TRUE] + if (length(j)) { + rle <- idf_env$reference$src_object_id[j] + set(idf_env$reference, j, "src_object_id", dt_object$object_id[-rle]) + } - # get object and value from character input {{{ - if (!length(l$parsed)) { - obj_chr <- data.table() - val_chr <- data.table() + # extract new reference + k <- unique(c(i, j)) + ref <- .Call(data.table:::CsubsetDT, idf_env$reference, k, seq_along(idf_env$reference)) + + # remove from the original IDF reference table + idf_env$reference <- idf_env$reference[-k] + # manually check new reference } else { - obj_chr <- l$parsed$object - val_chr <- l$parsed$value + # add necessary columns used for getting references + add_field_property(idd_env, dt_value, "src_enum") - # add class name - add_class_name(idd_env, obj_chr) - add_class_property(idd_env, obj_chr, "has_name") - # add class id and field index - add_joined_cols(obj_chr, val_chr, "object_id", c("class_id", "class_name")) - add_joined_cols(idd_env$field, val_chr, "field_id", c("field_index", "field_name")) - # add field property - add_field_property(idd_env, val_chr, prop) + 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) + on.exit(set(idf_env$value, NULL, c("src_enum", "class_id", "class_name"), NULL), add = TRUE) - # add field defaults if possible - set(val_chr, NULL, "defaulted", FALSE) - if (.default) val_chr[is.na(value_chr), defaulted := TRUE] + ref <- get_value_reference_map(idd_env, append_dt(idf_env$value, dt_value), dt_value) - # always tag rleid of character input as negative - set(val_chr, NULL, "rleid", -val_chr$rleid) + set(dt_value, NULL, "src_enum", NULL) } + + # here should only find if any values in the original IDF reference input + # values. references among input values have been handled previously + src <- get_value_reference_map(idd_env, dt_value, idf_env$value, all = FALSE)[!J(NA_integer_), on = "object_id"] + ref <- unique(rbindlist(list(ref, src))) # }}} - obj <- rbindlist(list(obj_chr, obj_dt), fill = TRUE) - val <- rbindlist(list(val_chr, val_dt), fill = TRUE) - setorderv(val, c("rleid", "object_id", "field_id")) + list(object = dt_object, value = dt_value, reference = ref) +} +# }}} +# set_idf_object {{{ +#' Modifying existing objects +#' +#' @param idd_env An environment or list contains IDD tables including class, +#' field, and reference. +#' @param idf_env An environment or list contains IDF tables including object, +#' value, and reference. +#' @param dt_object A [data.table::data.table()] that contains object data. +#' Usually created using [expand_idf_dots_value()]. +#' @param dt_value A [data.table::data.table()] that contains value data. +#' Usually created using [expand_idf_dots_value()]. +#' @param empty If `FALSE`, not required empty fields will be removed. +#' Default: `FALSE`. +#' @param level Validate level. Default: `eplusr_option("validate_level")`. +#' +#' @return The modified object data in a named list of 3 +#' [data.table::data.table()]s, i.e. `object`, `value` and `reference`. +#' +#' @keywords internal +#' @export +set_idf_object <- function (idd_env, idf_env, dt_object, dt_value, empty = FALSE, level = eplusr_option("validate_level")) { + chk <- level_checks(level) + # stop if try to modify version + if (any(invld <- dt_object$class_id == 1L)) { + abort(paste0("Modifying 'Version' object is prohibited. Invalid input:\n", + paste0(sprintf(" #%s| Class 'Version'", lpad(dt_object$rleid[invld], "0")), collapse = "\n")), + "set_version") + } + # stop if modifying same object multiple times + if (anyDuplicated(dt_object$object_id)) { + abort(paste0("Cannot modify same object multiple times. Invalid input:\n", + get_object_info(dt_object[duplicated(object_id)], collapse = "\n")), + "set_same" + ) + } + + # add new value id in case there are new fields added + dt_value[value_id < 0L, value_id := new_id(idf_env$value, "value_id", .N)] - # assign object id and value id - obj <- assign_new_id(idf_env, obj, "object") - # make sure rleid is unique - set(obj, NULL, "rleid", seq.int(nrow(obj))) - val <- assign_new_id(idf_env, val, "value") - set(val, NULL, "object_id", rleid(val$rleid, val$object_id)) - set(val, NULL, "rleid", val$object_id) - val <- correct_obj_id(obj, val) # update object name - obj <- update_object_name(obj, val) + if (!has_names(dt_value, "is_name")) add_field_property(idd_env, dt_value, "is_name") + dt_object[dt_value[J(TRUE), on = "is_name", nomatch = 0L], on = c("rleid", "object_id"), object_name := i.value_chr] + set(dt_object, NULL, "object_name_lower", stri_trans_tolower(dt_object$object_name)) + set(dt_value, NULL, "is_name", NULL) + dt_value[dt_object, on = c("rleid", "object_id"), object_name := i.object_name] - # assign default - if (.default) val <- assign_default_value(idd_env, idf_env, val) + # delete empty fields + if (!empty) dt_value <- remove_empty_fields(idd_env, idf_env, dt_value) - # remove duplicated objects - if (.unique) { - parsed <- remove_duplicated_objects(idd_env, idf_env, obj, val) + # validate + validity <- validate_on_level(idd_env, idf_env, dt_object, dt_value, level = chk) + assert_valid(validity, "set") + + # extract reference {{{ + # Since 'check_invalid_reference()' will add new field references in idf_env$reference + # only check new sources + if (chk$reference) { + # extract new reference + ref <- rbindlist(list( + idf_env$reference[J(dt_object$object_id), on = "object_id", nomatch = 0L], + idf_env$reference[J(dt_object$object_id), on = "src_object_id", nomatch = 0L] + )) + # manually check new reference } else { - parsed <- list(object = obj, value = val) - } - - # if all inputs are duplications - if (!nrow(parsed$object)) { - return(list(object = idf_env$object[0L], value = idf_env$value[0L], reference = idf_env$reference)) - } + # add necessary columns used for getting references + add_field_property(idd_env, dt_value, "src_enum") - # check if adding objects in specific class is allowed - assert_can_do(idd_env, idf_env, l$dot, parsed$object, action = "add") + 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) + on.exit(set(idf_env$value, NULL, c("src_enum", "class_id", "class_name"), NULL), add = TRUE) - # delete fields - add_joined_cols(idd_env$class, parsed$value, "class_id", c("min_fields", "num_extensible")) - if (!.empty) parsed$value <- remove_empty_fields(parsed$value) + ref <- get_value_reference_map(idd_env, append_dt(idf_env$value, dt_value), dt_value) - # validate - assert_valid(idd_env, idf_env, parsed$object, parsed$value, action = "add") + set(dt_value, NULL, "src_enum", NULL) + } - # get field reference in whole fields - add_joined_cols(idf_env$object, idf_env$value, "object_id", "class_id") - add_class_name(idd_env, idf_env$value) - add_field_property(idd_env, idf_env$value, c("type_enum", "src_enum")) - parsed$reference <- get_value_reference_map(idd_env$reference, - append_dt(idf_env$value, parsed$value, "value_id"), - append_dt(idf_env$value, parsed$value, "value_id") - ) - set(idf_env$value, NULL, c("class_id", "class_name", "type_enum", "src_enum"), NULL) + # here should only find if any values in the original IDF reference input + # values. references among input values have been handled previously + src <- get_value_reference_map(idd_env, dt_value, idf_env$value, all = FALSE)[!J(NA_integer_), on = "object_id"] + ref <- unique(rbindlist(list(ref, src))) + # }}} - # update object name - parsed$object <- update_object_name(parsed$object, parsed$value) - # add lower name - set(parsed$object, NULL, "object_name_lower", stri_trans_tolower(parsed$object$object_name)) - set(parsed$object, NULL, "has_name", NULL) - - list(object = parsed$object[, .SD, .SDcols = names(idf_env$object)], - value = parsed$value[, .SD, .SDcols = names(idf_env$value)], - reference = parsed$reference - ) + list(object = dt_object, value = dt_value, reference = ref) } # }}} -# update_idf_object {{{ -update_idf_object <- function (idd_env, idf_env, version, ..., .default = TRUE, .empty = FALSE) { - l <- sep_definition_dots(..., .version = version, .update = TRUE) - - prop <- c("is_name", "required_field", "src_enum", "type_enum", "extensible_group") - if (.default) prop <- c(prop, c("units", "ip_units", "default_chr", "default_num")) - - # get object and value from data.frame input {{{ - if (!nrow(l$value)) { - obj_dt <- data.table() - val_dt <- data.table() - } else { - obj <- l$value[, list(num = max(field_index)), by = c("rleid", "object_id", "class_name")] - - # verify class name - if (!all(obj$class_name %chin% idd_env$class$class_name[idf_env$object$class_id])) { - # get input with invalid class name - invld <- obj[!class_name %chin% idd_env$class$class_name[idf_env$object$class_id]] - abort("error_class_name", - paste0("Invalid class name ", collapse(unique(invld$class_name)), " found in input:\n", - dot_string(l$dot[J(unique(invld$rleid)), on = "rleid"]) - ) - ) +# del_idf_object {{{ +#' Delete existing objects +#' +#' @param idd_env An environment or list contains IDD tables including class, +#' field, and reference. +#' @param idf_env An environment or list contains IDF tables including object, +#' value, and reference. +#' @param dt_object A [data.table::data.table()] that contains object data. +#' Usually created using [expand_idf_dots_value()]. +#' @param ref_by If `TRUE`, objects whose fields refer to input objects +#' will also be deleted. Default: `FALSE`. +#' @param ref_to If `TRUE`, objects whose fields are referred by input +#' objects will also be deleted. Default: `FALSE`. +#' @param recursive If `TRUE`, relation searching is performed +#' recursively, in case that objects whose fields refer to target +#' object are also referred by another object, and also objects +#' whose fields are referred by target object are also referred +#' by another object. Default: `FALSE`. +#' @param force If `TRUE`, objects are deleted even if they are +#' referred by other objects. +#' @param level Validate level. Default: `eplusr_option("validate_level")`. +#' +#' @return The modified whole IDF data in a named list of 3 +#' [data.table::data.table()]s, i.e. `object`, `value` and `reference`. +#' +#' @keywords internal +#' @export +del_idf_object <- function (idd_env, idf_env, dt_object, ref_to = FALSE, ref_by = FALSE, + recursive = FALSE, force = FALSE, level = eplusr_option("validate_level")) { + chk <- level_checks(level) + + # stop if try to delete version + if (any(invld <- dt_object$class_id == 1L)) { + abort(paste0("Deleting 'Version' object is prohibited.\n", + paste0(dt_object[invld, sprintf(" #%s| Object ID [%i] --> Class 'Version'", + lpad(rleid, "0"), object_id)], collapse = "\n")), + "del_version") + } + if (!force) { + # stop attempting to delete required objects + if (chk$required_object && any(invld <- dt_object$class_id %in% idd_env$class[required_object == TRUE, class_id])) { + abort(paste0("Deleting a required object is prohibited. Invalid input:\n", + get_object_info(dt_object[invld], numbered = TRUE, collapse = "\n")), + "del_required") } + # stop if trying to delete unique object + if (chk$unique_object && nrow(invld <- dt_object[J(get_idd_class_unique(idd_env)$class_id), on = "class_id", nomatch = 0L])) { + abort(paste0("Existing unique object cannot be deleted. Invalid input:\n", + get_object_info(invld, numbered = TRUE, collapse = "\n")), + "del_unique") + } + } - # verify object id - obj_dt <- tryCatch(get_idf_object(idd_env, idf_env, obj$class_name, obj$object_id, "has_name"), - error_object_id = function (e) { - # get input with invalid class name - invld <- obj[J(e$value), on = "object_id"] - obj <- collapse(paste0(surround(invld$object_id), "(Class: ", surround(invld$class_name), ")"), NULL) - abort("error_object_id", - paste0("Invalid object id ", obj, " found in input:\n", - dot_string(l$dot[J(invld$rleid), on = "rleid"]) - ) - ) - } - ) + # get objects to be deleted + id_del <- dt_object$object_id - # reset by max field number per object - set(obj, NULL, "num", - pmax(idf_env$value[J(obj$object_id), on = "object_id", list(num = .N), by = "object_id"]$num, - obj$num - ) - ) - # reset rleid - set(obj_dt, NULL, c("rleid", "num"), list(obj$rleid, obj$num)) - - assert_can_do(idd_env, idf_env, l$dot, obj_dt, "set") - - # verify class name and add class id - val_dt <- tryCatch( - get_idf_value(idd_env, idf_env, object = obj$object_id, field = obj$num, - complete = TRUE, property = prop), - error_bad_field_index = function (e) { - # update rleid - e$data[, rleid := l$value$rleid[e$data$rleid]] - abort_bad_field("error_bad_field_index", "index", e$data) - } - ) + # always check if target objects are referred by others + dir <- if (ref_to) "all" else "ref_by" - # add input new values - set(val_dt, NULL, "rleid", l$value$rleid[val_dt$rleid]) - set(val_dt, NULL, c("new_value", "new_value_num", "defaulted", "type"), - l$value[val_dt, on = c("object_id", "field_index"), - .SD, .SDcols = c("value_chr", "value_num", "defaulted", "type") - ] - ) + depth <- if (recursive) NULL else 0L + rel <- get_idfobj_relation(idd_env, idf_env, id_del, direction = dir, + depth = depth, name = in_verbose(), class_ref = "both" + ) + + if (in_verbose()) { + msg <- paste0("Deleting object(s) [ID: ", paste(id_del, sep = ", ", collapse = ", "), "]") + } - # if input is character vectors, need to reset values since all of them - # are coerced regardless of field types - val_dt[type == 1L & type_enum > IDDFIELD_TYPE$real, `:=`(value_num = NA_real_, new_value_num = NA_real_)] - set(val_dt, NULL, "type", NULL) + id_ref_by <- c() - # reset rleid - set(val_dt, NULL, "rleid", - obj_dt[J(val_dt$rleid, val_dt$object_id), on = c("rleid", "object_id"), rleid] - ) + # ref by {{{ + # exclude invalid reference + if (nrow(rel$ref_by)) { + rel$ref_by <- rel$ref_by[!J(NA_integer_), on = "object_id"] - # add new value id - val_dt <- assign_new_id(idf_env, val_dt, "value", keep = TRUE) + # stop if objects are referred {{{ + # should be able to delete targets objects in at least one condition: + # 1. current validate level does not includ reference checking + # 2. want to delete both targets and referees + # 3. `force` is TRUE + if (chk$reference && !ref_by && !force && nrow(rel$ref_by)) { + rel$ref_by <- rel$ref_by[!J(id_del), on = "object_id"] - # delete unuseful columns - set(obj_dt, NULL, "num", NULL) + if (!eplusr_option("verbose_info")) { + rel$ref_by <- add_idf_relation_format_cols(idd_env, idf_env, rel$ref_by) + } + abort(paste0("Cannot delete object(s) that are referred by others:\n", + "\n", + paste0(" ", unlist(format_idf_relation(rel$ref_by, "ref_by")$fmt, use.names = FALSE), collapse = "\n") + ), "del_referenced") + } + # }}} - # order - setorderv(val_dt, c("rleid", "field_index")) + if (ref_by && nrow(rel$ref_by)) { + # check if objects that refer to targets are also referred by other + # objects + id_ref_by <- setdiff(unique(rel$ref_by$object_id), id_del) + id_src <- id_ref_by[id_ref_by %in% idf_env$reference$src_object_id] + if (!force && length(id_src)) { + id_ref_by <- setdiff(id_ref_by, id_src) + if (in_verbose()) { + if (length(id_ref_by)) { + msg <- c(msg, + paste0( + "Including object(s) [ID:", paste(id_ref_by, collapse = ", "), "] that refer to it, ", + "skipping object(s) [ID: ", paste0(id_src, collapse = ","), "] that is referred by other objects." + ) + ) + } else { + msg <- c(msg, + paste0("Skipping object(s) [ID: ", paste0(id_src, collapse = ","), "] that is referred by other objects.") + ) + } + } + } else { + if (in_verbose()) { + msg <- c(msg, + paste0("Including object(s) [ID:", paste(id_ref_by, collapse = ", "), "] that refer to it.") + ) + } + } + } } # }}} - # get object and value from character input {{{ - if (!length(l$parsed)) { - obj_chr <- data.table() - val_chr <- data.table() - } else { - obj_chr <- l$parsed$object - val_chr <- l$parsed$value - - # add class name - add_class_name(idd_env, obj_chr) - add_class_property(idd_env, obj_chr, "has_name") - - # check invalid class - if (!all(obj_chr$class_id %in% idf_env$object$class_id)) { - # get input with invalid class name - invld <- obj_chr[!class_id %in% idf_env$object$class_id] - set(invld, NULL, "class_name", idd_env$class$class_name[invld$class_id]) - abort("error_class_name", - paste0("Invalid class name ", collapse(unique(invld$class_name)), " found in input:\n", - dot_string(l$dot[J(unique(invld$rleid)), on = "rleid"]) - ) - ) - } + # if ref_to is TRUE and rel$ref_to has contents + # ref to {{{ + if (NROW(rel$ref_to)) { + # exclude invalid reference + rel$ref_to <- rel$ref_to[!J(NA_integer_), on = "src_object_id"] - # if all class are valid, each object in class that has name attribute - # should has a valid name - if (anyNA(obj_chr$object_name[obj_chr$has_name])) { - invld <- obj_chr[J(TRUE, NA_character_), on = c("has_name", "object_name")] - abort("error_missing_object_name", - paste0("When input is a character vector, object name should be given to locate which object to update. ", - "Missing object name for class ", collapse(unique(invld$class_name)), " found in input:\n", - dot_string(l$dot[J(unique(invld$rleid)), on = "rleid"]) - ) - ) - } + id_ref_to <- setdiff(unique(rel$ref_to$src_object_id), id_del) - # verify object name - obj_chr_out <- tryCatch( - get_idf_object(idd_env, idf_env, obj_chr$class_id, obj_chr$object_name_lower, "has_name", ignore_case = TRUE), - error_object_name_lower = function (e) { - # get input with invalid class name - invld <- obj_chr[J(e$value), on = "object_name_lower"] - obj_chr <- collapse(paste0(surround(invld$object_name), "(Class: ", surround(invld$class_name), ")"), NULL) - abort("error_object_name", - paste0("Invalid object name ", obj_chr, " found in input:\n", - dot_string(l$dot[J(invld$rleid), on = "rleid"]) + # check if objects that target refers to are also referred by other + # objects + id_src <- idf_env$reference[!J(id_del), on = "object_id"][ + J(unique(rel$ref_to$src_object_id)), on = "src_object_id", nomatch = 0L, unique(src_object_id) + ] + id_src <- setdiff(id_src, id_del) + if (!force && length(id_src)) { + id_ref_to <- setdiff(id_ref_to, id_src) + if (in_verbose()) { + if (length(id_ref_to)) { + msg <- c(msg, + paste0( + "Including object(s) [ID:", paste(id_ref_to, collapse = ", "), "] that is referred by it, ", + "skipping object(s) [ID: ", paste0(id_src, collapse = ","), "] that is also referred by other objects." + ) + ) + } else { + msg <- c(msg, + paste0("Skipping object(s) [ID: ", paste0(id_src, collapse = ","), "] that is also referred by other objects.") ) + } + } + } else { + if (in_verbose()) { + msg <- c(msg, + paste0("Including object(s) [ID:", paste(id_ref_by, collapse = ", "), "] that is referred by it.") ) } - ) - - # reset rleid - # keep the original rleid for error printing - obj_chr <- set(obj_chr_out, NULL, c("rleid", "has_name", "old_object_id"), - list(obj_chr$rleid, obj_chr$has_name, obj_chr$object_id) - ) - - # update object ID - set(val_chr, NULL, "object_id", obj_chr[J(val_chr$object_id), on = "old_object_id", object_id]) - set(obj_chr, NULL, "old_object_id", NULL) + } + } + # }}} - assert_can_do(idd_env, idf_env, l$dot, obj_chr, "set") + if (in_verbose() && + ((ref_to && NROW(rel$ref_to)) || (ref_by && NROW(rel$ref_by)) || + (force && (NROW(rel$ref_to) || NROW(rel$ref_by))))) { + msg <- paste0(c(msg, "", "Object relation is shown below:", ""), collapse = "\n") + msg_rel <- paste0(" ", capture.output(print.IdfRelation(rel)), collapse = "\n") + verbose_info(paste0(msg, msg_rel, collapse = "\n")) + } - # get field number to extract - set(obj_chr, NULL, "num", - pmax(val_chr[J(obj_chr$object_id), on = "object_id", list(num = .N), by = "object_id"]$num, - idf_env$value[J(obj_chr$object_id), on = "object_id", list(num = .N), by = "object_id"]$num - ) - ) + id_del <- if (NROW(rel$ref_to)) c(id_del, id_ref_by, id_ref_to) else c(id_del, id_ref_by) - # get all fields involved - val_ori <- tryCatch( - get_idf_value(idd_env, idf_env, object = obj_chr$object_id, field = obj_chr$num, - complete = TRUE, property = prop), - error_bad_field_index = function (e) { - # update rleid - e$data[, rleid := val_chr$rleid[obj_chr$rleid]] - abort_bad_field("error_bad_field_index", "index", e$data) - } - ) + # delete rows in object table + obj <- idf_env$object[!J(id_del), on = "object_id"] + val <- idf_env$value[!J(id_del), on = "object_id"] + ref <- idf_env$reference[J(id_del), on = "object_id", nomatch = 0L] - # add field defaults if possible - set(val_ori, NULL, "defaulted", FALSE) - # merge value columns - val_ori[J(val_chr$object_id, val_chr$field_id), on = c("object_id", "field_id"), - `:=`(new_value = val_chr$value_chr, new_value_num = val_chr$value_num, defaulted = is.na(val_chr$value_chr)) - ] + # NOTE: should keep invalid reference + # [J(id_del), on = "src_object_id", `:=`(src_object_id = NA_integer_, src_value_id = NA_integer_) - # correct rleid - val_chr <- val_ori - add_joined_cols(obj_chr, val_chr, "object_id", "rleid") + list(object = obj, value = val, reference = ref) +} +# }}} +# purge_idf_object {{{ +#' Purge not-used resource objects +#' +#' @param idd_env An environment or list contains IDD tables including class, +#' field, and reference. +#' @param idf_env An environment or list contains IDF tables including object, +#' value, and reference. +#' @param dt_object A [data.table::data.table()] that contains object data. +#' Usually created using [expand_idf_dots_value()]. +#' @param level Validate level. Default: `eplusr_option("validate_level")`. +#' +#' @return The modified whole IDF data in a named list of 3 +#' [data.table::data.table()]s, i.e. `object`, `value` and `reference`. +#' +#' @keywords internal +#' @export +purge_idf_object <- function (idd_env, idf_env, dt_object) { + # exclude objects that cannot be resources + src <- dt_object[J(unique(idd_env$reference$src_class_id)), on = "class_id", nomatch = 0L] - # clean - set(obj_chr, NULL, "num", NULL) + if (in_verbose()) { + norm <- dt_object[!J(src$class_id), on = "class_id"] + if (nrow(norm)) { + verbose_info("Non-resource objects are ignored:\n", get_object_info(norm, collapse = "\n")) + } } - # }}} - obj <- rbindlist(list(obj_dt, obj_chr), fill = TRUE) - val <- rbindlist(list(val_dt, val_chr), fill = TRUE) - setorderv(val, c("rleid", "object_id", "field_id")) + # get references + ref <- get_idf_relation(idd_env, idf_env, src$object_id, depth = 0L, + direction = "ref_by", class_ref = "both") - # in case try to update same object multiple times - assert_can_do(idd_env, idf_env, l$dot, obj, "set") + # get objects that can be removed directly + id_del <- setdiff(src$object_id, ref$src_object_id) - # exclude name field if it has been already set before in order to - # prevent name conflict checking error - val[is_name == TRUE & !is.na(value_chr) & is.na(new_value), - `:=`(required_field = FALSE) - ] + # take into account references inside inputs, i.e. an resource object can + # be purged if all objects referencing it can be purged and have already + # been captured in 'id_del' + id_rec <- setdiff( + # resources that are used by objects to be purged + ref[J(id_del), on = "object_id", nomatch = 0L, src_object_id], + # resources that are not used by objects to be purged + ref[!J(id_del), on = "object_id", src_object_id] + ) + + # should do above step again to catch the deepest resources + id_del <- c(id_del, id_rec) + id_rec <- setdiff( + # resources that are used by objects to be purged + ref[J(id_del), on = "object_id", nomatch = 0L, src_object_id], + # resources that are not used by objects to be purged + ref[!J(id_del), on = "object_id", src_object_id] + ) - # make sure rleid is unique - set(obj, NULL, "rleid", seq.int(nrow(obj))) - set(val, NULL, "rleid", rleid(val$rleid, val$object_id)) + id <- unique(c(id_del, id_rec)) - # assign default values if needed - if (.default) { - val <- assign_default_value(idd_env, idf_env, val) - set(val, NULL, c("default_chr", "default_num"), NULL) + if (!length(id)) { + verbose_info("None of specified object(s) can be purged. Skip.") + obj <- data.table() + val <- data.table() + ref <- data.table() } else { - # remove - val[defaulted == TRUE, `:=`(value_chr = NA_character_, value_num = NA_real_)] + verbose_info("Object(s) below have been purged:\n", + get_object_info(add_rleid(dt_object[J(id), on = "object_id"]), collapse = "\n")) + + # delete rows in object table + obj <- idf_env$object[J(id), on = "object_id"] + val <- idf_env$value[J(id), on = "object_id"] + ref <- idf_env$reference[J(id), on = "object_id", nomatch = 0L] } - # assign new values - val[!is.na(new_value) & defaulted == FALSE, `:=`(value_chr = new_value, value_num = new_value_num)] - set(val, NULL, c("new_value", "new_value_num"), NULL) + list(object = obj, value = val, reference = ref) +} +# }}} +# duplicated_idf_object {{{ +#' Determine duplicate objects +#' +#' @param idd_env An environment or list contains IDD tables including class, +#' field, and reference. +#' @param idf_env An environment or list contains IDF tables including object, +#' value, and reference. +#' @param dt_object A [data.table::data.table()] that contains object data. +#' Usually created using [expand_idf_dots_value()]. +#' +#' @return A same [data.table::data.table()] as input `dt_object` (updated by +#' reference) with appended logical column `duplicated` indicating the object is +#' a duplicated one or not. +#' +#' @keywords internal +#' @export +duplicated_idf_object <- function (idd_env, idf_env, dt_object) { + dt_value <- idf_env$value[J(dt_object$object_id), on = "object_id"] + add_field_property(idd_env, dt_value, c("field_index", "src_enum")) + add_joined_cols(dt_object, dt_value, "object_id", "class_id") - # assign new value id - val[value_id < 0L, value_id := new_id(idf_env$value, "value_id", .N)] + # change to lower case for comparison + set(dt_value, NULL, "value_chr_lower", tolower(dt_value$value_chr)) - # update object name - obj <- update_object_name(obj, val) - set(val, NULL, "is_name", NULL) - # add lower name - set(obj, NULL, "object_name_lower", stri_trans_tolower(obj$object_name)) + # should seperate resource objects and non-resource objects + set(dt_value, NULL, "is_resource", FALSE) + cls_rsrc <- dt_value[field_index == 1L & src_enum > IDDFIELD_SOURCE$none, unique(class_id)] + if (length(cls_rsrc)) dt_value[J(cls_rsrc), on = "class_id", is_resource := TRUE] - # delete fields - add_joined_cols(idd_env$class, val, "class_id", c("min_fields", "num_extensible")) - if (!.empty) val <- remove_empty_fields(val) + # get ID of objects to keep and delete + dup <- rbindlist(lapply( + split(dt_value[, .SD, .SDcols = c("class_id", "object_id", "field_index", + "value_chr_lower", "is_resource")], by = "class_id"), + function(d) { + # dcast to compare + dd <- data.table::dcast(d, class_id + object_id ~ field_index, value.var = "value_chr_lower") - # validate - assert_valid(idd_env, idf_env, obj, val, action = "set") + dd[, list(class_id = class_id[[1L]], object_id = object_id[[1L]], object_id_dup = list(object_id[-1L])), + by = c(setdiff(names(dd), c("class_id", "object_id", "1"[d$is_resource[[1L]]])))][ + , list(class_id, object_id, object_id_dup)] + } + ))[, lapply(.SD, unlist), by = c("class_id", "object_id")] - list(object = obj[, .SD, .SDcols = names(idf_env$object)], - value = val[, .SD, .SDcols = names(idf_env$value)], - reference = update_value_reference(idd_env, idf_env, obj, val) - ) + set(dt_object, NULL, "duplicated", FALSE) + if (nrow(dup)) dt_object[J(dup$object_id_dup), on = "object_id", duplicated := TRUE] + + dt_object } # }}} -# search_idf_value {{{ -search_idf_value <- function (idd_env, idf_env, pattern, class = NULL, ignore.case = FALSE, - perl = FALSE, fixed = FALSE, useBytes = FALSE) { - if (!is.null(class) && anyDuplicated(class)) { - abort("error_search_object_dup_class", - "Class should not contain any duplication.", class = class - ) - } - - val <- get_idf_value(idd_env, idf_env, class) - - val <- val[grepl(pattern, value_chr, ignore.case = ignore.case, perl = perl, - fixed = fixed, useBytes = useBytes) - ] +# unique_idf_object {{{ +#' Remove duplicate objects +#' +#' @param idd_env An environment or list contains IDD tables including class, +#' field, and reference. +#' @param idf_env An environment or list contains IDF tables including object, +#' value, and reference. +#' @param dt_object A [data.table::data.table()] that contains object data. +#' Usually created using [expand_idf_dots_value()]. +#' +#' @return The modified whole IDF data in a named list of 3 +#' [data.table::data.table()]s, i.e. `object`, `value` and `reference`. +#' +#' @keywords internal +#' @export +unique_idf_object <- function (idd_env, idf_env, dt_object) { + dup <- duplicated_idf_object(idd_env, idf_env, dt_object) - if (!nrow(val)) { - verbose_info("No matched result found.") - return(invisible()) + if (!any(dup$duplicated)) { + verbose_info("None duplicated objects found. Skip.") + return(list(object = data.table(), value = data.table(), reference = data.table())) } - val -} -# }}} -# replace_idf_value {{{ -replace_idf_value <- function (idd_env, idf_env, pattern, replacement, - class = NULL, ignore.case = FALSE, - perl = FALSE, fixed = FALSE, useBytes = FALSE) { - if (!is.null(class) && anyDuplicated(class)) { - abort("error_search_object_dup_class", - "Class should not contain any duplication.", class = class - ) - } + obj <- dup[J(TRUE), on = "duplicated", .SDcols = -"duplicated"] + val <- get_idf_value(idd_env, idf_env, object = obj$object_id) - prop <- c("units", "ip_units", "is_name", "required_field", "src_enum", "type_enum", "extensible_group") + # get referenced field index of object to be deleted + ref <- get_idf_relation(idd_env, idf_env, object_id = obj$object_id, direction = "ref_by", depth = 0L) + ref[val, on = c("src_object_id" = "object_id", "src_value_id" = "value_id"), field_index := i.field_index] + # update the referenced object id + ref[dup, on = c("src_object_id" = "object_id_dup"), src_object_id := i.object_id] + # update the reference value id + ref[val, on = c("src_object_id" = "object_id", "field_index"), `:=`( + src_value_id = i.value_id, src_value_chr = i.value_chr, + src_value_num = i.value_num + )] - val <- get_idf_value(idd_env, idf_env, class, property = prop) + # update referenced value + idf_env$value[ref, on = c("object_id", "value_id"), `:=`( + value_chr = i.src_value_chr, value_num = i.src_value_num + )] + # update reference dict + idf_env$reference[ref, on = c("object_id", "value_id"), `:=`( + src_object_id = i.src_object_id, src_value_id = i.src_value_id + )] - val <- val[grepl(pattern, value_chr, ignore.case = ignore.case, perl = perl, - fixed = fixed, useBytes = useBytes) - ] + if (eplusr::eplusr_option("verbose_info")) { + dup[obj, on = "object_id", `:=`(class_name = i.class_name, object_name = i.object_name)] + set(dup, NULL, "merged", get_object_info(dup, numbered = FALSE, prefix = "")) - if (!nrow(val)) { - verbose_info("No matched result found.") - return(invisible()) - } + setnames(dup, c("object_id", "object_id_dup"), c("merged_object_id", "object_id")) + dup[obj, on = "object_id", `:=`(object_name = i.object_name)] + dup[, by = c("class_id", "merged_object_id"), removed := get_object_info(.SD, c("id", "name"), numbered = TRUE)] - set(val, NULL, "value_chr", - gsub(pattern, replacement, val$value_chr, ignore.case = ignore.case, - perl = perl, fixed = fixed, useBytes = useBytes - ) - ) - set(val, NULL, "value_num", suppressWarnings(as.numeric(val$value_chr))) - set(val, NULL, "defaulted", FALSE) + msg <- dup[, by = c("class_id", "merged_object_id"), list(list( + sprintf("Duplications for %s have been removed:\n %s", + merged[[1L]], paste0(removed, collapse = "\n ") + ) + ))]$V1 - obj <- get_idf_object(idd_env, idf_env, object = unique(val$object_id)) - # update object name - obj <- update_object_name(obj, val) + setnames(dup, c("merged_object_id", "object_id"), c("object_id", "object_id_dup")) - assert_valid(idd_env, idf_env, obj, val, action = "set") + verbose_info(paste0(unlist(msg), collapse = "\n\n")) + } - list(object = obj, value = val, - reference = update_value_reference(idd_env, idf_env, obj, val) + list(object = idf_env$object[!J(dup$object_id_dup), on = "object_id"], + value = idf_env$value[!J(dup$object_id_dup), on = "object_id"], + reference = idf_env$reference ) } # }}} -# get_object_input {{{ -get_object_input <- function (idd_env, idf_env, l, property = NULL, keep_duplicate = TRUE) { - # match - if (nrow(l$id)) { - obj_id <- get_idf_object(idd_env, idf_env, object = l$id$object_id, property = property) - obj_id <- cbind( - set(obj_id, NULL, "rleid", NULL), - l$id[, .SD, .SDcols = c("rleid", "object_rleid", "new_object_name")] +# rename_idf_object {{{ +#' Rename existing objects +#' +#' @param idd_env An environment or list contains IDD tables including class, +#' field, and reference. +#' @param idf_env An environment or list contains IDF tables including object, +#' value, and reference. +#' @param dt_object A [data.table::data.table()] that contains object data. +#' Usually created using [expand_idf_dots_name()]. +#' @param level Validate level. Default: `eplusr_option("validate_level")`. +#' +#' @return The modified object data in a named list of 3 +#' [data.table::data.table()]s, i.e. `object`, `value`, `reference`. +#' +#' @note +#' * The `reference` table in the returned list only contains the reference-by +#' map, indicating which values have been updated in the main `value` table in +#' `idf_env`. +#' * The `value` table in input `idf_env` could be modified if input objects are +#' referenced by other objects. The `reference` table in the returned list +#' tells the id actual values modified +#' +#' @keywords internal +#' @export +rename_idf_object <- function (idd_env, idf_env, dt_object, level = eplusr_option("validate_level")) { + chk <- level_checks(level) + # stop if modifying same object multiple times + if (anyDuplicated(dt_object$object_id)) { + abort(paste0("Cannot modify same object multiple times. Invalid input:\n", + get_object_info(dt_object[duplicated(object_id)], collapse = "\n")), + "rename_same" ) - } else { - obj_id <- idf_env$object[0L] } - if (nrow(l$name)) { - obj_nm <- get_idf_object(idd_env, idf_env, object = l$name$object_name, - property = property, ignore_case = TRUE + # stop if no new name is provided when renaming + if (!has_names(dt_object, "new_object_name")) { + abort(paste0("Please give new object names. Invalid input:\n", + get_object_info(dt_object, collapse = "\n")), + "rename_no_new_name" ) - obj_nm <- cbind( - set(obj_nm, NULL, "rleid", NULL), - l$name[, .SD, .SDcols = c("rleid", "object_rleid", "new_object_name")] + } + if (anyNA(dt_object$new_object_name)) { + abort(paste0("Please give new object names. Invalid input:\n", + get_object_info(dt_object[is.na(new_object_name)], collapse = "\n")), + "rename_no_new_name" ) - } else { - obj_nm <- idf_env$object[0L] } - # remain the input order - obj <- rbindlist(list(obj_id, obj_nm), fill = TRUE) - setorderv(obj, "rleid") - - if (keep_duplicate) return(obj) + obj <- make_idf_object_name(idd_env, idf_env, dt_object) + set(obj, NULL, c("object_name", "object_name_lower"), NULL) + setnames(obj, c("new_object_name", "new_object_name_lower"), c("object_name", "object_name_lower")) - unique(obj, by = "object_id") -} -# }}} -# get_idf_object_from_multi_level {{{ -get_idf_object_from_multi_level <- function (idd_env, idf_env, object = NULL, class = NULL, group = NULL, empty = FALSE) { - obj <- data.table() + # extract value table + val <- get_idf_value(idd_env, idf_env, object = obj$object_id, property = "is_name") - if (is.null(object) && is.null(class) && is.null(group)) { - if (empty) { - obj <- get_idf_object(idd_env, idf_env) - } else { - abort("error_empty_purge_input", "'object', 'class' and 'group' canot all be empty.") - } - } + # assign new object name + set(obj, NULL, "has_name", TRUE) + val[obj, on = c("object_id", is_name = "has_name"), value_chr := i.object_name] - if (!is.null(object)) { - obj <- get_idf_object(idd_env, idf_env, object = object, ignore_case = TRUE) - } - if (!is.null(class)) { - obj <- rbindlist(list(obj, get_idf_object(idd_env, idf_env, class = class)), use.names = TRUE) + # validate + # There are some special fields that could both reference to other objects + # and be referenced by other objects. + # For instance, `1: Zone Name` in `AirflowNetwork:MultiZone:Zone`. It + # references to values from `Zone` names and also can be referenced by + # `3: Zone Name` in `AirflowNetwork:IntraZone:Node`. + # In this case, it is also needed to check if new names are valid. + ref_to <- idf_env$reference[J(val$value_id[val$is_name], IDDFIELD_SOURCE$field), on = c("value_id", "src_enum"), nomatch = 0L] + if (nrow(ref_to) && chk$reference) { + validity <- validate_on_level(idd_env, idf_env, obj, val, level = chk) + assert_valid(validity, "rename") } - if (!is.null(group)) { - assert(is.character(group)) - - add_class_property(idd_env, idf_env$object, "group_name") - - grp_in <- recognize_input(group, "group") - obj_grp <- join_from_input(idf_env$object, grp_in, "object_id") - # clean - set(idf_env$object, NULL, "group_name", NULL) - - # add class name to make sure results have same columns as 'get_idf_object()' - set(obj_grp, NULL, "group_name", NULL) - add_class_property(idd_env, obj_grp, "class_name") + # value reference + # extract value reference and update other objects using its name + # only consider value reference + ref_by <- idf_env$reference[J(val$value_id[val$is_name], IDDFIELD_SOURCE$field), on = c("src_value_id", "src_enum"), nomatch = 0L] - obj <- rbindlist(list(obj, obj_grp), use.names = TRUE) + # update values in main table + if (nrow(ref_by)) { + add_joined_cols(val, ref_by, c(src_value_id = "value_id"), c(src_value_chr = "value_chr")) + idf_env$value[ref_by, on = "value_id", `:=`(value_chr = i.src_value_chr)] + set(ref_by, NULL, "src_value_chr", NULL) } - obj <- unique(obj, by = "object_id") + set(obj, NULL, "has_name", NULL) + set(val, NULL, "is_name", NULL) + setcolorder(obj, c("rleid", "class_id", "class_name", "object_id", "object_name", "object_name_lower", "comment")) + setcolorder(val, c("rleid", "class_id", "class_name", "object_id", "object_name", "field_id", "field_index", "field_name", "value_id", "value_chr")) - # reset rleid - add_rleid(obj) + list(object = obj, value = val, reference = ref_by) } # }}} -# fill_unnamed_field_index {{{ -fill_unnamed_field_index <- function (idd_env, idf_env, val) { - # match field names and get field index - val_nm <- val[!is.na(field_name)] - val_nm_fld <- get_idd_field(idd_env, val_nm$class_id, val_nm$field_name) - set(val_nm_fld, NULL, "rleid", val_nm$rleid) - set(val, NULL, "field_index", - val_nm_fld[val, on = c("rleid", field_in = "field_name"), field_index] - ) - val[, field_index := { - # whether field index is detected by using field name - no_nm <- is.na(field_index) - # how many field indices - s <- seq_along(field_index) - # no field name is given - if (all(no_nm)) { - s - # some field name is given - } else { - # what are left after excluding detected field indices - idx <- setdiff(s, field_index[!no_nm]) - field_index[no_nm] <- idx[seq.int(sum(no_nm))] - field_index - } - }, by = "rleid"] - set(val, NULL, "field_name", NULL) - - val -} -# }}} # remove_empty_fields {{{ -remove_empty_fields <- function (val) { - if (!val[required_field == FALSE & is.na(value_chr) & min_fields < field_index, .N]) return(val) +remove_empty_fields <- function (idd_env, idf_env, dt_value) { + if (!has_names(dt_value, "required_field")) { + add_field_property(idd_env, dt_value, "required_field") + on.exit(set(dt_value, NULL, "required_field", NULL), add = TRUE) + } + if (!has_names(dt_value, "min_fields")) { + add_class_property(idd_env, dt_value, "min_fields") + on.exit(set(dt_value, NULL, "min_fields", NULL), add = TRUE) + } + + if (!dt_value[required_field == FALSE & is.na(value_chr) & min_fields < field_index, .N]) return(dt_value) # fields that can be deleted: # 1. not required # 2. do not have value # 3. field index should be consecutive from the end # 4. should be a whole extensible group - val[, rev_field_rleid := rev(field_index), by = "object_id"] + dt_value[, rev_field_rleid := rev(field_index), by = "object_id"] + on.exit(set(dt_value, NULL, "rev_field_rleid", NULL), add = TRUE) + + if (!has_names(dt_value, "extensible_group")) { + add_field_property(idd_env, dt_value, "extensible_group") + on.exit(set(dt_value, NULL, "extensible_group", NULL), add = TRUE) + } + if (!has_names(dt_value, "num_extensible")) { + add_class_property(idd_env, dt_value, "num_extensible") + on.exit(set(dt_value, NULL, "num_extensible", NULL), add = TRUE) + } - id_del <- val[required_field == FALSE & is.na(value_chr) & field_index > min_fields, + id_del <- dt_value[required_field == FALSE & is.na(value_chr) & field_index > min_fields, { # skip if no field found or field index not consecutive if (!.N || !length(idx <- rev_field_rleid[rev_field_rleid == rev(seq_len(.N))])) { @@ -3169,13 +3296,13 @@ remove_empty_fields <- function (val) { by = c("object_id") ] - if (any(!is.na(id_del$value_id))) val <- val[!id_del, on = "value_id"] + if (any(!is.na(id_del$value_id))) dt_value <- dt_value[!id_del, on = "value_id"] - val + dt_value } # }}} # remove_duplicated_objects {{{ -remove_duplicated_objects <- function (idd_env, idf_env, obj, val) { +remove_duplicated_objects <- function (idd_env, idf_env, dt_object, dt_value) { # extract all object values in the same class # in order to distinguish input from original IDF, set id of objects # from IDF Editor to negative also note that dcast will automatically @@ -3183,15 +3310,15 @@ remove_duplicated_objects <- function (idd_env, idf_env, obj, val) { # bottom. add_joined_cols(idd_env$field, idf_env$value, "field_id", "field_index") add_joined_cols(idf_env$object, idf_env$value, "object_id", "class_id") - val_idf <- idf_env$value[J(unique(obj$class_id)), on = "class_id", + val_idf <- idf_env$value[J(unique(dt_object$class_id)), on = "class_id", list(class_id, object_id = -object_id, field_index, value_chr), nomatch = 0L] set(idf_env$value, NULL, c("class_id", "field_index"), NULL) # if there are no objects in the same class - if (!nrow(val_idf)) return(list(object = obj, value = val)) + if (!nrow(val_idf)) return(list(object = dt_object, value = dt_value)) # get all input value - val_in <- val[, list(class_id, object_id, field_index, value_chr)] + val_in <- dt_value[, list(class_id, object_id, field_index, value_chr)] # compare in case-insensitive way val_d <- rbindlist(list(val_idf, val_in), fill = TRUE) @@ -3211,62 +3338,70 @@ remove_duplicated_objects <- function (idd_env, idf_env, obj, val) { verbose_info( "Duplicated objects in input, or objects in input that are the same in current IDF have been removed:\n", { - del <- obj[J(id_dup), on = "object_id"] + del <- dt_object[J(id_dup), on = "object_id"] setorderv(del, "rleid") get_object_info(del, c("name", "class"), collapse = "\n", name_prefix = FALSE) } ) - obj <- obj[!J(id_dup), on = "object_id"] - val <- val[!J(id_dup), on = "object_id"] + dt_object <- dt_object[!J(id_dup), on = "object_id"] + dt_value <- dt_value[!J(id_dup), on = "object_id"] } - list(object = obj, value = val) -} -# }}} -# get_idf_duplicated_object {{{ -get_idf_duplicated_object <- function (idd_env, idf_env, object = NULL, class = NULL, group = NULL) { - obj <- get_idf_object_from_multi_level(idd_env, idf_env, object, class, group, empty = TRUE) - - val <- get_idf_value(idd_env, idf_env, object = obj$object_id, align = TRUE, - property = "src_enum") - - # change to lower case for comparison - set(val, NULL, "value_chr_lower", tolower(val$value_chr)) - - # should seperate resource objects and non-resource objects - set(val, NULL, "is_resource", FALSE) - cls_rsrc <- val[field_index == 1L & src_enum > IDDFIELD_SOURCE$none, unique(class_id)] - if (length(cls_rsrc)) val[J(cls_rsrc), on = "class_id", is_resource := TRUE] - - # get ID of objects to keep and delete - dup <- lapply( - split(val[, .SD, .SDcols = c("class_id", "object_id", "field_index", - "value_chr_lower", "is_resource")], by = "class_id"), - function(d) { - # dcast to compare - dd <- data.table::dcast(d, class_id + object_id ~ field_index, value.var = "value_chr_lower") - - dd[, list(class_id = class_id[[1L]], object_id = object_id[[1L]], - object_id_dup = list(object_id[-1L]) - ), by = c(setdiff(names(dd), c("class_id", "object_id", "1"[d$is_resource[[1L]]])))][ - , list(class_id, object_id, object_id_dup)] - } - ) - dup <- data.table::rbindlist(dup)[, lapply(.SD, unlist), by = c("class_id", "object_id")] - - list(object = obj, value = val, duplicated = dup) + list(object = dt_object, value = dt_value) } # }}} # REFERENCES # get_idf_relation {{{ +#' Extract object and value reference relations +#' +#' @param idd_env An environment or list contains IDD tables including class, +#' field, and reference. +#' @param idf_env An environment or list contains IDF tables including object, +#' value, and reference. +#' @param object_id An integer vector of valid object IDs. If `NULL`, all object +#' IDs in current IDF will be used. +#' @param value_id An integer vector of valid value IDs. If `NULL`, all value +#' IDs in current IDF will be used. +#' @param direction Reference relation direction. Should be one of `"ref_to"` +#' and `"ref_by"`. Default: `"ref_to"`. +#' @param depth Recursive reference relation depth. `NULL` means infinite. +#' Default: `0L`. +#' @param name If `TRUE`, all class, object, field value ID and name columns +#' will be added and a `IdfRelationTo` or `IdfRelationBy` object is +#' returned with customized printing method. Default: `FALSE`. +#' @param object An integer vector of valid object IDs or a character vector +#' of valid object names to specify the targeting relation objects. +#' Default: `NULL`. +#' @param class An integer vector of valid class indexes or a character vector +#' of valid class names to specify the targeting relation classes. +#' Default: `NULL`. +#' @param group A character vector of valid group names to specify the targeting +#' relation groups. Default: `NULL`. +#' @param keep_all If `TRUE`, all input ID are kept. Otherwise, only input IDs +#' that have relations are kept. Default: `FALSE`. +#' @param class_ref Specify how to handle class-name-references. There are 3 +#' options in total, i.e. `"none"`, `"both"` and `"all"`, with `"both"` +#' being the default. +#' * `"none"`: just ignore class-name-references. +#' * `"both"`: only include class-name-references if this object also +#' reference field values of the same one. This is the default option. +#' * `"all"`: include all class-name-references. This is the most aggressive +#' option. +#' @param match_all If `TRUE`, relation search will continue even though one +#' relation has been found. If `FALSE`, searching is stopped whenever one +#' relation is found in specified classes/groups. Default: `FALSE`. +#' +#' @return A data.table. +#' +#' @keywords internal +#' @export get_idf_relation <- function (idd_env, idf_env, object_id = NULL, value_id = NULL, - depth = NULL, name = FALSE, direction = c("ref_to", "ref_by"), - object = NULL, class = NULL, group = NULL, - keep_all = FALSE, class_ref = c("both", "none", "all"), - match_all = FALSE) { - assert(is.null(depth) || is_count(depth, TRUE)) + direction = c("ref_to", "ref_by"), depth = 0L, name = FALSE, + object = NULL, class = NULL, group = NULL, keep_all = FALSE, + class_ref = c("both", "none", "all"), match_all = FALSE) { + assert_count(depth, null.ok = TRUE) if (is.null(depth)) depth <- Inf direction <- match.arg(direction) class_ref <- match.arg(class_ref) @@ -3291,7 +3426,7 @@ get_idf_relation <- function (idd_env, idf_env, object_id = NULL, value_id = NUL # if object IDs are given } else { # make sure object IDs and value ids have the same length - assert(have_same_len(object_id, value_id)) + assert_same_len(object_id, value_id) obj_id <- object_id val_id <- value_id @@ -3372,6 +3507,8 @@ get_idf_relation <- function (idd_env, idf_env, object_id = NULL, value_id = NUL # keep all input if (keep_all) ref <- combine_input_and_relation(val, ref, "idf", direction) + setcolorder(ref, c("object_id", "value_id", "src_object_id", "src_value_id", "src_enum", "dep")) + if (!name) return(ref) ref <- add_idf_relation_format_cols(idd_env, idf_env, ref) @@ -3411,114 +3548,126 @@ add_idf_relation_format_cols <- function (idd_env, idf_env, ref) { ref } # }}} -# update_value_reference {{{ -update_value_reference <- function (idd_env, idf_env, object, value) { - # If field reference has been handled and updated during validation, only - # check sources - if (level_checks()$reference) { - set(object, NULL, "rleid", -object$rleid) - - # update object id as new object id during validation - idf_env$reference[object, on = c("object_id" = "rleid"), object_id := i.object_id] - idf_env$reference[object, on = c("src_object_id" = "rleid"), src_object_id := i.object_id] - - # if have new sources - if (any(value$src_enum > IDDFIELD_SOURCE$none)) { - idf_env <- update_referenced_value(idd_env, idf_env, value) - idf_env$value <- add_field_property(idd_env, idf_env$value, "type_enum") - val <- value - new_ref <- get_value_reference_map(idd_env$reference, - value[!J(idf_env$value$value_id), on = "value_id"], - idf_env$value[!J(val$value_id), on = "value_id"], all = FALSE - ) - set(idf_env$value, NULL, "type_enum", NULL) - if (nrow(new_ref)) { - ref <- rbindlist(list(idf_env$reference, new_ref)) - } else { - ref <- idf_env$reference - } - } else { - ref <- idf_env$reference - } - } else { - idf_env$value <- add_field_property(idd_env, idf_env$value, c("src_enum", "type_enum")) - if (any(value$type_enum == IDDFIELD_TYPE$object_list)) { - new_ref <- TRUE - val_ref <- append_dt(idf_env$value, value, "value_id") - } else { - new_ref <- FALSE - val_ref <- idf_env$value - } - - # add class name - set(idf_env$value, NULL, "class_id", idf_env$object[J(idf_env$value$object_id), on = "object_id", class_id]) - idf_env$value <- add_class_name(idd_env, idf_env$value) - if (any(value$src_enum > IDDFIELD_SOURCE$none)) { - idf_env <- update_referenced_value(idd_env, idf_env, value) - - new_src <- TRUE - val_src <- append_dt(idf_env$value, value, "value_id") - } else { - new_src <- FALSE - val_src <- idf_env$value - } - - if (!new_ref && !new_src) { - ref <- idf_env$reference - } else { - ref <- get_value_reference_map(idd_env$reference, val_src, val_ref) - } - set(idf_env$value, NULL, c("class_id", "class_name", "src_enum", "type_enum"), NULL) - } - - ref -} -# }}} -# update_referenced_value {{{ -update_referenced_value <- function (idd_env, idf_env, value) { - ref <- find_value_reference(idd_env, idf_env, value[src_enum > IDDFIELD_SOURCE$none, value_id]) - - if (!nrow(ref)) return(idf_env) - - # get actual source value - ref[value, on = c("src_value_id" = "value_id"), `:=`( - value_chr = i.value_chr, value_num = i.value_num, class_name = i.class_name - )] - ref[J(IDDFIELD_SOURCE$class), on = "src_enum", `:=`(value_chr = class_name, value_num = NA_real_)] - - # update value - idf_env$value[ref, on = "value_id", `:=`(value_chr = i.value_chr, value_num = i.value_num)] - - idf_env -} -# }}} -# find_value_reference {{{ -find_value_reference <- function (idd_env, idf_env, value_id = NULL, only_top = TRUE) { - id <- value_id - - if (!length(id)) return(idf_env$reference[0L]) - - cur_ref <- idf_env$reference[J(id), on = "src_value_id", nomatch = 0L] - - ref <- cur_ref[0L] - while(nrow(cur_ref) > 0L) { - ref <- rbindlist(list(ref, cur_ref)) - next_ref <- idf_env$reference[J(unique(cur_ref$value_id)), on = "src_value_id", nomatch = 0L] - # make sure always use the top level value id - if (only_top) next_ref[cur_ref, on = c("src_value_id" = "value_id"), src_value_id := i.value_id] - cur_ref <- next_ref - } - - ref -} -# }}} +# # update_value_reference {{{ +# update_value_reference <- function (idd_env, idf_env, object, value) { +# # If field reference has been handled and updated during validation, only +# # check sources +# if (level_checks()$reference) { +# set(object, NULL, "rleid", -object$rleid) + +# # update object id as new object id during validation +# idf_env$reference[object, on = c("object_id" = "rleid"), object_id := i.object_id] +# idf_env$reference[object, on = c("src_object_id" = "rleid"), src_object_id := i.object_id] + +# # if have new sources +# if (any(value$src_enum > IDDFIELD_SOURCE$none)) { +# idf_env <- update_referenced_value(idd_env, idf_env, value) +# idf_env$value <- add_field_property(idd_env, idf_env$value, "type_enum") +# val <- value +# new_ref <- get_value_reference_map(idd_env, +# value[!J(idf_env$value$value_id), on = "value_id"], +# idf_env$value[!J(val$value_id), on = "value_id"], all = FALSE +# ) +# set(idf_env$value, NULL, "type_enum", NULL) +# if (nrow(new_ref)) { +# ref <- rbindlist(list(idf_env$reference, new_ref)) +# } else { +# ref <- idf_env$reference +# } +# } else { +# ref <- idf_env$reference +# } +# } else { +# idf_env$value <- add_field_property(idd_env, idf_env$value, c("src_enum", "type_enum")) +# if (any(value$type_enum == IDDFIELD_TYPE$object_list)) { +# new_ref <- TRUE +# val_ref <- append_dt(idf_env$value, value, "value_id") +# } else { +# new_ref <- FALSE +# val_ref <- idf_env$value +# } + +# # add class name +# set(idf_env$value, NULL, "class_id", idf_env$object[J(idf_env$value$object_id), on = "object_id", class_id]) +# idf_env$value <- add_class_name(idd_env, idf_env$value) +# if (any(value$src_enum > IDDFIELD_SOURCE$none)) { +# idf_env <- update_referenced_value(idd_env, idf_env, value) + +# new_src <- TRUE +# val_src <- append_dt(idf_env$value, value, "value_id") +# } else { +# new_src <- FALSE +# val_src <- idf_env$value +# } + +# if (!new_ref && !new_src) { +# ref <- idf_env$reference +# } else { +# ref <- get_value_reference_map(idd_env, val_src, val_ref) +# } +# set(idf_env$value, NULL, c("class_id", "class_name", "src_enum", "type_enum"), NULL) +# } + +# ref +# } +# # }}} +# # update_referenced_value {{{ +# update_referenced_value <- function (idd_env, idf_env, value) { +# ref <- find_value_reference(idd_env, idf_env, value[src_enum > IDDFIELD_SOURCE$none, value_id]) + +# if (!nrow(ref)) return(idf_env) + +# # get actual source value +# ref[value, on = c("src_value_id" = "value_id"), `:=`( +# value_chr = i.value_chr, value_num = i.value_num, class_name = i.class_name +# )] +# ref[J(IDDFIELD_SOURCE$class), on = "src_enum", `:=`(value_chr = class_name, value_num = NA_real_)] + +# # update value +# idf_env$value[ref, on = "value_id", `:=`(value_chr = i.value_chr, value_num = i.value_num)] + +# idf_env +# } +# # }}} +# # find_value_reference {{{ +# find_value_reference <- function (idd_env, idf_env, value_id = NULL, only_top = TRUE) { +# id <- value_id + +# if (!length(id)) return(idf_env$reference[0L]) + +# cur_ref <- idf_env$reference[J(id), on = "src_value_id", nomatch = 0L] + +# ref <- cur_ref[0L] +# while(nrow(cur_ref) > 0L) { +# ref <- rbindlist(list(ref, cur_ref)) +# next_ref <- idf_env$reference[J(unique(cur_ref$value_id)), on = "src_value_id", nomatch = 0L] +# # make sure always use the top level value id +# if (only_top) next_ref[cur_ref, on = c("src_value_id" = "value_id"), src_value_id := i.value_id] +# cur_ref <- next_ref +# } + +# ref +# } +# # }}} # NODES # get_idf_node_relation {{{ +#' Extract node relations +#' +#' @inheritParams get_idf_relation +#' +#' @return A data.table. +#' +#' @keywords internal +#' @export get_idf_node_relation <- function (idd_env, idf_env, object_id = NULL, value_id = NULL, object = NULL, class = NULL, group = NULL, name = FALSE, keep_all = FALSE, depth = 0L) { - assert(!is.null(object_id) || !is.null(value_id)) + assert( + check_integerish(object_id, any.missing = FALSE), + check_integerish(value_id, any.missing = FALSE) + ) + assert_count(depth, null.ok = TRUE) if (is.null(depth)) depth <- Inf # extract all node data @@ -3549,7 +3698,7 @@ get_idf_node_relation <- function (idd_env, idf_env, object_id = NULL, value_id # if object IDs are given } else { # make sure object IDs and value ids have the same length - assert(have_same_len(object_id, value_id)) + assert_same_len(object_id, value_id) obj_id <- object_id val_id <- value_id @@ -3671,27 +3820,72 @@ get_idf_node_relation <- function (idd_env, idf_env, object_id = NULL, value_id # IDF Editor Integration # read_idfeditor_copy {{{ -read_idfeditor_copy <- function (version = NULL, in_ip = FALSE) { +#' Parse objects from IDF Editor +#' +#' @param idd_env An environment or list contains IDD tables including class, +#' field, and reference. +#' @param idf_env An environment or list contains IDF tables including object, +#' value, and reference. +#' @param version The version of IDF file open by IDF Editor, e.g. `8.6`, +#' `"8.8.0"`. If `NULL`, assume that the file has the same +#' version as current Idf object. Default: `NULL`. +#' @param in_ip Set to `TRUE` if the IDF file is open with `Inch-Pound` +#' view option toggled. Numeric values will automatically +#' converted to SI units if necessary. Default: `FALSE`. +#' +#' @note +#' References in the input is not parsed and `reference` in the returned list is +#' always a zero-row table. +#' +#' @return The copyied object data from IDF Editor in a named list of 3 +#' [data.table::data.table()]s, i.e. `object`, `value` and `reference`. +#' +#' @keywords internal +#' @export +read_idfeditor_copy <- function (idd_env, idf_env, version = NULL, in_ip = FALSE) { # nocov start if (!is_windows()) { - abort("error_not_on_windows", "Currently $paste() can only work on Windows platform.") + abort("Currently 'read_idfeditor_copy()' can only work on Windows platform.") } text <- readLines("clipboard", warn = FALSE) if (length(text) != 1L || !stringi::stri_startswith_fixed(text, "IDF,")) { - abort("error_clipboard_string", "Failed to find contents copied from IDF Editor.") + abort("Failed to find contents copied from IDF Editor.") } - text <- gsub("([,;])", "\\1\n", stri_sub(text, 5L)) + text <- stringi::stri_replace_all_regex(stri_sub(text, 5L), "([,;])", "$1\n") if (isTRUE(in_ip)) { text <- paste0("!-Option SortedOrder ViewInIPunits\n", text) } # ignore the warning of using given IDD - withCallingHandlers(parse_idf_file(text, idd = version, ref = FALSE), - warning_given_idd_used = function (w) invokeRestart("muffleWarning") + parsed <- withCallingHandlers(parse_idf_file(text, idd = version, ref = FALSE), + eplusr_warning = function (w) invokeRestart("muffleWarning") ) -} + + # add class name + add_class_name(idd_env, parsed$object) + # add class id and field index + add_joined_cols(parsed$object, parsed$value, "object_id", c("class_id", "class_name")) + add_joined_cols(idd_env$field, parsed$value, "field_id", c("field_index", "field_name")) + + # remove version object + obj_ver <- parsed$object[class_name == "Version", object_id] + parsed$object <- parsed$object[!J(obj_ver), on = "object_id"] + parsed$value <- parsed$value[!J(obj_ver), on = "object_id"] + + # add rleid for validation and message printing + add_rleid(parsed$object) + add_joined_cols(parsed$object, parsed$value, "object_id", c("rleid", "object_name")) + + # remove empty fields + parsed$value <- remove_empty_fields(idd_env, idf_env, parsed$value) + + setcolorder(parsed$object, c("rleid", "class_id", "class_name", "object_id", "object_name", "object_name_lower", "comment")) + setcolorder(parsed$value, c("rleid", "class_id", "class_name", "object_id", "object_name", "field_id", "field_index", "field_name", "value_id", "value_chr")) + + parsed +} # nocov end # }}} # TABLE @@ -3718,11 +3912,9 @@ get_idf_table <- function (idd_env, idf_env, class = NULL, object = NULL, } else { cls <- paste0(c(surround(cls[1:5]), "..."), collapse = ", ") } - abort("error_multi_class", - paste0("Target objects should belong to a same class when 'wide' is TRUE. ", - "Multiple classes found: ", cls, "." - ) - ) + abort(paste0("Target objects should belong to a same class when 'wide' is TRUE. ", + "Multiple classes found: ", cls, "." + )) } setnames(val, @@ -3823,14 +4015,15 @@ get_idf_table <- function (idd_env, idf_env, class = NULL, object = NULL, #' method in [Idf] class. #' #' @param dt A data.table created using `Idf$to_table()` and -#' `IdfObject$to_table()`. `dt` should at least contain column `id` (indicator -#' used to distinguish object definitions), `class` (class names). If a `name` -#' column exists, it will be preserved. +#' `IdfObject$to_table()`. `dt` should at least contain column `id` +#' (indicator used to distinguish object definitions), `class` (class +#' names). If a `name` column exists, it will be preserved. #' @param string_value If `TRUE`, all value will be coerced into character and -#' the `value` column of returned [datat.table][data.table::data.table()] will -#' be character type. If `FALSE`, the original value will be preserved and the -#' `value` column of returned [data.table][data.table::data.table()] will be -#' list type. +#' the `value` column of returned [datat.table][data.table::data.table()] +#' will be character type. If `FALSE`, the original value will be +#' preserved and the `value` column of returned +#' [data.table][data.table::data.table()] will be list type. +#' #' @return #' A [data.table][data.table::data.table()] with 5 or 6 columns: #' @@ -3841,7 +4034,6 @@ get_idf_table <- function (idd_env, idf_env, class = NULL, object = NULL, #' * `field`: Character type. Field names. #' * `value`: Character or list type. The value of each field to be added. #' -#' @export #' @examples #' \dontrun{ #' # read an example distributed with eplusr @@ -3853,15 +4045,17 @@ get_idf_table <- function (idd_env, idf_env, class = NULL, object = NULL, #' #' dt_to_load(dt) #' } -#' @export +#' #' @export # dt_to_load {{{ dt_to_load <- function (dt, string_value = TRUE) { - assert(has_name(dt, c("id", "class"))) - has_nm <- has_name(dt, "name") + assert_data_frame(dt) + assert_names(names(dt), must.include = c("id", "class")) + assert_flag(string_value) + has_nm <- has_names(dt, "name") dt <- copy(dt)[, rleid := .I] - id_cols <- if (has_name(dt, "name")) c("rleid", "id", "name", "class") else c("rleid", "id", "class") + id_cols <- if (has_names(dt, "name")) c("rleid", "id", "name", "class") else c("rleid", "id", "class") val_cols <- setdiff(names(dt), id_cols) if (string_value && length(val_cols)) { @@ -3890,25 +4084,42 @@ get_idf_string <- function (idd_env, idf_env, dt_order = NULL, class = NULL, obj leading = 4L, sep_at = 29L) { format <- match.arg(format) + # IP - SI conversion + from <- if (eplusr_option("view_in_ip")) "ip" else "si" + to <- if (in_ip) "ip" else "si" + temp_ip <- FALSE + if (from != to) { + if (in_ip) temp_ip <- TRUE + + value <- copy(idf_env$value) + idf_env$value <- convert_value_unit(idd_env, idf_env$value, from, to) + } + if (any(!is.null(class), !is.null(object))) { obj <- get_idf_object(idd_env, idf_env, class, object, ignore_case = TRUE) fmt <- with_nocolor(with_format_cols(idd_env, idf_env, - format_idf( - idf_env$value[J(obj$object_id), on = "object_id"], - idf_env$object[J(obj$object_id), on = "object_id"], - dt_order, in_ip = in_ip, header = header, comment = comment, - save_format = format, leading = leading, sep_at = sep_at + with_option(list(view_in_ip = temp_ip), + format_idf( + idf_env$value[J(obj$object_id), on = "object_id"], + idf_env$object[J(obj$object_id), on = "object_id"], + dt_order, header = header, comment = comment, + save_format = format, leading = leading, sep_at = sep_at + ) ) )) } else { fmt <- with_nocolor(with_format_cols(idd_env, idf_env, - format_idf(idf_env$value, idf_env$object, dt_order, in_ip = in_ip, - header = header, comment = comment, save_format = format, - leading = leading, sep_at = sep_at + with_option(list(view_in_ip = temp_ip), + format_idf(idf_env$value, idf_env$object, dt_order, + header = header, comment = comment, save_format = format, + leading = leading, sep_at = sep_at + ) ) )) } + if (from != to) idf_env$value <- value + if (format == "sorted") { combine_fmt <- function (lst) { head <- if (is.null(lst[[1L]])) "" else c("", lst[[1L]], "") @@ -3939,17 +4150,13 @@ save_idf <- function (idd_env, idf_env, dt_order = NULL, path, in_ip = FALSE, overwrite = FALSE, copy_external = TRUE, oldpath = path) { format <- match.arg(format) - assert(has_ext(path, "idf")) + assert_string(path) + if (!has_ext(path, "idf")) abort("'path' should have the extension of 'idf'") if (file.exists(path)) { new_file <- FALSE if (!overwrite) { - abort("error_not_overwrite_idf", - paste0( - "Target IDF file already exists. Please set `overwrite` to ", - "TRUE if you want to replace it." - ) - ) + abort("Target IDF file already exists. Please set 'overwrite' to TRUE if you want to replace it.") } else { verbose_info("Replace the existing IDF located at ", normalizePath(path), ".") } @@ -3957,9 +4164,7 @@ save_idf <- function (idd_env, idf_env, dt_order = NULL, path, in_ip = FALSE, d <- dirname(path) if (!dir.exists(d)) { tryCatch(dir.create(d, recursive = TRUE), - warning = function (w) { - abort("error_create_idf_dir", paste0("Failed to create directory ", surround(d), ".")) - } + warning = function (w) stop("Failed to create directory ", surround(d)) ) } new_file <- TRUE @@ -3979,7 +4184,7 @@ save_idf <- function (idd_env, idf_env, dt_order = NULL, path, in_ip = FALSE, # auto change full file path in `Schedule:File` to relative path and copy those # files into the same directory of the model resolve_idf_external_link <- function (idd_env, idf_env, old, new, copy = TRUE) { - if (!has_name(idf_env$object, "class_name")) { + if (!has_names(idf_env$object, "class_name")) { added <- TRUE add_class_name(idd_env, idf_env$object) on.exit(set(idf_env$object, NULL, "class_name", NULL), add = TRUE) @@ -4043,11 +4248,9 @@ resolve_idf_external_link <- function (idd_env, idf_env, old, new, copy = TRUE) invld <- val[J(to_copy[!flag]), on = c("old_full_path")] m <- paste0(" ", unlist(format_objects(invld, c("class", "object", "value"), brief = FALSE)$out), collapse = "\n") - abort("error_failed_to_copy", - paste0("Failed to copy external file into the output directory ", - surround(new_dir), ":\n", m, collapse = "\n" - ) - ) + abort(paste0("Failed to copy external file into the output directory ", + surround(new_dir), ":\n", m, collapse = "\n" + )) } } @@ -4073,37 +4276,42 @@ assign_new_id <- function (dt_idf, dt, type = c("object", "value"), keep = FALSE } } # }}} -# correct_obj_id {{{ -correct_obj_id <- function (dt_object, dt_value) { - set(dt_value, NULL, "object_id", - rep(dt_object$object_id, times = dt_value[, .N, by = "object_id"]$N) - ) -} -# }}} -# assign_default_value {{{ -assign_default_value <- function (idd_env, idf_env, dt_value) { +# assign_idf_value_default {{{ +assign_idf_value_default <- function (idd_env, idf_env, dt_value) { if (in_ip_mode()) { dt_value <- field_default_to_unit(idd_env, dt_value, "si", "ip") } - dt_value[defaulted == TRUE, `:=`(value_chr = default_chr, value_num = default_num)] + + cols_add <- NULL + if (!has_names(dt_value, "default_chr")) cols_add <- "default_chr" + if (!has_names(dt_value, "default_num")) cols_add <- c(cols_add, "default_num") + if (!is.null(cols_add)) add_field_property(idd_env, dt_value, cols_add) + + if (has_names(dt_value, "defaulted")) { + dt_value[J(TRUE), on = "defaulted", `:=`(value_chr = default_chr, value_num = default_num)] + } else { + dt_value[J(NA_character_), on = "value_chr", `:=`(value_chr = default_chr, value_num = default_num)] + } + + if (!is.null(cols_add)) set(dt_value, NULL, cols_add, NULL) + dt_value } # }}} # merge_idf_data {{{ -merge_idf_data <- function (idf_env, dt, by_object = FALSE) { - assert(is.environment(idf_env)) - assert(has_name(dt, c("object", "value", "reference"))) +merge_idf_data <- function (idf_env, lst, by_object = FALSE) { + assert_names(names(lst), c("object", "value", "reference")) - idf_env$object <- append_dt(idf_env$object, dt$object, "object_id") + idf_env$object <- append_dt(idf_env$object, lst$object, "object_id") - if (nrow(dt$value)) { + if (nrow(lst$value)) { if (by_object) { - idf_env$value <- append_dt(idf_env$value, dt$value, "object_id") + idf_env$value <- append_dt(idf_env$value, lst$value, "object_id") } else { - idf_env$value <- append_dt(idf_env$value, dt$value, "value_id") + idf_env$value <- append_dt(idf_env$value, lst$value, "value_id") } } - idf_env$reference <- dt$reference + idf_env$reference <- lst$reference setorderv(idf_env$object, c("object_id")) setorderv(idf_env$value, c("object_id", "field_id")) diff --git a/man/add_idf_object.Rd b/man/add_idf_object.Rd new file mode 100644 index 000000000..d711bfecd --- /dev/null +++ b/man/add_idf_object.Rd @@ -0,0 +1,49 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/impl-idf.R +\name{add_idf_object} +\alias{add_idf_object} +\title{Add new objects} +\usage{ +add_idf_object( + idd_env, + idf_env, + dt_object, + dt_value, + default = TRUE, + unique = FALSE, + empty = FALSE, + level = eplusr_option("validate_level") +) +} +\arguments{ +\item{idd_env}{An environment or list contains IDD tables including class, +field, and reference.} + +\item{idf_env}{An environment or list contains IDF tables including object, +value, and reference.} + +\item{dt_object}{A \code{\link[data.table:data.table]{data.table::data.table()}} that contains object data. +Usually created using \code{\link[=expand_idf_dots_value]{expand_idf_dots_value()}}.} + +\item{dt_value}{A \code{\link[data.table:data.table]{data.table::data.table()}} that contains value data. +Usually created using \code{\link[=expand_idf_dots_value]{expand_idf_dots_value()}}.} + +\item{default}{If \code{TRUE}, default values are used for those blank +fields if possible. If \code{FALSE}, empty fields are kept blank. +Default: \code{TRUE}.} + +\item{unique}{If \code{TRUE}, there are same objects in current \link{Idf} as input, +duplications in input are removed. Default: \code{FALSE}.} + +\item{empty}{If \code{TRUE}, trailing empty fields are kept. Default: \code{FALSE}.} + +\item{level}{Validate level. Default: \code{eplusr_option("validate_level")}.} +} +\value{ +The newly added object data in a named list of 3 +\code{\link[data.table:data.table]{data.table::data.table()}}s, i.e. \code{object}, \code{value} and \code{reference}. +} +\description{ +Add new objects +} +\keyword{internal} diff --git a/man/del_idf_object.Rd b/man/del_idf_object.Rd new file mode 100644 index 000000000..660362ba5 --- /dev/null +++ b/man/del_idf_object.Rd @@ -0,0 +1,52 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/impl-idf.R +\name{del_idf_object} +\alias{del_idf_object} +\title{Delete existing objects} +\usage{ +del_idf_object( + idd_env, + idf_env, + dt_object, + ref_to = FALSE, + ref_by = FALSE, + recursive = FALSE, + force = FALSE, + level = eplusr_option("validate_level") +) +} +\arguments{ +\item{idd_env}{An environment or list contains IDD tables including class, +field, and reference.} + +\item{idf_env}{An environment or list contains IDF tables including object, +value, and reference.} + +\item{dt_object}{A \code{\link[data.table:data.table]{data.table::data.table()}} that contains object data. +Usually created using \code{\link[=expand_idf_dots_value]{expand_idf_dots_value()}}.} + +\item{ref_to}{If \code{TRUE}, objects whose fields are referred by input +objects will also be deleted. Default: \code{FALSE}.} + +\item{ref_by}{If \code{TRUE}, objects whose fields refer to input objects +will also be deleted. Default: \code{FALSE}.} + +\item{recursive}{If \code{TRUE}, relation searching is performed +recursively, in case that objects whose fields refer to target +object are also referred by another object, and also objects +whose fields are referred by target object are also referred +by another object. Default: \code{FALSE}.} + +\item{force}{If \code{TRUE}, objects are deleted even if they are +referred by other objects.} + +\item{level}{Validate level. Default: \code{eplusr_option("validate_level")}.} +} +\value{ +The modified whole IDF data in a named list of 3 +\code{\link[data.table:data.table]{data.table::data.table()}}s, i.e. \code{object}, \code{value} and \code{reference}. +} +\description{ +Delete existing objects +} +\keyword{internal} diff --git a/man/dup_idf_object.Rd b/man/dup_idf_object.Rd new file mode 100644 index 000000000..1f77c842a --- /dev/null +++ b/man/dup_idf_object.Rd @@ -0,0 +1,33 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/impl-idf.R +\name{dup_idf_object} +\alias{dup_idf_object} +\title{Duplicate existing objects} +\usage{ +dup_idf_object( + idd_env, + idf_env, + dt_object, + level = eplusr_option("validate_level") +) +} +\arguments{ +\item{idd_env}{An environment or list contains IDD tables including class, +field, and reference.} + +\item{idf_env}{An environment or list contains IDF tables including object, +value, and reference.} + +\item{dt_object}{A \code{\link[data.table:data.table]{data.table::data.table()}} that contains object data. +Usually created using \code{\link[=expand_idf_dots_value]{expand_idf_dots_value()}}.} + +\item{level}{Validate level. Default: \code{eplusr_option("validate_level")}.} +} +\value{ +The duplicated object data in a named list of 3 +\code{\link[data.table:data.table]{data.table::data.table()}}s, i.e. \code{object}, \code{value} and \code{reference}. +} +\description{ +Duplicate existing objects +} +\keyword{internal} diff --git a/man/duplicated_idf_object.Rd b/man/duplicated_idf_object.Rd new file mode 100644 index 000000000..4cb3e7969 --- /dev/null +++ b/man/duplicated_idf_object.Rd @@ -0,0 +1,27 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/impl-idf.R +\name{duplicated_idf_object} +\alias{duplicated_idf_object} +\title{Determine duplicate objects} +\usage{ +duplicated_idf_object(idd_env, idf_env, dt_object) +} +\arguments{ +\item{idd_env}{An environment or list contains IDD tables including class, +field, and reference.} + +\item{idf_env}{An environment or list contains IDF tables including object, +value, and reference.} + +\item{dt_object}{A \code{\link[data.table:data.table]{data.table::data.table()}} that contains object data. +Usually created using \code{\link[=expand_idf_dots_value]{expand_idf_dots_value()}}.} +} +\value{ +A same \code{\link[data.table:data.table]{data.table::data.table()}} as input \code{dt_object} (updated by +reference) with appended logical column \code{duplicated} indicating the object is +a duplicated one or not. +} +\description{ +Determine duplicate objects +} +\keyword{internal} diff --git a/man/expand_idf_dots_literal.Rd b/man/expand_idf_dots_literal.Rd new file mode 100644 index 000000000..ca5045b70 --- /dev/null +++ b/man/expand_idf_dots_literal.Rd @@ -0,0 +1,76 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/impl-idf.R +\name{expand_idf_dots_literal} +\alias{expand_idf_dots_literal} +\title{Parse object values given in literal character vectors or data.frames} +\usage{ +expand_idf_dots_literal(idd_env, idf_env, ..., .default = TRUE, .exact = FALSE) +} +\arguments{ +\item{idd_env}{An environment or list contains IDD tables including class, +field, and reference.} + +\item{idf_env}{An environment or list contains IDF tables including object, +value, and reference.} + +\item{...}{Character vectors or data.frames.} + +\item{.default}{If \code{TRUE}, all empty fields will be filled with default +values if possible. Default: \code{TRUE}.} + +\item{.exact}{If \code{TRUE}, all inputs should match existing objects in the +\link{Idf}. In this case, \code{id} column is require for data.frame input. +Default: \code{FALSE}.} +} +\value{ +A named list of 2 element \code{object} and \code{value} which is a +\code{\link[data.table:data.table]{data.table::data.table()}} with object data and value data respectively. +} +\description{ +Parse object values given in literal character vectors or data.frames +} +\details{ +For object definitions in character vector format, they follow the +same rules as a normal IDF file: +\itemize{ +\item Each object starts with a class name and a comma (\verb{,}); +\item Separates each values with a comma (\verb{,}); +\item Ends an object with a semicolon (\verb{;}) for the last value. +} + +Each character vector can contain: +\itemize{ +\item One single object, e.g. \code{c("Building,", "MyBuilding;")}, or "Building, MyBuilding;". +\item Multiple objects, e.g. \code{c("Building, MyBuilding;", "SimulationControl, Yes")}. +} + +You can also provide an option header to indicate if input objects are +presented in IP units, using \verb{!-Option ViewInIPunits}. If this header does +not exist, then all values are treated as in SI units. + +For object definitions in data.frame format, a valid definition requires at +least three columns described below. Note that column order does not matter. +\itemize{ +\item \code{class}:Character type. Valid class names in the underlying +\link{Idd} object. +\item \code{index}:Integer type. Valid field indices for each class. +\item \code{value}:Character type or list type. Value for each field +to be added. +\itemize{ +\item If character type, each value should be given as a string even if the +corresponding field is a numeric type. +\item If list type, each value should have the right type as the corresponding +field definition. +} +\item \code{id}: \strong{Optional} when \code{.exact} is \code{FALSE}. Integer type. +If input data.frame includes multiple object definitions in a same class, +values in \code{id} column will be used to distinguish each definition. If \code{id} +column does not exists, it assumes that each definition is separated by +\code{class} column and will issue an error if there is any duplication in the +\code{index} column. +} +} +\note{ +Objects from character vectors will always be at the top of each table. +} +\keyword{internal} diff --git a/man/expand_idf_dots_name.Rd b/man/expand_idf_dots_name.Rd new file mode 100644 index 000000000..ba1a00557 --- /dev/null +++ b/man/expand_idf_dots_name.Rd @@ -0,0 +1,36 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/impl-idf.R +\name{expand_idf_dots_name} +\alias{expand_idf_dots_name} +\title{Parse object ID or name specifications given in list format} +\usage{ +expand_idf_dots_name( + idd_env, + idf_env, + ..., + .keep_name = TRUE, + .property = NULL +) +} +\arguments{ +\item{idd_env}{An environment or list contains IDD tables including class, +field, and reference.} + +\item{idf_env}{An environment or list contains IDF tables including object, +value, and reference.} + +\item{...}{Lists of object ID or name pair, e.g. \code{c(Name1, Name2)}, \code{c(ID1, ID2)}, \code{NewName = OldName} and \code{NewName = ID}. \code{NewName} is optional.} + +\item{.keep_name}{If \code{TRUE}, input new names will be kept in a column named +\code{new_object_name}, otherwise they will be dropped. Default: \code{TRUE}.} + +\item{.property}{A character vector of column names in class table to return. +Default: \code{NULL}.} +} +\value{ +A \code{\link[data.table:data.table]{data.table::data.table()}} containing extracted object data. +} +\description{ +Parse object ID or name specifications given in list format +} +\keyword{internal} diff --git a/man/expand_idf_dots_object.Rd b/man/expand_idf_dots_object.Rd new file mode 100644 index 000000000..491c628d7 --- /dev/null +++ b/man/expand_idf_dots_object.Rd @@ -0,0 +1,46 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/impl-idf.R +\name{expand_idf_dots_object} +\alias{expand_idf_dots_object} +\title{Parse object values given in a list of Idf or IdfObject format} +\usage{ +expand_idf_dots_object( + idd_env, + idf_env, + ..., + .unique = TRUE, + .strict = TRUE, + .complete = TRUE, + .all = FALSE +) +} +\arguments{ +\item{idd_env}{An environment or list contains IDD tables including class, +field, and reference.} + +\item{idf_env}{An environment or list contains IDF tables including object, +value, and reference.} + +\item{...}{Lists of \link{Idf}s or \link{IdfObject}s.} + +\item{.unique}{If \code{TRUE}, make sure there are no duplicated objects in the +input. If \code{FALSE}, duplicates are kept. If \code{NULL}, duplicates are +removed. Default: \code{TRUE}.} + +\item{.strict}{If \code{TRUE}, make sure all input objects come from the same +verion as that from \code{idf_env}. Default: \code{TRUE}.} + +\item{.complete}{If \code{TRUE}, make sure the returned field number meets the +\verb{\\min-fields} requirement. Default: \code{TRUE}} + +\item{.all}{If \code{TRUE}, make sure the all possible fields are returned. +Default: \code{FALSE}.} +} +\value{ +A named list of 3 \code{\link[data.table:data.table]{data.table::data.table()}}: \code{meta}, \code{object} and +\code{value}. +} +\description{ +Parse object values given in a list of Idf or IdfObject format +} +\keyword{internal} diff --git a/man/expand_idf_dots_value.Rd b/man/expand_idf_dots_value.Rd new file mode 100644 index 000000000..2492df848 --- /dev/null +++ b/man/expand_idf_dots_value.Rd @@ -0,0 +1,78 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/impl-idf.R +\name{expand_idf_dots_value} +\alias{expand_idf_dots_value} +\title{Parse object field values given in list format} +\usage{ +expand_idf_dots_value( + idd_env, + idf_env, + ..., + .type = "class", + .complete = TRUE, + .all = FALSE, + .scalar = TRUE, + .pair = FALSE, + .ref_assign = TRUE, + .unique = TRUE, + .empty = TRUE, + .default = TRUE, + .env = parent.frame() +) +} +\arguments{ +\item{idd_env}{An environment or list contains IDD tables including class, +field, and reference.} + +\item{idf_env}{An environment or list contains IDF tables including object, +value, and reference.} + +\item{...}{Lists of object definitions. Each list should be named +with a valid class/object id/name. ID should be denoted in style +\code{..ID}. There is a special element \code{.comment} in each list, which will +be used as new comments of the object. If \code{.ref_assign} is \code{TRUE}, +\verb{:=} can be used to group multiple id/name wrapped by \code{.()} or \code{c()}.} + +\item{.type}{Should be either \code{"class"} or \code{"object"}. If \code{"class"}, +id/name of each input will be treated as class index/name. If \code{"object"}, +id/name of each input will be treated as object id/name.} + +\item{.complete}{If \code{TRUE}, make sure the returned field number meets the +\verb{\\min-fields} requirement. Default: \code{TRUE}} + +\item{.all}{If \code{TRUE}, make sure the all possible fields are returned. +Default: \code{FALSE}.} + +\item{.scalar}{If \code{TRUE}, make sure the value of each field in the object is a +scalar value. If \code{FALSE}, \code{value_chr} and \code{value_num} column will be +list type. Default: \code{TRUE}.} + +\item{.pair}{Only works when \code{.scalar} is \code{FALSE}. If \code{.pair} is \code{TRUE}, +vector field values will be paired to each id/name on the LHS. In this +case, \code{value_chr} and \code{value_num} will be character type and double +type, respectively. When there is only one id/name on the LHS, it will +be replicated to match the length of the value vector. Default: \code{FALSE}.} + +\item{.ref_assign}{If \code{TRUE}, allow using \verb{:=} to gather multiple +classes/objects on the LHS when defining the objects. Default: \code{TRUE}.} + +\item{.unique}{If \code{TRUE}, make sure there are no duplicated classes/objects in +the input. Default: \code{FALSE}.} + +\item{.empty}{If \code{TRUE}, allow using an empty list, i.e. \code{list()} to define an +object with all default values. Default: \code{TRUE}.} + +\item{.default}{If \code{TRUE}, all empty fields will be filled with default +values if possible. Default: \code{TRUE}.} + +\item{.env}{An environment specifying the environment to evaluate the \code{...}. +Default: \code{\link[=parent.frame]{parent.frame()}}.} +} +\value{ +A named list of 2 element \code{object} and \code{value} which is a +\code{\link[data.table:data.table]{data.table::data.table()}} with object data and value data respectively. +} +\description{ +Parse object field values given in list format +} +\keyword{internal} diff --git a/man/expand_idf_regex.Rd b/man/expand_idf_regex.Rd new file mode 100644 index 000000000..30d8e2dff --- /dev/null +++ b/man/expand_idf_regex.Rd @@ -0,0 +1,39 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/impl-idf.R +\name{expand_idf_regex} +\alias{expand_idf_regex} +\title{Parse regular expression of object field values} +\usage{ +expand_idf_regex( + idd_env, + idf_env, + pattern, + replacement = NULL, + class = NULL, + ignore.case = FALSE, + perl = FALSE, + fixed = FALSE, + useBytes = FALSE +) +} +\arguments{ +\item{idd_env}{An environment or list contains IDD tables including class, +field, and reference.} + +\item{idf_env}{An environment or list contains IDF tables including object, +value, and reference.} + +\item{pattern}{A single string of regular expression used to match field +values} + +\item{pattern, ignore.case, perl, fixed, useBytes}{All of them are +directly passed to \link[base:grep]{base::grepl} and +\link[base:grep]{base::gsub} with the same default values.} +} +\value{ +A named list of 2 \code{\link[data.table:data.table]{data.table::data.table()}}: \code{object} and \code{value}. +} +\description{ +Parse regular expression of object field values +} +\keyword{internal} diff --git a/man/get_idf_object.Rd b/man/get_idf_object.Rd new file mode 100644 index 000000000..c22836517 --- /dev/null +++ b/man/get_idf_object.Rd @@ -0,0 +1,47 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/impl-idf.R +\name{get_idf_object} +\alias{get_idf_object} +\title{Get object data} +\usage{ +get_idf_object( + idd_env, + idf_env, + class = NULL, + object = NULL, + property = NULL, + underscore = FALSE, + ignore_case = FALSE +) +} +\arguments{ +\item{idd_env}{An environment or list contains IDD tables including class, +field, and reference.} + +\item{idf_env}{An environment or list contains IDF tables including object, +value, and reference.} + +\item{class}{An integer vector of valid class indexes or a character vector +of valid class names. Default: \code{NULL}.} + +\item{object}{An integer vector of valid object IDs or a character vector +of valid object names. Default: \code{NULL}.} + +\item{property}{A character vector of column names in class table to return.} + +\item{underscore}{If \code{TRUE}, input class name will be converted into +underscore style name first and column \code{class_name_us} will be used +for matching. Default: \code{FALSE}.} + +\item{ignore_case}{If \code{TRUE}, input object name will be converted into lower +case and column \code{object_name_lower} will be used for matching. +converted into underscore style name first and column \code{class_name_us} +and \code{field_name_us} will be used for matching. Default: \code{FALSE}.} +} +\value{ +A data.table. +} +\description{ +Get object data +} +\keyword{internal} diff --git a/man/get_idf_relation.Rd b/man/get_idf_relation.Rd new file mode 100644 index 000000000..2471f4f98 --- /dev/null +++ b/man/get_idf_relation.Rd @@ -0,0 +1,79 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/impl-idf.R +\name{get_idf_relation} +\alias{get_idf_relation} +\title{Extract object and value reference relations} +\usage{ +get_idf_relation( + idd_env, + idf_env, + object_id = NULL, + value_id = NULL, + direction = c("ref_to", "ref_by"), + depth = 0L, + name = FALSE, + object = NULL, + class = NULL, + group = NULL, + keep_all = FALSE, + class_ref = c("both", "none", "all"), + match_all = FALSE +) +} +\arguments{ +\item{idd_env}{An environment or list contains IDD tables including class, +field, and reference.} + +\item{idf_env}{An environment or list contains IDF tables including object, +value, and reference.} + +\item{object_id}{An integer vector of valid object IDs. If \code{NULL}, all object +IDs in current IDF will be used.} + +\item{value_id}{An integer vector of valid value IDs. If \code{NULL}, all value +IDs in current IDF will be used.} + +\item{direction}{Reference relation direction. Should be one of \code{"ref_to"} +and \code{"ref_by"}. Default: \code{"ref_to"}.} + +\item{depth}{Recursive reference relation depth. \code{NULL} means infinite. +Default: \code{0L}.} + +\item{name}{If \code{TRUE}, all class, object, field value ID and name columns +will be added and a \code{IdfRelationTo} or \code{IdfRelationBy} object is +returned with customized printing method. Default: \code{FALSE}.} + +\item{object}{An integer vector of valid object IDs or a character vector +of valid object names to specify the targeting relation objects. +Default: \code{NULL}.} + +\item{class}{An integer vector of valid class indexes or a character vector +of valid class names to specify the targeting relation classes. +Default: \code{NULL}.} + +\item{group}{A character vector of valid group names to specify the targeting +relation groups. Default: \code{NULL}.} + +\item{keep_all}{If \code{TRUE}, all input ID are kept. Otherwise, only input IDs +that have relations are kept. Default: \code{FALSE}.} + +\item{class_ref}{Specify how to handle class-name-references. There are 3 +options in total, i.e. \code{"none"}, \code{"both"} and \code{"all"}, with \code{"both"} +being the default. +* \code{"none"}: just ignore class-name-references. +* \code{"both"}: only include class-name-references if this object also +reference field values of the same one. This is the default option. +* \code{"all"}: include all class-name-references. This is the most aggressive +option.} + +\item{match_all}{If \code{TRUE}, relation search will continue even though one +relation has been found. If \code{FALSE}, searching is stopped whenever one +relation is found in specified classes/groups. Default: \code{FALSE}.} +} +\value{ +A data.table. +} +\description{ +Extract object and value reference relations +} +\keyword{internal} diff --git a/man/get_idf_value.Rd b/man/get_idf_value.Rd new file mode 100644 index 000000000..82d83e82c --- /dev/null +++ b/man/get_idf_value.Rd @@ -0,0 +1,67 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/impl-idf.R +\name{get_idf_value} +\alias{get_idf_value} +\title{Get value data} +\usage{ +get_idf_value( + idd_env, + idf_env, + class = NULL, + object = NULL, + field = NULL, + property = NULL, + underscore = FALSE, + ignore_case = FALSE, + align = FALSE, + complete = FALSE, + all = FALSE +) +} +\arguments{ +\item{idd_env}{An environment or list contains IDD tables including class, +field, and reference.} + +\item{idf_env}{An environment or list contains IDF tables including object, +value, and reference.} + +\item{class}{An integer vector of valid class indexes or a character vector +of valid class names. Default: \code{NULL}.} + +\item{object}{An integer vector of valid object IDs or a character vector +of valid object names. Default: \code{NULL}.} + +\item{field}{An integer vector of valid field indexes or a character +vector of valid field names (can be in in underscore style). \code{class} +and \code{field} should have the same length.} + +\item{property}{A character vector of column names in field table to return.} + +\item{underscore}{If \code{TRUE}, input class name will be converted into +underscore style name first and column \code{class_name_us} will be used +for matching. Default: \code{FALSE}.} + +\item{ignore_case}{If \code{TRUE}, input object name will be converted into lower +case and column \code{object_name_lower} will be used for matching. +converted into underscore style name first and column \code{class_name_us} +and \code{field_name_us} will be used for matching. Default: \code{FALSE}.} + +\item{align}{If \code{TRUE}, all objects in the same class will have the same +field number. The number of fields is the same as the object that have +the most fields among objects specified. Default: \code{FALSE}.} + +\item{complete}{If \code{TRUE}, at least fields till the current whole extensible +group will be returned. A new column named "matched_rleid" will be +created (when \code{property} is NULL) indicating if given field has been +matched or not.} + +\item{all}{If \code{TRUE}, all available fields defined in IDD for the class that +objects belong to will be returned. Default: \code{FALSE}.} +} +\value{ +A data.table containing specified columns. +} +\description{ +Get value data +} +\keyword{internal} diff --git a/man/init_idf_object.Rd b/man/init_idf_object.Rd new file mode 100644 index 000000000..f3ba6704c --- /dev/null +++ b/man/init_idf_object.Rd @@ -0,0 +1,45 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/impl-idf.R +\name{init_idf_object} +\alias{init_idf_object} +\title{Initialize object data} +\usage{ +init_idf_object( + idd_env, + idf_env, + class, + property = NULL, + underscore = FALSE, + id = TRUE, + name = TRUE +) +} +\arguments{ +\item{idd_env}{An environment or list contains IDD tables including class, +field, and reference.} + +\item{idf_env}{An environment or list contains IDF tables including object, +value, and reference.} + +\item{class}{An integer vector of valid class indexes or a character vector +of valid class names. Default: \code{NULL}.} + +\item{property}{A character vector of column names in class table to return.} + +\item{underscore}{If \code{TRUE}, input class name will be converted into +underscore style name first and column \code{class_name_us} will be used +for matching. Default: \code{FALSE}.} + +\item{id}{If \code{TRUE}, new object IDs will be added in column \code{object_id} based +on current existing objects found in \code{idf_env}. Default: \code{TRUE}.} + +\item{name}{If \code{TRUE}, column \code{object_name} and \code{object_name_lower} will be +filled using \code{\link[=make_idf_object_name]{make_idf_object_name()}}. Default: \code{TRUE}.} +} +\value{ +A \code{\link[data.table:data.table]{data.table::data.table()}} +} +\description{ +Initialize object data +} +\keyword{internal} diff --git a/man/init_idf_value.Rd b/man/init_idf_value.Rd new file mode 100644 index 000000000..84c61e938 --- /dev/null +++ b/man/init_idf_value.Rd @@ -0,0 +1,66 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/impl-idf.R +\name{init_idf_value} +\alias{init_idf_value} +\title{Initialize value data} +\usage{ +init_idf_value( + idd_env, + idf_env, + class, + field = NULL, + property = NULL, + underscore = FALSE, + complete = FALSE, + all = FALSE, + default = TRUE, + id = TRUE +) +} +\arguments{ +\item{idd_env}{An environment or list contains IDD tables including class, +field, and reference.} + +\item{idf_env}{An environment or list contains IDF tables including object, +value, and reference.} + +\item{class}{An integer vector of valid class indexes or a character vector +of valid class names. Default: \code{NULL}.} + +\item{field}{An integer vector of valid field indexes or a character +vector of valid field names (can be in in underscore style). \code{class} +and \code{field} should have the same length.} + +\item{property}{A character vector of column names in field table to return.} + +\item{underscore}{If \code{TRUE}, input class name will be converted into +underscore style name first and column \code{class_name_us} will be used +for matching. Default: \code{FALSE}.} + +\item{complete}{If \code{TRUE}, at least fields till the current whole extensible +group will be returned. A new column named "matched_rleid" will be +created (when \code{property} is NULL) indicating if given field has been +matched or not. Default: \code{FALSE}.} + +\item{all}{If \code{TRUE}, all available fields defined in IDD for the class that +objects belong to will be returned. Default: \code{FALSE}.} + +\item{default}{If \code{TRUE}, column \code{value_chr} and \code{value_num} will be filled +with default values. Default: \code{TRUE}.} + +\item{id}{If \code{TRUE}, new value id will be added in column \code{value_id} based +on current existing value ids found in \code{idf_env}. Default: \code{TRUE}.} + +\item{object}{An integer vector of valid object IDs or a character vector +of valid object names. Default: \code{NULL}.} +} +\value{ +A data.table containing specified columns. +} +\description{ +Initialize value data +} +\note{ +'object_id' and 'object_name' are added as all \code{NA}s. +} +\keyword{internal} diff --git a/man/make_idf_object_name.Rd b/man/make_idf_object_name.Rd new file mode 100644 index 000000000..36c5df3c2 --- /dev/null +++ b/man/make_idf_object_name.Rd @@ -0,0 +1,50 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/impl-idf.R +\name{make_idf_object_name} +\alias{make_idf_object_name} +\title{Initialize object data} +\usage{ +make_idf_object_name( + idd_env, + idf_env, + dt_object, + use_old = TRUE, + prefix_col = NULL, + prefix_sep = " ", + keep_na = TRUE, + inclu_ori = FALSE +) +} +\arguments{ +\item{idd_env}{An environment or list contains IDD tables including class, +field, and reference.} + +\item{idf_env}{An environment or list contains IDF tables including object, +value, and reference.} + +\item{dt_object}{A \code{\link[data.table:data.table]{data.table::data.table()}} containing object data.} + +\item{use_old}{If \code{TRUE}, new object names are based on the original object +names in column \code{object_name}. If \code{FALSE}, new object names are +created based on the class name it belongs to. Default: \code{TRUE}.} + +\item{prefix_col}{An character vector of column names in input \code{dt_object} +whose values will be combined together as the prefix of the new object +names. Default: \code{NULL}.} + +\item{prefix_sep}{A single string specifying the separation character among +prefix columns. Default: \code{NULL}.} + +\item{keep_na}{If \code{TRUE}, new object names will be \code{NA} if the original +object names in column \code{object_name} are \code{NA}s. Default: \code{TRUE}.} + +\item{inclu_ori}{If \code{TRUE}, make sure new object names are not the same as +the original object names in the \code{object_name} column. Default: \code{FALSE}.} +} +\value{ +A \code{\link[data.table:data.table]{data.table::data.table()}} +} +\description{ +Initialize object data +} +\keyword{internal} diff --git a/man/purge_idf_object.Rd b/man/purge_idf_object.Rd new file mode 100644 index 000000000..7c35f8841 --- /dev/null +++ b/man/purge_idf_object.Rd @@ -0,0 +1,28 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/impl-idf.R +\name{purge_idf_object} +\alias{purge_idf_object} +\title{Purge not-used resource objects} +\usage{ +purge_idf_object(idd_env, idf_env, dt_object) +} +\arguments{ +\item{idd_env}{An environment or list contains IDD tables including class, +field, and reference.} + +\item{idf_env}{An environment or list contains IDF tables including object, +value, and reference.} + +\item{dt_object}{A \code{\link[data.table:data.table]{data.table::data.table()}} that contains object data. +Usually created using \code{\link[=expand_idf_dots_value]{expand_idf_dots_value()}}.} + +\item{level}{Validate level. Default: \code{eplusr_option("validate_level")}.} +} +\value{ +The modified whole IDF data in a named list of 3 +\code{\link[data.table:data.table]{data.table::data.table()}}s, i.e. \code{object}, \code{value} and \code{reference}. +} +\description{ +Purge not-used resource objects +} +\keyword{internal} diff --git a/man/read_idfeditor_copy.Rd b/man/read_idfeditor_copy.Rd new file mode 100644 index 000000000..c7f8f453a --- /dev/null +++ b/man/read_idfeditor_copy.Rd @@ -0,0 +1,35 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/impl-idf.R +\name{read_idfeditor_copy} +\alias{read_idfeditor_copy} +\title{Parse objects from IDF Editor} +\usage{ +read_idfeditor_copy(idd_env, idf_env, version = NULL, in_ip = FALSE) +} +\arguments{ +\item{idd_env}{An environment or list contains IDD tables including class, +field, and reference.} + +\item{idf_env}{An environment or list contains IDF tables including object, +value, and reference.} + +\item{version}{The version of IDF file open by IDF Editor, e.g. \code{8.6}, +\code{"8.8.0"}. If \code{NULL}, assume that the file has the same +version as current Idf object. Default: \code{NULL}.} + +\item{in_ip}{Set to \code{TRUE} if the IDF file is open with \code{Inch-Pound} +view option toggled. Numeric values will automatically +converted to SI units if necessary. Default: \code{FALSE}.} +} +\value{ +The copyied object data from IDF Editor in a named list of 3 +\code{\link[data.table:data.table]{data.table::data.table()}}s, i.e. \code{object}, \code{value} and \code{reference}. +} +\description{ +Parse objects from IDF Editor +} +\note{ +References in the input is not parsed and \code{reference} in the returned list is +always a zero-row table. +} +\keyword{internal} diff --git a/man/rename_idf_object.Rd b/man/rename_idf_object.Rd new file mode 100644 index 000000000..4da636993 --- /dev/null +++ b/man/rename_idf_object.Rd @@ -0,0 +1,43 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/impl-idf.R +\name{rename_idf_object} +\alias{rename_idf_object} +\title{Rename existing objects} +\usage{ +rename_idf_object( + idd_env, + idf_env, + dt_object, + level = eplusr_option("validate_level") +) +} +\arguments{ +\item{idd_env}{An environment or list contains IDD tables including class, +field, and reference.} + +\item{idf_env}{An environment or list contains IDF tables including object, +value, and reference.} + +\item{dt_object}{A \code{\link[data.table:data.table]{data.table::data.table()}} that contains object data. +Usually created using \code{\link[=expand_idf_dots_name]{expand_idf_dots_name()}}.} + +\item{level}{Validate level. Default: \code{eplusr_option("validate_level")}.} +} +\value{ +The modified object data in a named list of 3 +\code{\link[data.table:data.table]{data.table::data.table()}}s, i.e. \code{object}, \code{value}, \code{reference}. +} +\description{ +Rename existing objects +} +\note{ +\itemize{ +\item The \code{reference} table in the returned list only contains the reference-by +map, indicating which values have been updated in the main \code{value} table in +\code{idf_env}. +\item The \code{value} table in input \code{idf_env} could be modified if input objects are +referenced by other objects. The \code{reference} table in the returned list +tells the id actual values modified +} +} +\keyword{internal} diff --git a/man/set_idf_object.Rd b/man/set_idf_object.Rd new file mode 100644 index 000000000..d8bf23d0d --- /dev/null +++ b/man/set_idf_object.Rd @@ -0,0 +1,41 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/impl-idf.R +\name{set_idf_object} +\alias{set_idf_object} +\title{Modifying existing objects} +\usage{ +set_idf_object( + idd_env, + idf_env, + dt_object, + dt_value, + empty = FALSE, + level = eplusr_option("validate_level") +) +} +\arguments{ +\item{idd_env}{An environment or list contains IDD tables including class, +field, and reference.} + +\item{idf_env}{An environment or list contains IDF tables including object, +value, and reference.} + +\item{dt_object}{A \code{\link[data.table:data.table]{data.table::data.table()}} that contains object data. +Usually created using \code{\link[=expand_idf_dots_value]{expand_idf_dots_value()}}.} + +\item{dt_value}{A \code{\link[data.table:data.table]{data.table::data.table()}} that contains value data. +Usually created using \code{\link[=expand_idf_dots_value]{expand_idf_dots_value()}}.} + +\item{empty}{If \code{FALSE}, not required empty fields will be removed. +Default: \code{FALSE}.} + +\item{level}{Validate level. Default: \code{eplusr_option("validate_level")}.} +} +\value{ +The modified object data in a named list of 3 +\code{\link[data.table:data.table]{data.table::data.table()}}s, i.e. \code{object}, \code{value} and \code{reference}. +} +\description{ +Modifying existing objects +} +\keyword{internal} diff --git a/man/unique_idf_object.Rd b/man/unique_idf_object.Rd new file mode 100644 index 000000000..6f92c7d60 --- /dev/null +++ b/man/unique_idf_object.Rd @@ -0,0 +1,26 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/impl-idf.R +\name{unique_idf_object} +\alias{unique_idf_object} +\title{Remove duplicate objects} +\usage{ +unique_idf_object(idd_env, idf_env, dt_object) +} +\arguments{ +\item{idd_env}{An environment or list contains IDD tables including class, +field, and reference.} + +\item{idf_env}{An environment or list contains IDF tables including object, +value, and reference.} + +\item{dt_object}{A \code{\link[data.table:data.table]{data.table::data.table()}} that contains object data. +Usually created using \code{\link[=expand_idf_dots_value]{expand_idf_dots_value()}}.} +} +\value{ +The modified whole IDF data in a named list of 3 +\code{\link[data.table:data.table]{data.table::data.table()}}s, i.e. \code{object}, \code{value} and \code{reference}. +} +\description{ +Remove duplicate objects +} +\keyword{internal} diff --git a/tests/testthat/test_impl-idf.R b/tests/testthat/test_impl-idf.R index fa1667627..1c1e83c0e 100644 --- a/tests/testthat/test_impl-idf.R +++ b/tests/testthat/test_impl-idf.R @@ -1,12 +1,12 @@ context("IDF Implementation") -eplusr_option(validate_level = "final") +eplusr_option(validate_level = "final", verbose_info = FALSE) use_idd(8.8, "auto") # TABLE {{{ test_that("table", { idf_env <- parse_idf_file(text("idf", 8.8)) - idd_env <- ._get_private(use_idd(8.8))$m_idd_env + idd_env <- get_priv_env(use_idd(8.8))$idd_env() # OBJECT {{{ expect_equal(get_idf_object(idd_env, idf_env, 1), @@ -34,18 +34,26 @@ test_that("table", { ) ) expect_equal(get_idf_object(idd_env, idf_env), add_rleid(add_class_name(idd_env, copy(idf_env$object)))) + expect_equal(get_idf_object(idd_env, idf_env, property = "has_name"), + add_rleid(add_class_property(idd_env, add_class_name(idd_env, copy(idf_env$object)), "has_name"))) + expect_equal(get_idf_object(idd_env, idf_env, 55, property = "has_name")$has_name, c(TRUE, TRUE)) expect_equal(get_idf_object(idd_env, idf_env, 55)$object_id, c(1L, 4L)) expect_equal(get_idf_object(idd_env, idf_env, 55, c("WD02", "WD01"))$object_id, c(4L, 1L)) expect_equal(get_idf_object(idd_env, idf_env, "Material")$object_id, c(1L, 4L)) expect_equal(get_idf_object(idd_env, idf_env, "Material", c("WD02", "WD01"))$object_id, c(4L, 1L)) - expect_error(get_idf_object(idd_env, idf_env, 2), class = "error_class_id") - expect_error(get_idf_object(idd_env, idf_env, "Branch"), class = "error_class_name") - expect_error(get_idf_object(idd_env, idf_env, "Material", "wrong"), class = "error_object_name") - expect_error(get_idf_object(idd_env, idf_env, "Material", 15), class = "error_object_id") + expect_error(get_idf_object(idd_env, idf_env, 2), class = "eplusr_error_invalid_class_index") + expect_error(get_idf_object(idd_env, idf_env, "Branch"), class = "eplusr_error_invalid_class_name") + expect_error(get_idf_object(idd_env, idf_env, "Material", "wrong"), class = "eplusr_error_invalid_object_name") + expect_error(get_idf_object(idd_env, idf_env, "Material", 15), class = "eplusr_error_invalid_object_id") expect_equal(get_idf_object(idd_env, idf_env, 55, c("wd02", "wd01"), ignore_case = TRUE)$object_id, c(4L, 1L)) - expect_error(get_idf_object_id(idd_env, idf_env, 10000), class = "error_class_id") - expect_error(get_idf_object_id(idd_env, idf_env, "Branch"), class = "error_class_name") + # can stop if same names found in input class + idf_env1 <- idf_env + idf_env1$object <- rbindlist(list(idf_env1$object, idf_env1$object[1][, object_id := 6L])) + expect_error(get_idf_object(idd_env, idf_env1, object = "WD01"), class = "eplusr_error_multi_match_by_name") + + expect_error(get_idf_object_id(idd_env, idf_env, 10000), class = "eplusr_error_invalid_class_index") + expect_error(get_idf_object_id(idd_env, idf_env, "Branch"), class = "eplusr_error_invalid_class_name") expect_equal(get_idf_object_id(idd_env, idf_env), list(Version = 5L, Material = c(1L, 4L), Construction = 2L, `BuildingSurface:Detailed` = 3L) ) @@ -62,28 +70,53 @@ test_that("table", { expect_equal(get_idf_object_name(idd_env, idf_env, simplify = TRUE), c("WD01", "WALL-1", "WALL-1PF", "WD02", NA_character_) ) - expect_equal(get_idf_object_name(idd_env, idf_env, "Material"), list(Material = c("WD01", "WD02"))) - expect_equal(get_idf_object_name(idd_env, idf_env, 55), list(Material = c("WD01", "WD02"))) - expect_equal(get_idf_object_name(idd_env, idf_env, 55, simplify = TRUE), c("WD01", "WD02")) - expect_equal(get_idf_object_name(idd_env, idf_env, "Material", simplify = TRUE), c("WD01", "WD02")) expect_equal(get_idf_object_num(idd_env, idf_env), 5L) expect_equal(get_idf_object_num(idd_env, idf_env, c(55, 55, 100)), c(2L, 2L, 0L)) - expect_error(get_idf_object_num(idd_env, idf_env, c(55, 55, 10000)), class = "error_invalid_class") + expect_error(get_idf_object_num(idd_env, idf_env, c(55, 55, 10000)), class = "eplusr_error_invalid_class_index") expect_equal(get_idf_object_num(idd_env, idf_env, c("Material", "Material")), c(2L, 2L)) expect_equal(get_idf_object_num(idd_env, idf_env, c("Material", "Material", "Branch")), c(2L, 2L, 0L)) + expect_equal(get_idf_object_num(idd_env, idf_env, c("Version", "Material")), c(1L, 2L)) + + expect_equal(get_idf_object_name(idd_env, idf_env, "Material"), list(Material = c("WD01", "WD02"))) + expect_equal(get_idf_object_name(idd_env, idf_env, 55), list(Material = c("WD01", "WD02"))) + expect_equal(get_idf_object_name(idd_env, idf_env, 55, simplify = TRUE), c("WD01", "WD02")) + expect_equal(get_idf_object_name(idd_env, idf_env, "Material", simplify = TRUE), c("WD01", "WD02")) + expect_equal(get_idf_object_name(idd_env, idf_env, c("Version", "Material")), list(Version = NA_character_, Material = c("WD01", "WD02"))) + expect_equal(get_idf_object_name(idd_env, idf_env, c("Version", "Material"), simplify = TRUE), c(NA_character_, c("WD01", "WD02"))) expect_equal(get_idf_object_id(idd_env, idf_env, 1), list(Version = 5L)) expect_equal(get_idf_object_id(idd_env, idf_env, "Version"), list(Version = 5L)) expect_equal(get_idf_object_id(idd_env, idf_env, 1, simplify = TRUE), 5L) expect_equal(get_idf_object_id(idd_env, idf_env, "Version", simplify = TRUE), 5L) - expect_equal(get_idf_object_name(idd_env, idf_env, c("Version", "Material")), list(Version = NA_character_, Material = c("WD01", "WD02"))) - expect_equal(get_idf_object_name(idd_env, idf_env, c("Version", "Material"), simplify = TRUE), c(NA_character_, c("WD01", "WD02"))) - expect_equal(get_idf_object_num(idd_env, idf_env, c("Version", "Material")), c(1L, 2L)) + expect_equal(get_object_info(add_class_name(idd_env, idf_env$object[1])), " #1| Object ID [1] (name 'WD01') in class 'Material'") expect_equal(get_object_info(add_class_name(idd_env, idf_env$object[5])), " #1| Object ID [5] in class 'Version'") + expect_equal(get_object_info(add_class_name(idd_env, idf_env$object[1]), "class"), " #1| Class 'Material'") + expect_equal(get_object_info(add_class_name(idd_env, idf_env$object[c(1, 4)]), c("id", "class"), by_class = TRUE), " #1| Object ID [1] and ID [4] in class 'Material'") + expect_equal(get_object_info(add_class_name(idd_env, idf_env$object[c(1, 4)][, rleid := 5:6]), "class", by_class = TRUE), sprintf(" #%i| Class 'Material'", 5:6)) expect_equal(get_object_info(idf_env$object[1], c("id", "name")), " #1| Object ID [1] (name 'WD01')") + expect_equal(get_object_info(idf_env$object[1], c("name", "id")), " #1| Object name 'WD01'(ID [1])") expect_equal(get_object_info(idf_env$object[1], c("name")), " #1| Object name 'WD01'") + expect_equal(get_object_info(idf_env$object[1], c("name"), name_prefix = FALSE), " #1| Object 'WD01'") + + # can init object table + expect_equal(init_idf_object(idd_env, idf_env, c("Version", rep("Material", 2))), + data.table(rleid = 1:3, class_id = c(1L, 55L, 55L), + class_name = c("Version", "Material", "Material"), + group_id = c(1L, 5L, 5L), object_id = 6:8, + object_name = c(NA_character_, "Material", "Material 1"), + object_name_lower = c(NA_character_, "material", "material 1"), + comment = list() + ) + ) + expect_equal(init_idf_object(idd_env, NULL, "Material", name = FALSE), + data.table(rleid = 1L, class_id = 55L, + class_name = "Material", group_id = 5L, object_id = 1L, + object_name = NA_character_, object_name_lower = NA_character_, + comment = list() + ) + ) # }}} # VALUE {{{ @@ -331,12 +364,14 @@ test_that("table", { # }}} # misc - expect_error(get_idf_value(idd_env, idf_env, 10000), class = "error_class_id") - expect_error(get_idf_value(idd_env, idf_env, ""), class = "error_class_name") - expect_error(get_idf_value(idd_env, idf_env, object = 10000), class = "error_object_id") - expect_error(get_idf_value(idd_env, idf_env, object = ""), class = "error_object_name") - expect_error(get_idf_value(idd_env, idf_env, "Version", field = 2L), class = "error_bad_field_index") - expect_error(get_idf_value(idd_env, idf_env, "Version", field = "Version"), class = "error_bad_field_name") + expect_error(get_idf_value(idd_env, idf_env, 10000), class = "eplusr_error_invalid_class_index") + expect_error(get_idf_value(idd_env, idf_env, ""), class = "eplusr_error_invalid_class_name") + expect_error(get_idf_value(idd_env, idf_env, object = 10000), class = "eplusr_error_invalid_object_id") + expect_error(get_idf_value(idd_env, idf_env, object = ""), class = "eplusr_error_invalid_object_name") + expect_error(get_idf_value(idd_env, idf_env, "Version", field = 2L), class = "eplusr_error_invalid_field_index") + expect_error(get_idf_value(idd_env, idf_env, "Version", field = "Version"), class = "eplusr_error_invalid_field_name") + expect_error(get_idf_value(idd_env, idf_env, field = "Version"), class = "eplusr_error_missing_class_or_object") + expect_error(get_idf_value(idd_env, idf_env, c("Material", "Construction"), field = 1), class = "eplusr_error_invalid_field_length") expect_equal(get_idf_value(idd_env, idf_env, "Version")$value_id, 44L) expect_equal(get_idf_value(idd_env, idf_env, "Version", field = 1L)$value_id, 44L) @@ -357,677 +392,1662 @@ test_that("table", { expect_equal(get_idf_value(idd_env, idf_env, c("Construction", "Material"), field = fld_nm, align = TRUE)$value_id, c(13L, 9L, -1L) ) - # }}} - # RELATION {{{ - expect_equal(get_idf_relation(idd_env, idf_env), - data.table( - object_id = c(rep(2L, 4), rep(3L, 2), rep(2L, 4)), - value_id = c(11L:14L, 17L, 18L, 11L:14L), - src_object_id = c(1L, rep(NA, 3), 2L, NA, 1L, rep(NA, 3)), - src_value_id = c(1L, rep(NA, 3), 10L, NA, 1L, rep(NA, 3)), - src_enum = c(2L, rep(NA, 3), 2L, NA, 2L, rep(NA, 3)), - dep = c(rep(0L, 6L), rep(1L, 4L)) - ) - ) + # can init value table + idf_env1 <- idf_env + idf_env1$value <- idf_env1$value[0] + expect_equal(init_idf_value(idd_env, idf_env1, "Material")$value_id, 1:6) - idf_env <- parse_idf_file(example()) - idd_env <- ._get_private(use_idd(8.8))$m_idd_env - id <- get_idf_object_id(idd_env, idf_env, "Material")$Material - expect_equal( - get_idf_relation(idd_env, idf_env, id, depth = NULL, direction = "ref_by"), - data.table(object_id = c(16L, 25L), value_id = c(111L, 220L), - src_object_id = c(14L, 16L), src_value_id = c(99L, 110L), - src_enum = c(2L, 2L), dep = c(0L, 1L) + expect_equivalent(init_idf_value(idd_env, idf_env, "Material"), + data.table(rleid = 1L, class_id = 55L, class_name = "Material", + object_id = NA_integer_, object_name = NA_character_, + field_id = 7081:7086, field_index = 1:6, + field_name = c("Name", "Roughness", "Thickness", "Conductivity", "Density", "Specific Heat"), + value_id = 45:50, value_chr = NA_character_, value_num = NA_real_ ) ) - expect_equal( - get_idf_node_relation(idd_env, idf_env, id, depth = NULL), - set(idf_env$reference[0L], NULL, "dep", integer()) + expect_equivalent(init_idf_value(idd_env, idf_env, "Material", property = "is_name"), + data.table(rleid = 1L, class_id = 55L, class_name = "Material", + object_id = NA_integer_, object_name = NA_character_, + field_id = 7081:7086, field_index = 1:6, + field_name = c("Name", "Roughness", "Thickness", "Conductivity", "Density", "Specific Heat"), + value_id = 45:50, value_chr = NA_character_, value_num = NA_real_, + is_name = c(TRUE, rep(FALSE, 5)) + ) ) # }}} + + # VALUE RELATION {{{ + # read idf + idf_env <- parse_idf_file(example(), 8.8) + idd_env <- get_priv_env(use_idd(8.8))$idd_env() + + expect_is(rel <- get_idf_relation(idd_env, idf_env, direction = "ref_to"), "data.table") + expect_equal(nrow(rel), 21L) + + expect_is(rel <- get_idf_relation(idd_env, idf_env, direction = "ref_by"), "data.table") + expect_equal(nrow(rel), 21L) + + # can specify object id + expect_equal(nrow(get_idf_relation(idd_env, idf_env, object_id = 15L, direction = "ref_to")), 1L) + expect_equal(nrow(get_idf_relation(idd_env, idf_env, object_id = 15L, direction = "ref_by")), 4L) + + # can specify value id + expect_equal(nrow(get_idf_relation(idd_env, idf_env, value_id = 109L, direction = "ref_to")), 1L) + expect_equal(nrow(get_idf_relation(idd_env, idf_env, value_id = 114L, direction = "ref_by")), 8L) + + # can specify both object id and value id + expect_equal(nrow(get_idf_relation(idd_env, idf_env, 15L, 109L, direction = "ref_to")), 1L) + + # can keep all input id + expect_is(ref <- get_idf_relation(idd_env, idf_env, value_id = 100:110, direction = "ref_to", keep_all = TRUE), "data.table") + expect_equal(ref$value_id, 100:110) + expect_equal(ref$src_object_id, c(rep(NA, 9), 12L, NA)) + + # can detect multiple depth + idf_env <- parse_idf_file(system.file("extdata/1ZoneUncontrolled.idf", package = "eplusr"), 8.8) + idd_env <- get_priv_env(use_idd(8.8))$idd_env() + expect_equal(get_idf_relation(idd_env, idf_env, 21L, depth = NULL)$dep, c(0L, 0L, 1L)) + + # can add format columns + expect_is(rel <- get_idf_relation(idd_env, idf_env, 21L, depth = NULL, name = TRUE), "data.table") + expect_equal(names(rel), c( + "class_id", "class_name", + "object_id", "object_name", + "field_id", "field_index", "field_name", + "value_id", "value_chr", "value_num", "type_enum", + "src_class_id", "src_class_name", + "src_object_id", "src_object_name", + "src_field_id", "src_field_index", "src_field_name", + "src_value_id", "src_value_chr", "src_value_num", "src_type_enum", + "src_enum", "dep" + )) + + # can specify target group + expect_equal(get_idf_relation(idd_env, idf_env, 51L, depth = NULL, group = "Schedules", name = TRUE)$src_class_name, "Schedule:Constant") + + # can specify target class + expect_equal(get_idf_relation(idd_env, idf_env, 51L, depth = NULL, class = "Schedule:Constant", name = TRUE)$src_class_name, "Schedule:Constant") + + # can specify target object + expect_equal(get_idf_relation(idd_env, idf_env, 51L, object = 53L, name = TRUE)$src_object_name, "AlwaysOn") + + # read a more complex model + if (!is_avail_eplus(8.8)) install_eplus(8.8) + path_idf <- file.path(eplus_config(8.8)$dir, "ExampleFiles", "5Zone_Transformer.idf") + idf_env <- parse_idf_file(path_idf, 8.8) + idd_env <- get_priv_env(use_idd(8.8))$idd_env() + + # can handle class-name-references + expect_equal(nrow(get_idf_relation(idd_env, idf_env, 217L, direction = "ref_to")), 8L) + expect_equal(nrow(get_idf_relation(idd_env, idf_env, 217L, direction = "ref_to", class_ref = "none")), 4L) + expect_equal(nrow(get_idf_relation(idd_env, idf_env, 217L, direction = "ref_to", class_ref = "all")), 15L) + # }}} + + # NODE RELATION {{{ + if (!is_avail_eplus(8.8)) install_eplus(8.8) + + # read idf + path_idf <- file.path(eplus_config(8.8)$dir, "ExampleFiles", "5Zone_Transformer.idf") + idf_env <- parse_idf_file(path_idf, 8.8) + idd_env <- get_priv_env(use_idd(8.8))$idd_env() + + id <- get_idf_value(idd_env, idf_env, object = 277L, field = 5)$value_id + expect_equal(nrow(get_idf_node_relation(idd_env, idf_env, value_id = id, depth = NULL)), 10L) + expect_equal(nrow(get_idf_node_relation(idd_env, idf_env, 277L, depth = NULL)), 12L) + # }}} }) # }}} # NAME DOTS {{{ test_that("NAME DOTS", { - expect_error(sep_name_dots(), class = "error_empty_input") - expect_error(sep_name_dots(NULL), class = "error_wrong_type") - expect_error(sep_name_dots(list()), class = "error_wrong_type") - expect_error(sep_name_dots(NA), class = "error_wrong_type") - expect_error(sep_name_dots(NA_character_), class = "error_wrong_type") - expect_error(sep_name_dots(TRUE), class = "error_wrong_type") - expect_error(sep_name_dots(NaN), class = "error_wrong_type") - expect_error(sep_name_dots(Inf), class = "error_wrong_type") - expect_error(sep_name_dots(0), class = "error_wrong_type") - expect_error(sep_name_dots(list(0)), class = "error_wrong_type") - expect_warning({ - x <- c("e", "f"); y <- c(5L, 6L); z <- c(z = "g") - nm <- sep_name_dots(1:2, c("a", "b"), c = 1, d = "z", x, y, z = z) - }) - expect_equal(nm$id, - data.table( - rleid = c(1L, 1L, 3L, 6L, 6L), - object_rleid = c(1L, 2L, 1L, 1L, 2L), - object_id = c(1L, 2L, 1L, 5L, 6L), - new_object_name = c(rep(NA_character_, 2L), "c", rep(NA_character_, 2L)) + # read idf + idf <- read_idf(example(), 8.8) + idf_env <- get_priv_env(idf)$idf_env() + idd_env <- get_priv_env(idf)$idd_env() + + # can stop if empty input + expect_error(expand_idf_dots_name(idd_env, idf_env)) + # can stop if NULL + expect_error(expand_idf_dots_name(idd_env, idf_env, NULL)) + # can stop if not integer or character + expect_error(expand_idf_dots_name(idd_env, idf_env, list())) + expect_error(expand_idf_dots_name(idd_env, idf_env, TRUE)) + expect_error(expand_idf_dots_name(idd_env, idf_env, NaN)) + expect_error(expand_idf_dots_name(idd_env, idf_env, Inf)) + expect_error(expand_idf_dots_name(idd_env, idf_env, list(0))) + + # can stop if contains NA + expect_error(expand_idf_dots_name(idd_env, idf_env, NA)) + expect_error(expand_idf_dots_name(idd_env, idf_env, NA_character_)) + expect_error(expand_idf_dots_name(idd_env, idf_env, NA_integer_)) + + # can work with only object ID inputs + expect_equal( + expand_idf_dots_name(idd_env, idf_env, 1:2, a = 3, .property = "has_name")[, -"comment"], + data.table(rleid = 1:3, object_id = 1:3, class_id = c(1L, 13L, 3L), + object_name = c(NA_character_, NA_character_, "Simple One Zone (Wireframe DXF)"), + object_name_lower = c(NA_character_, NA_character_, "simple one zone (wireframe dxf)"), + class_name = c("Version", "Timestep", "Building"), + has_name = c(FALSE, FALSE, TRUE), + new_object_name = c(NA_character_, NA_character_, "a") ) ) - expect_equal(nm$name, - data.table( - rleid = c(2L, 2L, 4L, 5L, 5L, 7L), - object_rleid = c(1L, 2L, 1L, 1L, 2L, 1L), - object_name = c("a", "b", "z", "e", "f", "g"), - new_object_name = c(rep(NA_character_, 2L), "d", rep(NA_character_, 2L), "z") + + # can exclude input names + expect_equal( + expand_idf_dots_name(idd_env, idf_env, 1:2, 3, .keep_name = FALSE)[, -"comment"], + data.table(rleid = 1:3, object_id = 1:3, class_id = c(1L, 13L, 3L), + object_name = c(NA_character_, NA_character_, "Simple One Zone (Wireframe DXF)"), + object_name_lower = c(NA_character_, NA_character_, "simple one zone (wireframe dxf)"), + class_name = c("Version", "Timestep", "Building") + ) + ) + + # can work with only object name inputs + expect_equal( + expand_idf_dots_name(idd_env, idf_env, Floor = "floor", c("zone one", l = "extlights"))[, -"comment"], + data.table(rleid = 1:3, object_id = c(16L, 18L, 49L), class_id = c(90L, 100L, 277L), + object_name = c("FLOOR", "ZONE ONE", "ExtLights"), + object_name_lower = c("floor", "zone one", "extlights"), + class_name = c("Construction", "Zone", "Exterior:Lights"), + new_object_name = c("Floor", NA_character_, "l") + ) + ) + + # can exclude input names + expect_equal( + expand_idf_dots_name(idd_env, idf_env, Floor = "floor", c("zone one", l = "extlights"), .keep_name = FALSE)[, -"comment"], + data.table(rleid = 1:3, object_id = c(16L, 18L, 49L), class_id = c(90L, 100L, 277L), + object_name = c("FLOOR", "ZONE ONE", "ExtLights"), + object_name_lower = c("floor", "zone one", "extlights"), + class_name = c("Construction", "Zone", "Exterior:Lights") + ) + ) + + # can work with both object ID and name inputs + expect_equal( + expand_idf_dots_name(idd_env, idf_env, 1L, Floor = "floor")[, -"comment"], + data.table(rleid = 1:2, object_id = c(1L, 16L), class_id = c(1L, 90L), + object_name = c(NA_character_, "FLOOR"), + object_name_lower = c(NA_character_, "floor"), + class_name = c("Version", "Construction"), + new_object_name = c(NA_character_, "Floor") ) ) - expect_equal(nm$dot, data.table(rleid = 1L:7L, - dot = list(c(1L, 2L), c("a", "b"), 1L, "z", c("e", "f"), c(5L, 6L), c(z = "g")), - dot_nm = c(rep(NA_character_, 2L), "c", "d", rep(NA_character_, 2L), "z"), - type = c(1L, 2L, 1L, 2L, 2L, 1L, 2L) - )) }) # }}} # VALUE DOTS {{{ test_that("VALUE DOTS", { - expect_error(sep_value_dots(NULL), class = "error_dot_invalid_format") - expect_error(sep_value_dots(list()), class = "error_dot_invalid_format") - expect_error(sep_value_dots(1), class = "error_dot_invalid_format") - expect_error(sep_value_dots("a"), class = "error_dot_invalid_format") - expect_error(sep_value_dots(NA), class = "error_dot_invalid_format") - expect_error(sep_value_dots(NA_character_), class = "error_dot_invalid_format") - expect_error(sep_value_dots(NA_integer_), class = "error_dot_invalid_format") - expect_error(sep_value_dots(character()), class = "error_dot_invalid_format") - expect_error(sep_value_dots(integer()), class = "error_dot_invalid_format") - expect_error(sep_value_dots(double()), class = "error_dot_invalid_format") - expect_error(sep_value_dots(logical()), class = "error_dot_invalid_format") - expect_error(sep_value_dots(cls = NULL), class = "error_dot_invalid_format") - expect_error(sep_value_dots(cls = "a"), class = "error_dot_invalid_format") - expect_error(sep_value_dots(cls = NA_integer_), class = "error_dot_invalid_format") - - # can change empty string to NA - expect_equal(sep_value_dots(cls = list("", " ", " "))$value$value_chr, rep(NA_character_, 3L)) - - # missing class name - expect_error(sep_value_dots(list(NULL)), class = "error_dot_invalid_format") - expect_error(sep_value_dots(list(NULL, NULL)), class = "error_dot_invalid_format") - expect_error(sep_value_dots(list(NULL, NA)), class = "error_dot_invalid_format") - expect_error(sep_value_dots(list(NULL, c(NA, NA, NA))), class = "error_dot_invalid_format") - expect_error(sep_value_dots(list(NULL, 1)), class = "error_dot_invalid_format") - expect_error(sep_value_dots(list(NULL, c(1, 2))), class = "error_dot_invalid_format") - expect_error(sep_value_dots(list(NULL, "a")), class = "error_dot_invalid_format") - expect_error(sep_value_dots(list(NULL, NA_character_)), class = "error_dot_invalid_format") - expect_error(sep_value_dots(list(NULL, NA_integer_)), class = "error_dot_invalid_format") - expect_error(sep_value_dots(list(NA)), class = "error_dot_invalid_format") - expect_error(sep_value_dots(list(NA, "a")), class = "error_dot_invalid_format") - expect_error(sep_value_dots(list(list())), class = "error_dot_invalid_format") - expect_error(sep_value_dots(list(list(NULL))), class = "error_dot_invalid_format") - expect_error(sep_value_dots(list(list(NA))), class = "error_dot_invalid_format") - expect_error(sep_value_dots(list(list("a"))), class = "error_dot_invalid_format") - expect_error(sep_value_dots(list(list(NULL, NULL), list()), .empty = TRUE), class = "error_dot_invalid_format") - expect_error(sep_value_dots(cls = list(NULL, NULL, list()), .empty = TRUE), class = "error_dot_invalid_format") - - # invalid list format - expect_error(sep_value_dots(cls = list(list("a")), class = "error_dot_invalid_format")) - expect_error(sep_value_dots(cls = list(1, list())), class = "error_dot_invalid_format") - expect_error(sep_value_dots(cls = list(list())), class = "error_dot_invalid_format") - expect_error(sep_value_dots(cls = list(list(NULL, NULL))), class = "error_dot_invalid_format") - expect_error(sep_value_dots(list(cls = list(list()))), class = "error_dot_invalid_format") - expect_error(sep_value_dots(list(cls = list(list(NULL, NULL)))), class = "error_dot_invalid_format") - expect_error(sep_value_dots(list(cls = list(1, list()))), class = "error_dot_invalid_format") - expect_error(sep_value_dots(cls = list(1, list(NULL))), class = "error_dot_invalid_format") - expect_error(sep_value_dots(cls = list(1, list("a"))), class = "error_dot_invalid_format") - expect_error(sep_value_dots(list("Material" = list(), Construction = NULL))) - expect_error(sep_value_dots(list("Material" = list(), NULL))) - - # contains NA - expect_error(sep_value_dots(cls = list(NA)), class = "error_dot_invalid_format") - expect_error(sep_value_dots(cls = list(NULL, NA)), class = "error_dot_invalid_format") - expect_error(sep_value_dots(list(cls = list(NULL, NA))), class = "error_dot_invalid_format") - expect_error(sep_value_dots(cls1 = list(fld1 = c(NA_character_, 1)), .scalar = FALSE), class = "error_dot_invalid_format") - - # multiple .comment - expect_error(sep_value_dots(cls = list(.comment = c("a"), .comment = NULL)), class = "error_dot_multi_comment") - expect_error(sep_value_dots(list(cls = list(.comment = c("a"), .comment = NULL))), class = "error_dot_multi_comment") - - # duplicated field names - expect_error(sep_value_dots(cls = list(Name = "const", Name = "const1")), class = "error_dot_dup_field_name") - expect_error(sep_value_dots(list(cls = list(Name = "const", Name = "const1"))), class = "error_dot_dup_field_name") - - # empty objects - expect_error(sep_value_dots(cls = list(), .empty = FALSE), class = "error_dot_empty") - expect_error(sep_value_dots(list(cls = list()), .empty = FALSE), class = "error_dot_empty") - expect_silent({l <- sep_value_dots( - cls = list(), cls = list(NULL), list(cls = list(), cls = list(NULL)), - .empty = TRUE) - }) - expect_equivalent(l$object, - data.table(rleid = c(1L, 2L, 3L, 3L), object_rleid = c(1L, 1L, 1L, 2L), - name = rep("cls", 4L), comment = list(rep(NULL, 4L)), - empty = rep(c(TRUE, FALSE), 2L) - ) - ) - expect_equivalent(l$value, - data.table(rleid = c(2L, 3L), object_rleid = c(1L, 2L), - field_name = rep(NA_character_, 2L), value = rep(NA_character_, 2L), - value_num = rep(NA_real_, 2L), defaulted = rep(TRUE, 2L) - ) - ) - - # comment-only object - expect_silent({l <- sep_value_dots(cls = list(.comment = c("this is", "a comment")))}) - expect_equal(nrow(l$value), 0L) - expect_equal(l$object, data.table(rleid = 1L, object_rleid = 1L, name = "cls", - empty = TRUE, comment = list(c("this is", "a comment")))) + # parse_dots_value {{{ + # can stop if empty input + expect_error(parse_dots_value(), "missing value") + expect_error(parse_dots_value(NULL), "missing value") - # normal objects - expect_silent( - l <- sep_value_dots( - # empty - cls1 = list(), - cls2 = list(.comment = c("a", "b")), - cls3 = list(NULL, NULL, fld1 = NULL, .comment = c("a", "b")), - cls4 = list(NULL, fld1 = "a", fld2 = 2L, fld3 = NULL, "a", 1L, .comment = c("a", "b")), - list(cls5 = list(.comment = c("a", "b"))), - list(cls6 = list(NULL, NULL, fld1 = NULL, .comment = c("a", "b"))), - list(cls7 = list(fld1 = NULL, fld2 = "a", NULL, 2L, fld3 = NULL, .comment = c("a", "b"))), - .empty = TRUE - ) - ) - expect_equivalent(l$object, - data.table(rleid = 1L:7L, - object_rleid = rep(1L, 7L), - name = paste0("cls", 1L:7L), - comment = c(list(NULL), rep(list(c("a", "b")), 6L)), - empty = c(rep(TRUE, 2L), rep(FALSE, 2L), TRUE, rep(FALSE, 2L)) - ) - ) - expect_equivalent(l$value, - data.table(rleid = c(rep(3L, 3L), rep(4L, 6L), rep(6L, 3L), rep(7L, 5L)), - object_rleid = rep(1L, 17L), - field_name = c(rep(NA_character_, 2L), "fld1", NA_character_, - paste0("fld", 1L:3L), rep(NA_character_, 4L), paste0("fld", c(1, 1, 2)), - rep(NA_character_, 2L), "fld3"), - value = c(rep(NA_character_, 4L), "a", "2", NA_character_, "a", "1", - rep(NA_character_, 4L), "a", NA_character_, "2", NA_character_ - ), - value_num = c(rep(NA_real_, 5L), 2, rep(NA_real_, 2L), - 1, rep(NA_real_, 6L), 2, NA_real_ - ), - defaulted = c(rep(TRUE, 4L), FALSE, FALSE, TRUE, FALSE, FALSE, - rep(TRUE, 4L), FALSE, TRUE, FALSE, TRUE - ) + # can stop if not named + expect_error(parse_dots_value(list()), class = "eplusr_error_dots_no_name") + expect_error({x <- list(1); parse_dots_value(x)}, class = "eplusr_error_dots_no_name") + expect_error(parse_dots_value(1), class = "eplusr_error_dots_no_name") + + # can stop if not list + expect_error(parse_dots_value(cls = "a"), "list") + + # can stop if missing value + expect_error(parse_dots_value(cls = list(NA_character_)), "missing") + + # can stop if multiple value + expect_error(parse_dots_value(cls = list(1:3)), "length") + + # can stop if nested list + expect_error(parse_dots_value(cls = list(list())), "types") + + # can stop if duplicated field name + expect_error(parse_dots_value(cls = list(..1 = "", ..1 = "")), "duplicated") + + # can stop if invalid LHS of ":=" + expect_error(parse_dots_value(f(x) := list(..1 = "name")), class = "eplusr_error_dots_ref_lhs") + + # can stop if LHS of ":=" is not allowed + expect_error(parse_dots_value(a := list(..1 = "name"), .ref_assign = FALSE), class = "eplusr_error_dots_ref") + + # can stop if LHS of ":=" is not allowed + expect_error(parse_dots_value(c(1, 2) := list(..1 = "name", ..2 = "sch", 1:3), .scalar = FALSE, .pair = TRUE), class = "eplusr_error_dots_pair_length") + + # can separate numeric and character value + expect_equal(parse_dots_value(cls = list(..1 = "name", ..2 = 1L, NULL, NULL)), + list(object = data.table(rleid = 1L, each_rleid = 1L, id = NA_integer_, name = "cls", + comment = list(), is_ref = FALSE, lhs_sgl = FALSE, rhs_sgl = TRUE, is_empty = FALSE), + value = data.table(rleid = 1L, each_rleid = 1L, id = NA_integer_, name = "cls", + field_index = c(1:2, rep(NA_integer_, 2)), field_name = NA_character_, + value_chr = c("name", "1", rep(NA_character_, 2)), + value_num = c(NA_real_, 1, NA_real_, NA_real_) + ) ) ) - # multiple values support - expect_silent( - l <- sep_value_dots( - cls1 = list(fld1 = c(1, 2, 3), fld2 = c("a", "b", "c")), - list(cls2 = list(fld3 = c(4, 5), fld4 = c("d", "e"))), - .scalar = FALSE + # can store multiple values + expect_equal(parse_dots_value(cls = list(..1 = c("name1", "name2"), ..2 = 1:3, NULL, NULL), .scalar = FALSE), + list(object = data.table(rleid = 1L, each_rleid = 1L, id = NA_integer_, name = "cls", + comment = list(), is_ref = FALSE, lhs_sgl = FALSE, rhs_sgl = FALSE, is_empty = FALSE), + value = data.table(rleid = 1L, each_rleid = 1L, id = NA_integer_, name = "cls", + field_index = c(1:2, rep(NA_integer_, 2)), field_name = NA_character_, + value_chr = list(c("name1", "name2"), c("1", "2", "3"), NA_character_, NA_character_), + value_num = list(rep(NA_real_, 2), 1:3, NA_real_, NA_real_) + ) ) ) - expect_equivalent(l$object, - data.table(rleid = 1L:2L, - object_rleid = rep(1L, 2L), - name = paste0("cls", 1L:2L), - empty = rep(FALSE, 2L), - comment = rep(list(NULL), 2L) + + # can convert empty string to NA + expect_equal(parse_dots_value(cls = list(roughness = "", ..2 = " ", name = " ", ..4 = NULL)), + list(object = data.table(rleid = 1L, each_rleid = 1L, id = NA_integer_, name = "cls", + comment = list(), is_ref = FALSE, lhs_sgl = FALSE, rhs_sgl = TRUE, is_empty = FALSE), + value = data.table(rleid = 1L, each_rleid = 1L, id = NA_integer_, name = "cls", + field_index = c(NA_integer_, 2L, NA_integer_, 4L), + field_name = c("roughness", NA_character_, "name", NA_character_), + value_chr = NA_character_, value_num = NA_real_ + ) ) ) - expect_equivalent(l$value, - data.table(rleid = c(rep(1L, 2L), rep(2L, 2L)), - object_rleid = rep(1L, 4L), - field_name = paste0("fld", 1L:4L), - value_chr = list(c("1", "2", "3"), c("a", "b", "c"), c("4", "5"), c("d", "e")), - value_num = list(c(1, 2, 3), rep(NA_real_, 3L), c(4, 5), rep(NA_real_, 2L)), - defaulted = rep(FALSE, 4L) + + # can detect empty object + expect_equal(parse_dots_value(cls = list(), .empty = TRUE), + list(object = data.table(rleid = 1L, each_rleid = 1L, id = NA_integer_, name = "cls", + comment = list(), is_ref = FALSE, lhs_sgl = FALSE, rhs_sgl = TRUE, is_empty = TRUE), + value = data.table(rleid = 1L, each_rleid = 1L, id = NA_integer_, name = "cls", + field_index = NA_integer_, field_name = NA_character_, + value_chr = NA_character_, value_num = NA_real_ + ) ) ) - # whole-class support - expect_silent(l <- sep_value_dots(cls1 := list(fld1 = 1, fld2 = 2))) - expect_equivalent(l$object, - data.table(rleid = 1L, object_rleid = 1L, name = "cls1", empty = FALSE, comment = list()) + # can use single name on LHS of ":=" + expect_equal(parse_dots_value(cls := list(..1 = "name")), + list(object = data.table(rleid = 1L, each_rleid = 1L, id = NA_integer_, name = "cls", + comment = list(), is_ref = TRUE, lhs_sgl = TRUE, rhs_sgl = TRUE, is_empty = FALSE), + value = data.table(rleid = 1L, each_rleid = 1L, id = NA_integer_, name = "cls", + field_index = 1L, field_name = NA_character_, + value_chr = "name", value_num = NA_real_ + ) + ) ) - expect_equivalent(l$value, - data.table(rleid = 1L, object_rleid = 1L, field_name = paste0("fld", 1L:2L), - value_chr = c("1", "2"), value_num = c(1, 2), defaulted = rep(FALSE, 2L) + + # can use multiple inputs on LHS of ":=" + expect_equal(parse_dots_value(c(1:3) := list(..1 = "name")), + list(object = data.table(rleid = 1L, each_rleid = 1:3, id = 1:3, name = NA_character_, + comment = list(), is_ref = TRUE, lhs_sgl = FALSE, rhs_sgl = TRUE, is_empty = FALSE), + value = data.table(rleid = 1L, each_rleid = 1:3, id = 1:3, name = NA_character_, + field_index = 1L, field_name = NA_character_, + value_chr = "name", value_num = NA_real_ + ) ) ) - # multi-object support - expect_silent(l <- sep_value_dots(.(..1, ..2) := list(fld1 = 1, fld2 = 2))) - expect_equivalent(l$object, - data.table(rleid = 1L, object_rleid = 1L:2L, name = c("..1", "..2"), empty = FALSE, comment = list()) + # can stop if multiple value for normal list when .pair is TRUE + expect_error( + parse_dots_value( + ..11 = list(1:2), # invalid + # single id & multi field & multi value + ..12 = list(1:2, 3:4), # invalid + .scalar = FALSE, .pair = TRUE + ), class = "eplusr_error_dots_pair_length" ) - expect_equivalent(l$value, - data.table(rleid = 1L, object_rleid = c(1L, 1L, 2L, 2L), - field_name = rep(paste0("fld", 1L:2L), 2L), - value_chr = rep(c("1", "2"), 2L), - value_num = rep(c(1, 2), 2L), defaulted = FALSE + + # can match multiple id and single value input + expect_equal( + parse_dots_value(c(5:6) := list(1), .scalar = FALSE, .pair = FALSE), + list( + object = data.table(rleid = 1L, each_rleid = 1:2, id = 5:6, + name = NA_character_, comment = list(), + is_ref = TRUE, lhs_sgl = FALSE, rhs_sgl = TRUE, is_empty = FALSE + ), + value = data.table(rleid = 1L, each_rleid = 1:2, id = 5:6, name = NA_character_, + field_index = NA_integer_, field_name = NA_character_, + value_chr = list("1"), + value_num = list(1) + ) ) ) -}) -# }}} -# DEFINITION DOTS {{{ -test_that("DEFINITION DOTS", { - expect_error(sep_definition_dots(), class = "error_empty_input") - expect_error(sep_definition_dots(NULL), class = "error_wrong_type") - expect_error(sep_definition_dots(list()), class = "error_wrong_type") - expect_error(sep_definition_dots(NA_character_), class = "error_wrong_type") - expect_error(sep_definition_dots(c("a", NA_character_)), class = "error_wrong_type") - expect_error(sep_definition_dots(data.table()), class = "error_wrong_type") - - expect_error(sep_definition_dots("Version,8.8;"), class = "error_parse_idf") - - idd <- use_idd(8.8) - mat1 <- idd$Material$to_table() - expect_error(sep_definition_dots(mat1), class = "error_wrong_type") - - set(mat1, NULL, "value", c("", " ", " ", rep(NA_character_, 3))) - - expect_equal(sep_definition_dots(mat1), - list(parsed = list(), - value = data.table(rleid = 1L, object_id = 1L, class_name = "Material", - field_index = 1:6, value_chr = NA_character_, value_num = NA_real_, - defaulted = TRUE, type = 1L - ), - dot = data.table(rleid = 1L, dot = list(mat1), dot_nm = NA_character_, depth = 2L) - ) - ) - - const1 <- idd$Construction$to_string(all = TRUE) - const2 <- idd$Construction$to_string() - expect_equivalent(sep_definition_dots(const1, const2, .version = 8.8), - list(parsed = list( - version = numeric_version("8.8.0"), - options = list(idf_editor = FALSE, special_format = FALSE, view_in_ip = FALSE, save_format = "sorted"), - object = data.table(object_id = 1:2, class_id = 90L, comment = list(NULL), - object_name = NA_character_, object_name_lower = NA_character_, rleid = 1L - ), - value = data.table(value_id = 1:13, value_chr = NA_character_, - value_num = NA_real_, object_id = c(rep(1L, 11), rep(2L, 2)), - field_id = c(11006:11016, 11006:11007), rleid = 1L - ), - reference = data.table(object_id = integer(), value_id = integer(), - src_object_id = integer(), src_value_id = integer(), - src_enum = integer() + # can pair multiple id and multiple value input + expect_equal( + parse_dots_value( + # multi id & single field & multi value + c(1:2) := list(..1 = c("name1", "name2")), + # multi id & multi field & multi value + c(3:4) := list(..1 = c("name1", "name2"), ..2 = 1:2, NULL, "a"), + # multi id & single field & scalar value + c(5:6) := list(1), + # multi id & multi field & scalar value + c(7:8) := list(1, 2), + # single id & single field & scalar value + ..9 = list(1), + # single id & multi field & scalar value + ..10 = list(1, 2), + cls := list(1:2), + .scalar = FALSE, .pair = TRUE + ), + + list( + object = data.table( + rleid = c(1L, 1L, 2L, 2L, 3L, 3L, 4L, 4L, 5L, 6L, 7L, 7L), + each_rleid = c(rep(1:2, 4), 1L, 1L, 1:2), + id = c(1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, NA, NA), + name = c(rep(NA_character_, 10), "cls", "cls"), comment = list(), + is_ref = c(rep(TRUE, 8), rep(FALSE, 2), TRUE, TRUE), + lhs_sgl = c(rep(FALSE, 10), TRUE, TRUE), + rhs_sgl = c(rep(FALSE, 4), rep(TRUE, 6), rep(FALSE, 2)), + is_empty = FALSE + ), + value = data.table( + rleid = c(rep(1L, 2), rep(2L, 8), rep(3L, 2), rep(4L, 4), 5L, rep(6L, 2), rep(7L, 2)), + each_rleid = c(1:2, rep(1:2, each = 4), 1:2, rep(1:2, each = 2), 1L, rep(1L, 2), 1:2), + id = c(1L, 2L, rep(3L, 4), rep(4L, 4), 5L, 6L, rep(7L, 2), rep(8L, 2), 9L, rep(10L, 2), NA, NA), + name = c(rep(NA_character_, 19), "cls", "cls"), + field_index = c(1L, 1L, 1L, 2L, rep(NA, 2), 1L, 2L, rep(NA, 13)), + field_name = NA_character_, + value_chr = c( + "name1", "name2", + "name1", "1", NA, "a", "name2", "2", NA, "a", + "1", "1", + "1", "2", "1", "2", + "1", + "1", "2", + "1", "2"), + value_num = c( + NA, NA, + NA, 1, NA, NA, NA, 2, NA, NA, + 1, 1, + 1, 2, 1, 2, + 1, + 1, 2, + 1, 2 ) - ), - value = data.table(), - dot = data.table(rleid = 1:2, dot = list(const1, const2), - dot_nm = NA_character_, depth = 1L + ) + ) + ) + + # can stop if id and value length is not the same + expect_error( + parse_dots_value(c(1:3) := list(..1 = c("name1", "name2"), ..2 = 1:3), .scalar = FALSE, .pair = TRUE), + class = "eplusr_error_dots_pair_length" + ) + + # can use variable input on LHS of ":=" + expect_equal({x <- 1:3; parse_dots_value(c(x) := list(..1 = "name"))}, + list(object = data.table(rleid = 1L, each_rleid = 1:3, id = 1:3, name = NA_character_, + comment = list(), is_ref = TRUE, lhs_sgl = FALSE, rhs_sgl = TRUE, is_empty = FALSE), + value = data.table(rleid = 1L, each_rleid = 1:3, id = 1:3, name = NA_character_, + field_index = 1L, field_name = NA_character_, + value_chr = "name", value_num = NA_real_ + ) + ) + ) + expect_equal({x <- 1:3; parse_dots_value(.(x) := list(..1 = "name"))}, + list(object = data.table(rleid = 1L, each_rleid = 1:3, id = 1:3, name = NA_character_, + comment = list(), is_ref = TRUE, lhs_sgl = FALSE, rhs_sgl = TRUE, is_empty = FALSE), + value = data.table(rleid = 1L, each_rleid = 1:3, id = 1:3, name = NA_character_, + field_index = 1L, field_name = NA_character_, + value_chr = "name", value_num = NA_real_ ) ) ) -}) -# }}} -# DUP {{{ -test_that("Dup", { - # read idf - idf <- read_idf(example(), 8.8) - idf_env <- ._get_private(idf)$m_idf_env - idd_env <- ._get_private(idf)$idd_env() - - expect_error(dup_idf_object(idd_env, idf_env), class = "error_empty_input") - expect_error(dup_idf_object(idd_env, idf_env, 1), class = "error_dup_version") - # unique object: SimulationControl - expect_error(dup_idf_object(idd_env, idf_env, 7), class = "error_dup_unique") - - expect_error(dup_idf_object(idd_env, idf_env, shit = 7, fuck = 7), class = "error_dup_unique") - - expect_silent({dup <- dup_idf_object(idd_env, idf_env, `NewFloor` = "FLOOR")}) - expect_equivalent(dup$object, data.table(object_id = 54L, class_id = 90L, - comment = list(), object_name = "NewFloor", object_name_lower = "newfloor")) - expect_equivalent(dup$value, data.table(value_id = c(349L, 350L), - value_chr = c("NewFloor", "C5 - 4 IN HW CONCRETE"), - value_num = c(NA_real_, NA_real_), object_id = c(54L, 54L), - field_id = c(11006L, 11007L))) - expect_equal(dup$reference[.N], data.table(object_id = 54L, value_id = 350L, - src_object_id = 14L, src_value_id = 99L, src_enum = 2L)) - - expect_error(dup_idf_object(idd_env, idf_env, FLOOR = "FLOOR"), fixed = TRUE, - class = "error_validity") - expect_silent({dup <- dup_idf_object(idd_env, idf_env, rep("FLOOR", 10))}) - expect_equal(dup$object$object_name, paste0("FLOOR_", 1:10)) -}) -# }}} + # can accept quote input on LHS of ":=" + expect_equal({x <- quote(cls := list(..1 = "name")); parse_dots_value(x)}, + list(object = data.table(rleid = 1L, each_rleid = 1L, id = NA_integer_, name = "cls", + comment = list(), is_ref = TRUE, lhs_sgl = TRUE, rhs_sgl = TRUE, is_empty = FALSE), + value = data.table(rleid = 1L, each_rleid = 1L, id = NA_integer_, name = "cls", + field_index = 1L, field_name = NA_character_, + value_chr = "name", value_num = NA_real_ + ) + ) + ) -# ADD {{{ -test_that("Add", { + # can accept variable input + expect_equal({x <- list(a = 1L, b = 2L); parse_dots_value(obj = x, .empty = TRUE)}, + list(object = data.table(rleid = 1L, each_rleid = 1L, id = NA_integer_, name = "obj", + comment = list(), is_ref = FALSE, lhs_sgl = FALSE, rhs_sgl = TRUE, is_empty = FALSE), + value = data.table(rleid = 1L, each_rleid = 1L, id = NA_integer_, name = "obj", + field_index = NA_integer_, field_name = c("a", "b"), + value_chr = c("1", "2"), value_num = 1:2 + ) + ) + ) + expect_equal({x <- list(a = list(1), b = list()); parse_dots_value(x, .empty = TRUE)}, + list(object = data.table(rleid = 1:2, each_rleid = 1L, id = NA_integer_, name = c("a", "b"), + comment = list(), is_ref = FALSE, lhs_sgl = FALSE, rhs_sgl = TRUE, is_empty = c(FALSE, TRUE)), + value = data.table(rleid = 1:2, each_rleid = 1L, id = NA_integer_, name = c("a", "b"), + field_index = NA_integer_, field_name = NA_character_, + value_chr = c("1", NA_character_), value_num = c(1, NA_real_) + ) + ) + ) + + # whole game + expect_equal( + { + x <- list(cls8 = list(fld1 = NULL, fld2 = "a", NULL, 2L, fld3 = NULL, .comment = c("a", "b"))) + parse_dots_value( + # empty + cls1 = list(), + cls2 = list(.comment = c("a", "b")), + cls3 = list(NULL, NULL, fld1 = NULL, .comment = c("a", "b")), + cls4 = list(NULL, fld1 = "a", fld2 = 2L, fld3 = NULL, "a", 1L, .comment = c("a", "b")), + cls5 := list(.comment = c("a", "b")), + c("cls6", "cls7") := list(..1 = NULL, ..3 = NULL, fld1 = NULL, .comment = c("a", "b")), + x, + .empty = TRUE + ) + }, + list( + object = data.table( + rleid = c(1:5, rep(6L, 2), 7), each_rleid = c(rep(1L, 6), 2L, 1L), + id = NA_integer_, + name = paste0("cls", 1:8), + comment = c(list(NULL), rep(list(c("a", "b")), 7L)), + is_ref = c(rep(FALSE, 4), rep(TRUE, 3), FALSE), + lhs_sgl = c(rep(FALSE, 4), TRUE, rep(FALSE, 3)), + rhs_sgl = TRUE, + is_empty = c(rep(TRUE, 2), rep(FALSE, 2), TRUE, rep(FALSE, 3)) + ), + value = data.table( + rleid = c(1L, 2L, rep(3L, 3), rep(4L, 6), 5L, rep(6L, 2*3), rep(7L, 5)), + each_rleid = c(rep(1L, 15), rep(2L, 3), rep(1L, 5)), + id = NA_integer_, + name = c("cls1", "cls2", rep("cls3", 3), rep("cls4", 6), "cls5", rep(c("cls6", "cls7"), each = 3), rep("cls8", 5)), + field_index = c(rep(NA_integer_, 12), rep(c(1L, 3L, NA_integer_), 2), rep(NA_integer_, 5)), + field_name = c(rep(NA_character_, 4), "fld1", NA_character_, paste0("fld", 1:3), rep(NA_character_, 5), + "fld1", rep(NA_character_, 2), paste0("fld", c(1, 1, 2)), rep(NA_character_, 2), "fld3"), + value_chr = c(rep(NA_character_, 6), "a", "2", NA_character_, "a", "1", rep(NA_character_, 8), "a", NA_character_, "2", NA_character_), + value_num = c(rep(NA_real_, 7), 2, rep(NA_real_, 2), 1, rep(NA_real_, 10), 2, NA_real_) + ) + ) + ) + # }}} + + # expand_idf_dots_value {{{ # read idf - idf <- read_idf(example(), 8.8) - idf_env <- ._get_private(idf)$m_idf_env - idd_env <- ._get_private(idf)$idd_env() - - expect_error(add_idf_object(idd_env, idf_env), class = "error_empty_input") - expect_error(add_idf_object(idd_env, idf_env, Version = list(8.8)), class = "error_add_version") - expect_error(add_idf_object(idd_env, idf_env, - SimulationControl = list()), class = "error_add_unique") - expect_silent({rp <- add_idf_object(idd_env, idf_env, - RunPeriod = list("Test1", 1, 1, End_Month = 2, 1, "Monday", Apply_Weekend_Holiday_Rule = "No") - )}) - expect_equivalent(rp$object, data.table(object_id = 54L, class_id = 22L, - comment = list(), object_name = "Test1", object_name_lower = "test1" - )) - expect_equivalent(rp$value, data.table(value_id = 349L:359L, - value_chr = c("Test1", "1", "1", "2", "1", "Monday", "Yes", "Yes", "No", "Yes", "Yes"), - value_num = c(NA_real_, 1, 1, 2, 1, rep(NA_real_, 6L)), - object_id = rep(54L, 11L), field_id = 104L:114L - )) + idf_env <- parse_idf_file(example(), 8.8) + idd_env <- get_priv_env(use_idd(8.8))$idd_env() + + # can stop if duplicated class names are given + expect_error(expand_idf_dots_value(idd_env, idf_env, Site_Location = list(), `Site:Location` = list(), .unique = TRUE)) + + # match by class {{{ + expect_error(res <- expand_idf_dots_value(idd_env, idf_env, c(1) := list(..1 = 8.8, 'Version Identifier' = 8.8)), class = "eplusr_error_dots_multi_match") + + # only class id + expect_is(res <- expand_idf_dots_value(idd_env, idf_env, c(1) := list(8.8), .empty = FALSE), "list") + expect_equal(names(res), c("object", "value")) + expect_equal(res$object, + data.table(rleid = 1L, class_id = 1L, class_name = "Version", + object_id = NA_integer_, object_name = NA_character_, + object_name_lower = NA_character_, comment = list() + ) + ) + expect_equal(res$value, + data.table(rleid = 1L, class_id = 1L, class_name = "Version", + object_id = NA_integer_, object_name = NA_character_, field_id = 1L, + field_index = 1L, field_name = "Version Identifier", value_id = NA_integer_, + value_chr = "8.8", value_num = 8.8) + ) + + expect_is( + res <- expand_idf_dots_value(idd_env, idf_env, + RunPeriod = list("Test1", ..2 = 1, 1, End_Month = 2, 1, "Monday", Apply_Weekend_Holiday_Rule = "No"), + RunPeriod = list("Test2", 1, 1, 2, 1), + Material = list("Mat"), + Construction = list("TestConst", "R13LAYER"), + SimulationControl = list(), + SimulationControl = list(..7 = "yes"), + .empty = TRUE, .unique = FALSE, .default = TRUE + ), "list" + ) + expect_equal(names(res), c("object", "value")) + expect_equivalent(res$object, + data.table(rleid = 1:6, class_id = c(22L, 22L, 55L, 90L, 2L, 2L), + class_name = c("RunPeriod", "RunPeriod", "Material", "Construction", "SimulationControl", "SimulationControl"), + object_id = NA_integer_, object_name = NA_character_, + object_name_lower = NA_character_, comment = list() + ) + ) - expect_silent(rp <- add_idf_object(idd_env, idf_env, - RunPeriod = list("Test2", 1, 1, 2, 1), .default = TRUE, .all = TRUE) + expect_equivalent(res$value[, -"field_name"], + data.table( + rleid = c(rep(1L, 11), rep(2L, 11), rep(3L, 6), rep(4L, 2), rep(5L, 5), rep(6L, 7)), + class_id = c(rep(22L, 22), rep(55, 6), rep(90L, 2), rep(2L, 12)), + class_name = c(rep("RunPeriod", 22), rep("Material", 6), rep("Construction", 2), rep("SimulationControl", 12)), + object_id = NA_integer_, object_name = NA_character_, + field_id = c(104:114, 104:114, 7081:7086, 11006:11007, 2:6, 2:8), + field_index = c(1:11, 1:11, 1:6, 1:2, 1:5, 1:7), + value_id = NA_integer_, + value_chr = c( + "Test1", "1", "1", "2", "1", "Monday", "Yes", "Yes", "No", "Yes", "Yes", + "Test2", "1", "1", "2", "1", "UseWeatherFile", "Yes", "Yes", "No", "Yes", "Yes", + "Mat", NA, NA, NA, NA, NA, + "TestConst", "R13LAYER", + "No", "No", "No", "Yes", "Yes", + "No", "No", "No", "Yes", "Yes", "No", "yes" + ), + value_num = c( + NA, 1, 1, 2, 1, NA, NA, NA, NA, NA, NA, + NA, 1, 1, 2, 1, NA, NA, NA, NA, NA, NA, + NA, NA, NA, NA, NA, NA, + NA, NA, + NA, NA, NA, NA, NA, + NA, NA, NA, NA, NA, NA, NA + ) + ) ) - expect_equivalent(rp$object, data.table(object_id = 54L, class_id = 22L, - comment = list(), object_name = "Test2", object_name_lower = "test2" - )) - expect_equivalent(rp$value, data.table(value_id = 349L:362L, - value = c("Test2", "1", "1", "2", "1", "UseWeatherFile", "Yes", "Yes", "No", "Yes", "Yes", "1", "Yes", NA_character_), - value_num = c(NA_real_, 1, 1, 2, 1, rep(NA_real_, 6L), 1, rep(NA_real_, 2L)), - object_id = rep(54L, 14L), field_id = 104L:117L - )) + # }}} - expect_silent(const <- add_idf_object(idd_env, idf_env, Construction = list("TestConst", "R13LAYER"))) - expect_equal(const$reference[object_id == 54L], - data.table(object_id = 54L, value_id = 350L, src_object_id = 12L, src_value_id = 87L, src_enum = 2L) + # match by object {{{ + # can stop if value number is not the same as object number in that class + expect_error(expand_idf_dots_value(idd_env, idf_env, Output_Variable := list(key_value = c("*", "*")), + .type = "object", .scalar = FALSE, .pair = TRUE, .unique = FALSE), + class = "eplusr_error_dots_pair_length" ) -}) -# }}} -# SET {{{ -test_that("Set", { - # read idf - idf <- read_idf(example(), 8.8) - idf_env <- ._get_private(idf)$m_idf_env - idd_env <- ._get_private(idf)$idd_env() + # can work for empty objects + expect_is(res <- expand_idf_dots_value(idd_env, idf_env, Output_Variable := list(), .type = "object"), "list") + expect_equal(names(res), c("object", "value")) + expect_equal(res$object, + data.table(rleid = 1L, class_id = 776L, class_name = "Output:Variable", + object_id = 27:40, object_name = NA_character_, + object_name_lower = NA_character_, comment = list() + ) + ) + expect_equal(res$value[, -"value_chr"], + data.table(rleid = 1L, class_id = 776L, class_name = "Output:Variable", + object_id = rep(27:40, each = 3), object_name = NA_character_, + field_id = rep(59058:59060, 14), field_index = rep(1:3, 14), + field_name = rep(c("Key Value", "Variable Name", "Reporting Frequency"), 14), + value_id = 262:303, value_num = NA_real_ + ) + ) - expect_error(set_idf_object(idd_env, idf_env), class = "error_empty_input") - expect_error(set_idf_object(idd_env, idf_env, ..1 = list(8.8)), class = "error_set_version") - expect_silent({rp <- set_idf_object(idd_env, idf_env, ..8 = list(Name = "Test"))}) - expect_equal(rp$object, data.table(object_id = 8L, class_id = 22L, - comment = list(NULL), object_name = "Test", object_name_lower = "test") + ## Class := list() + expect_is(class = "list", + res <- expand_idf_dots_value(idd_env, idf_env, .type = "object", .complete = FALSE, + Output_Variable := list(), + .scalar = FALSE, .pair = TRUE + ) ) - expect_equivalent(rp$value, - data.table( - value_id = 19:29, - value_chr = c("Test", "1", "1", "12", "31", "Tuesday", "Yes", "Yes", "No", "Yes", "Yes"), - value_num = c(NA_real_, 1, 1, 12, 31, rep(NA_real_, 6)), - object_id = rep(8L, 11), - field_id = 104:114) + expect_equal(res$object$object_id, 27:40) + expect_equal(res$value$field_index, rep(1:3, 14)) + ## Class := list(), dup + expect_is(class = "list", + res <- expand_idf_dots_value(idd_env, idf_env, .type = "object", .complete = FALSE, + Output_Variable := list(), Output_Variable := list(), + .scalar = FALSE, .pair = TRUE, .unique = FALSE + ) ) + expect_equal(res$object$object_id, rep(27:40, 2)) + expect_equal(res$value$field_index, rep(1:3, 14 * 2)) - expect_silent({floor <- set_idf_object(idd_env, idf_env, FLOOR = list(Name = "Flr"))}) - expect_equal(floor$object$object_name, "Flr") - expect_equal(idf_env$value[ - value_id == floor$reference[src_object_id == floor$object$object_id, value_id], - value_chr], "Flr" + ## Class := list(Fld = Val) + expect_is(class = "list", + res <- expand_idf_dots_value(idd_env, idf_env, .type = "object", .complete = FALSE, + Output_Variable := list(key_value = "*"), + .scalar = FALSE, .pair = TRUE + ) ) + expect_equal(res$object$object_id, 27:40) + expect_equal(res$value$field_index, rep(1L, 14)) + ## Class := list(Fld = Val), dup + expect_is(class = "list", + res <- expand_idf_dots_value(idd_env, idf_env, .type = "object", .complete = FALSE, + Output_Variable := list(key_value = "*"), Output_Variable := list(key_value = "*"), + .scalar = FALSE, .pair = TRUE, .unique = FALSE + ) + ) + expect_equal(res$object$object_id, rep(27:40, 2)) + expect_equal(res$value$field_index, rep(1, 14 * 2)) - # delete fields - expect_equal(nrow(set_idf_object(idd_env, idf_env, - ..8 = list(name = "name", start_year = NULL), .default = FALSE)$value), - 11L) + ## Class := list(Fld1 = Val1, Fld = Val2) + expect_is(class = "list", + res <- expand_idf_dots_value(idd_env, idf_env, .type = "object", .complete = FALSE, + Output_Variable := list(key_value = "*", variable_name = NULL), + .scalar = FALSE, .pair = TRUE + ) + ) + expect_equal(res$object$object_id, 27:40) + expect_equal(res$value$field_index, rep(1:2, 14)) + ## Class := list(Fld1 = Val1, Fld = Val2), dup + expect_is(class = "list", + res <- expand_idf_dots_value(idd_env, idf_env, .type = "object", .complete = FALSE, + Output_Variable := list(key_value = "*", variable_name = NULL), + Output_Variable := list(key_value = "*", variable_name = NULL), + .scalar = FALSE, .pair = TRUE, .unique = FALSE, .empty = FALSE + ) + ) + expect_equal(res$object$object_id, rep(27:40, 2)) + expect_equal(res$value$field_index, rep(1:2, 14 * 2)) - # can set whole class - expect_silent({mat <- set_idf_object(idd_env, idf_env, - Material_NoMass := list(roughness = "smooth", thermal_absorptance = 0.8))}) - expect_equivalent(mat$object, - data.table(object_id = c(12L, 13L), class_id = 56L, comment = list(), - object_name = c("R13LAYER", "R31LAYER"), object_name_lower = c("r13layer", "r31layer") + ## Class := list(Fld1 = c(Val1, Val2, Val3, ...)) + expect_is(class = "list", + res <- expand_idf_dots_value(idd_env, idf_env, .type = "object", .complete = FALSE, + Output_Variable := list(key_value = rep("*", 14)), + .scalar = FALSE, .pair = TRUE + ) + ) + expect_equal(res$object$object_id, 27:40) + expect_equal(res$value$field_index, rep(1, 14)) + ## Class := list(Fld1 = c(Val1, Val2, Val3, ...)), dup + expect_is(class = "list", + res <- expand_idf_dots_value(idd_env, idf_env, .type = "object", .complete = FALSE, + Output_Variable := list(key_value = rep("*", 14)), + Output_Variable := list(key_value = rep("*", 14)), + .scalar = FALSE, .pair = TRUE, .unique = FALSE + ) + ) + expect_equal(res$object$object_id, rep(27:40, 2)) + expect_equal(res$value$field_index, rep(1, 14 * 2)) + + ## Class := list(Fld1 = c(Val1, Val2, Val3, ...), Fld2 = c(Val4, Val5, Val6, ...)) + expect_is(class = "list", + res <- expand_idf_dots_value(idd_env, idf_env, .type = "object", .complete = FALSE, + Output_Variable := list(key_value = rep("*", 14), variable_name = rep("", 14)), + .scalar = FALSE, .pair = TRUE + ) + ) + expect_equal(res$object$object_id, 27:40) + expect_equal(res$value$field_index, rep(1:2, 14)) + ## Class := list(Fld1 = c(Val1, Val2, Val3, ...), Fld2 = c(Val4, Val5, Val6, ...)), dup + expect_is(class = "list", + res <- expand_idf_dots_value(idd_env, idf_env, .type = "object", .complete = FALSE, + Output_Variable := list(key_value = rep("*", 14), variable_name = rep("", 14)), + Output_Variable := list(key_value = rep("*", 14), variable_name = rep("", 14)), + .scalar = FALSE, .pair = TRUE, .unique = FALSE + ) + ) + expect_equal(res$object$object_id, rep(27:40, 2)) + expect_equal(res$value$field_index, rep(1:2, 14 * 2)) + + ## Obj = list() + expect_is(class = "list", + res <- expand_idf_dots_value(idd_env, idf_env, .type = "object", .complete = FALSE, + ..27 = list(), + .scalar = FALSE, .pair = TRUE + ) + ) + expect_equal(res$object$object_id, 27) + expect_equal(res$value$field_index, 1:3) + ## Obj = list(), dup + expect_is(class = "list", + res <- expand_idf_dots_value(idd_env, idf_env, .type = "object", .complete = FALSE, + ..27 = list(), ..27 = list(), + .scalar = FALSE, .pair = TRUE, .unique = FALSE + ) + ) + expect_equal(res$object$object_id, rep(27, 2)) + expect_equal(res$value$field_index, rep(1:3, 2)) + + ## Obj = list(Fld = Val) + expect_is(class = "list", + res <- expand_idf_dots_value(idd_env, idf_env, .type = "object", .complete = FALSE, + ..27 = list(key_value = "*"), + .scalar = FALSE, .pair = TRUE + ) + ) + expect_equal(res$object$object_id, 27) + expect_equal(res$value$field_index, 1) + ## Obj = list(Fld = Val), dup + expect_is(class = "list", + res <- expand_idf_dots_value(idd_env, idf_env, .type = "object", .complete = FALSE, + ..27 = list(key_value = "*"), ..27 = list(key_value = "*"), + .scalar = FALSE, .pair = TRUE, .unique = FALSE + ) + ) + expect_equal(res$object$object_id, rep(27, 2)) + expect_equal(res$value$field_index, rep(1, 2)) + + ## Obj = list(Fld1 = Val1, Fld2 = Val2) + expect_is(class = "list", + res <- expand_idf_dots_value(idd_env, idf_env, .type = "object", .complete = FALSE, + ..27 = list(key_value = "*", variable_name = NULL), + .scalar = FALSE, .pair = TRUE + ) + ) + expect_equal(res$object$object_id, 27) + expect_equal(res$value$field_index, 1:2) + ## Obj = list(Fld1 = Val1, Fld2 = Val2), dup + expect_is(class = "list", + res <- expand_idf_dots_value(idd_env, idf_env, .type = "object", .complete = FALSE, + ..27 = list(key_value = "*", variable_name = NULL), + ..27 = list(key_value = "*", variable_name = NULL), + .scalar = FALSE, .pair = TRUE, .unique = FALSE + ) + ) + expect_equal(res$object$object_id, rep(27, 2)) + expect_equal(res$value$field_index, rep(1:2, 2)) + + ## c(Obj1, Obj2) := list(Fld = Val) + expect_is(class = "list", + res <- expand_idf_dots_value(idd_env, idf_env, .type = "object", .complete = FALSE, + c(27, 28) := list(key_value = "*"), + .scalar = FALSE, .pair = TRUE + ) + ) + expect_equal(res$object$object_id, 27:28) + expect_equal(res$value$field_index, rep(1, 2)) + ## c(Obj1, Obj2) := list(Fld = Val), dup + expect_is(class = "list", + res <- expand_idf_dots_value(idd_env, idf_env, .type = "object", .complete = FALSE, + c(27, 28) := list(key_value = "*"), c(27, 28) := list(key_value = "*"), + .scalar = FALSE, .pair = TRUE, .unique = FALSE + ) + ) + expect_equal(res$object$object_id, rep(27:28, 2)) + expect_equal(res$value$field_index, rep(1, 2 * 2)) + + ## c(Obj1, Obj2) := list(Fld1 = Val1, Fld2 = Val2) + expect_is(class = "list", + res <- expand_idf_dots_value(idd_env, idf_env, .type = "object", .complete = FALSE, + c(27, 28) := list(key_value = "*", variable_name = NULL), + .scalar = FALSE, .pair = TRUE + ) + ) + expect_equal(res$object$object_id, 27:28) + expect_equal(res$value$field_index, rep(1:2, 2)) + ## c(Obj1, Obj2) := list(Fld1 = Val1, Fld2 = Val2), dup + expect_is(class = "list", + res <- expand_idf_dots_value(idd_env, idf_env, .type = "object", .complete = FALSE, + c(27, 28) := list(key_value = "*", variable_name = NULL), + c(27, 28) := list(key_value = "*", variable_name = NULL), + .scalar = FALSE, .pair = TRUE, .unique = FALSE ) ) - expect_equivalent(mat$value[field_id == 7091, value_chr], c("smooth", "smooth")) - expect_equivalent(mat$value[field_id == 7093, value_chr], c("0.8", "0.8")) + expect_equal(res$object$object_id, rep(27:28, 2)) + expect_equal(res$value$field_index, rep(1:2, 2 * 2)) - # can reset object comments - expect_silent(cmt <- set_idf_object(idd_env, idf_env, - R13LAYER = list(.comment = c("new", "comment")))) - expect_equivalent(cmt$object, - data.table(object_id = 12L, class_id = 56L, comment = list(c("new", "comment")), - object_name = "R13LAYER", object_name_lower = "r13layer" + ## c(Obj1, Obj2) := list(Fld1 = c(Val1, Val2), Fld2 = c(Val3, Val4)) + expect_is(class = "list", + res <- expand_idf_dots_value(idd_env, idf_env, .type = "object", .complete = FALSE, + c(27, 28) := list(key_value = c("*", "*"), variable_name = c("", "")), + .scalar = FALSE, .pair = TRUE + ) + ) + expect_equal(res$object$object_id, 27:28) + expect_equal(res$value$field_index, rep(1:2, 2)) + ## c(Obj1, Obj2) := list(Fld1 = c(Val1, Val2), Fld2 = c(Val3, Val4)), dup + expect_is(class = "list", + res <- expand_idf_dots_value(idd_env, idf_env, .type = "object", .complete = FALSE, + c(27, 28) := list(key_value = c("*", "*"), variable_name = c("", ""), "hourly"), + c(27, 28) := list(key_value = c("*", "*"), variable_name = c("", "")), + .scalar = FALSE, .pair = TRUE, .unique = FALSE + ) + ) + expect_equal(res$object$object_id, rep(27:28, 2)) + expect_equal(res$value$field_index, c(rep(1:3, 2), rep(1:2, 2))) + + # whole game + expect_is(class = "list", + res <- expand_idf_dots_value(idd_env, idf_env, + # Class := list() # extract all data from a class + BuildingSurface_Detailed := list(), + # Class := list(Fld = Val) # set field values in all class objects + Material_NoMass := list(roughness = "smooth", thermal_absorptance = 0.8), + # Class := list(Fld = c(Val1, Val2, Val3)) # set field values individually in a class + BuildingSurface_Detailed := list(outside_boundary_condition = rep("Adiabatic", 6)), + # Object = list() # extract object data with new comments + R13LAYER = list(.comment = c("new", "comment")), + # object = list(Fld1 = Val1, Fld2 = Val2) # set object field values + ..8 = list(name = "name", start_year = NULL), + # .(Obj1, Obj2, Obj3) := list(Fld = c(Val1, Val2, Val3)) # set field values individually + c("r13wall", "floor", "roof31") := list(paste("Const", 1:3), "r13layer", c("r13layer", "r31layer", "r13layer")), + .type = "object", .complete = TRUE, .scalar = FALSE, .pair = FALSE, .empty = TRUE, + .unique = FALSE ) ) - expect_equivalent(cmt$value, data.table()) - expect_equivalent(cmt$reference, idf_env$reference) + expect_equal(res$object$object_id, c(21:26, 12:13, 21:26, 12, 8, 15:17)) + expect_equal(nrow(res$value), 292) + expect_is(res$value$value_chr, "list") + expect_is(res$value$value_num, "list") + expect_equal(res$value$value_chr[c(291:292)], list("r13layer", c("r13layer", "r31layer", "r13layer"))) + + # whole game + expect_is(class = "list", + res <- expand_idf_dots_value(idd_env, idf_env, + # Class := list() # extract all data from a class + BuildingSurface_Detailed := list(), + # Class := list(Fld = Val) # set field values in all class objects + Material_NoMass := list(roughness = "smooth", thermal_absorptance = 0.8), + # Class := list(Fld = c(Val1, Val2, Val3)) # set field values individually in a class + BuildingSurface_Detailed := list(outside_boundary_condition = rep("Adiabatic", 6)), + # Object = list() # extract object data with new comments + R13LAYER = list(.comment = c("new", "comment")), + # object = list(Fld1 = Val1, Fld2 = Val2) # set object field values + ..8 = list(name = "name", start_year = NULL), + # .(Obj1, Obj2, Obj3) := list(Fld = c(Val1, Val2, Val3)) # set field values individually + c("r13wall", "floor", "roof31") := list(paste("Const", 1:3), "r13layer", c("r13layer", "r31layer", "r13layer")), + .type = "object", .complete = TRUE, .scalar = FALSE, .pair = TRUE, .empty = TRUE, + .unique = FALSE + ) + ) + expect_equal(res$object$object_id, c(21:26, 12:13, 21:26, 12, 8, 15:17)) + expect_equal(nrow(res$value), 283) + + # cannot modify same object multiple times at the same time + expect_error(expand_idf_dots_value(idd_env, idf_env, Construction := list(), Floor = list(), .type = "object")) + # }}} + # }}} }) # }}} -# DEL {{{ -test_that("Del", { - eplusr_option(verbose_info = FALSE) +# OBJECT DOTS {{{ +test_that("OBJECT DOTS", { # read idf idf <- read_idf(example(), 8.8) - idf_env <- ._get_private(idf)$m_idf_env - idd_env <- ._get_private(idf)$idd_env() + idf_env <- get_priv_env(idf)$idf_env() + idd_env <- get_priv_env(idf)$idd_env() + + # can stop if empty input + expect_error(expand_idf_dots_object(idd_env, idf_env), class = "eplusr_error_dots_empty") + # can stop if NULL + expect_error(expand_idf_dots_object(idd_env, idf_env, NULL), class = "eplusr_error_dots_format") + # can stop if duplicates + expect_error(expand_idf_dots_object(idd_env, idf_env, idf, idf), class = "eplusr_error_dots_format") + expect_error(expand_idf_dots_object(idd_env, idf_env, idf, list(idf)), class = "eplusr_error_dots_format") + expect_error(expand_idf_dots_object(idd_env, idf_env, list(idf), list(idf)), class = "eplusr_error_dots_format") + expect_error(expand_idf_dots_object(idd_env, idf_env, idf$Version, idf$Version), class = "eplusr_error_dots_format") + expect_error(expand_idf_dots_object(idd_env, idf_env, idf$Version, list(idf$Version)), class = "eplusr_error_dots_format") + expect_error(expand_idf_dots_object(idd_env, idf_env, list(idf$Version), list(idf$Version)), class = "eplusr_error_dots_format") + + # can remove duplicates + expect_is(l <- expand_idf_dots_object(idd_env, idf_env, list(idf$Version), list(idf$Version), .unique = NULL), class = "list") + expect_equal(names(l), c("meta", "object", "value")) + expect_equal(names(l$meta), c("rleid", "version", "uuid", "object_id", "idd_env", "idf_env")) + expect_equal(names(l$object), c("rleid", "class_id", "class_name", "object_id", "object_name", "object_name_lower", "comment")) + expect_equal(names(l$value), + c("rleid", "class_id", "class_name", "object_id", "object_name", + "field_id", "field_index", "field_name", "value_id", "value_chr", "value_num") + ) + expect_equal(nrow(l$meta), 1L) + expect_equal(nrow(l$object), 1L) + expect_equal(nrow(l$value), 1L) + + # can keep duplicates + expect_is(l <- expand_idf_dots_object(idd_env, idf_env, list(idf$Version), list(idf$Version), .unique = FALSE), class = "list") + expect_equal(names(l), c("meta", "object", "value")) + expect_equal(names(l$meta), c("rleid", "version", "uuid", "object_id", "idd_env", "idf_env")) + expect_equal(names(l$object), c("rleid", "class_id", "class_name", "object_id", "object_name", "object_name_lower", "comment")) + expect_equal(names(l$value), + c("rleid", "class_id", "class_name", "object_id", "object_name", + "field_id", "field_index", "field_name", "value_id", "value_chr", "value_num") + ) + expect_equal(nrow(l$meta), 2L) + expect_equal(nrow(l$object), 2L) + expect_equal(nrow(l$value), 2L) + + # can stop if version is not the same + if (!is_avail_eplus(8.8)) install_eplus(8.8) + expect_error(expand_idf_dots_object(idd_env, idf_env, empty_idf(8.7)), class = "eplusr_error_dots_format") + + # can proceed if version is not the same + expect_is(expand_idf_dots_object(idd_env, idf_env, empty_idf(8.7), .strict = FALSE), "list") +}) +# }}} - expect_error(del_idf_object(idd_env, idf_env), class = "error_empty_input") - expect_error(del_idf_object(idd_env, idf_env, 1), class = "error_del_version") - expect_error(del_idf_object(idd_env, idf_env, c(2, 2)), class = "error_del_multi_time") - expect_error(del_idf_object(idd_env, idf_env, 3), class = "error_del_required") - expect_error( - del_idf_object(idd_env, idf_env, "R13WALL", "FLOOR", "ROOF31"), - class = "error_del_referenced" +# LITERAL DOTS {{{ +test_that("LITERAL DOTS", { + # read idf + idf <- read_idf(example(), 8.8) + idf_env <- get_priv_env(idf)$idf_env() + idd_env <- get_priv_env(idf)$idd_env() + + expect_error(expand_idf_dots_literal(idd_env, idf_env)) + expect_error(expand_idf_dots_literal(idd_env, idf_env, NULL)) + expect_error(expand_idf_dots_literal(idd_env, idf_env, list())) + expect_error(expand_idf_dots_literal(idd_env, idf_env, c("a", NA_character_))) + expect_error(expand_idf_dots_literal(idd_env, idf_env, data.table())) + expect_error(expand_idf_dots_literal(idd_env, idf_env, data.table(id = NA, index = NA, value = NA))) + + # can stop if trying to add Version + expect_error(expand_idf_dots_literal(idd_env, idf_env, "Version,8.7;\n")) + + # can stop if trying to match objects without name + expect_error(expand_idf_dots_literal(idd_env, idf_env, "SimulationControl,no;\n", .exact = TRUE)) + + # can stop if concatenated line + expect_error(expand_idf_dots_literal(idd_env, idf_env, "Construction, const1, mat; Construction, const2;\n"), class = "eplusr_error_parse_idf_line") + + # can stop if invalid object names + expect_error(expand_idf_dots_literal(idd_env, idf_env, .exact = TRUE, "Construction, const, mat;\n"), class = "eplusr_error_dots_format") + + mat <- get_idd_table(idd_env, "Material") + mat1 <- set(copy(mat), NULL, "value", c("", " ", " ", rep(NA_character_, 3))) + mat2 <- set(copy(mat), NULL, "value", list(list(" "))) + mat3 <- get_idf_table(idd_env, idf_env, "Material:NoMass") + + # can stop if duplicates in combinations of class, index and field + expect_error(expand_idf_dots_literal(idd_env, idf_env, rbindlist(list(mat1, mat1)))) + + # can stop if missing id column + expect_error(expand_idf_dots_literal(idd_env, idf_env, copy(mat3)[, id := NULL], .exact = TRUE)) + + # can stop if duplicates in combinations of id, class, index and field + expect_error(expand_idf_dots_literal(idd_env, idf_env, rbindlist(list(mat1, mat1))[, id := 1L])) + expect_error(expand_idf_dots_literal(idd_env, idf_env, copy(mat3)[, id := 1L], .exact = TRUE)) + + # can stop if invalid class name + expect_error(expand_idf_dots_literal(idd_env, idf_env, copy(mat1)[, class := "mat"])) + expect_error(expand_idf_dots_literal(idd_env, idf_env, copy(mat3)[, class := "mat"], .exact = TRUE)) + + # can stop if invalid object id + expect_error(expand_idf_dots_literal(idd_env, idf_env, copy(mat1)[, id := 1e5L], .exact = TRUE)) + + # can stop if invalid field index + expect_error(expand_idf_dots_literal(idd_env, idf_env, rbindlist(list(mat1, mat1))[, index := .I])) + expect_error(expand_idf_dots_literal(idd_env, idf_env, rbindlist(list(mat3, mat3))[, index := .I], .exact = TRUE)) + + # whole game + expect_is(class = "list", + l <- expand_idf_dots_literal(idd_env, idf_env, mat1, mat2, + c("! some comments;", + "Material,", + " mat, !- Name", + " MediumSmooth, !- Roughness", + " 0.667; !- Thickness {m}", + "Construction, const, mat;" + ), mat3 + ) + ) + expect_equal(names(l), c("object", "value")) + expect_equal(l$object, + data.table( + rleid = 1:6, class_id = c(55L, 90L, 55L, 55L, 56L, 56L), + class_name = c("Material", "Construction", "Material", "Material", "Material:NoMass", "Material:NoMass"), + object_id = NA_integer_, object_name = NA_character_, object_name_lower = NA_character_, + comment = c(list(" some comments;"), rep(list(NULL), 5L)) + ) + ) + expect_equal(l$value$rleid, c(rep(1L, 3), rep(2L, 2), rep(3:6, each = 6))) + expect_equal(l$value$class_id, c(rep(55L, 3), rep(90L, 2), rep(c(55L, 55L, 56L, 56L), each = 6))) + expect_equal(l$value$object_id, rep(NA_integer_, 29)) + expect_equal(l$value$object_name, rep(NA_character_, 29)) + expect_equal(l$value$value_id, rep(NA_integer_, 29)) + expect_equal(l$value$value_num, c(NA, NA, 0.667, rep(NA, 16), 2.290965, 0.9, 0.75, 0.75, NA, NA, 5.456, 0.9, 0.75, 0.75)) + + # whole game + expect_is(class = "list", + l <- expand_idf_dots_literal(idd_env, idf_env, .exact = TRUE, mat3, + c("! some comments;", + "Material,", + " C5 - 4 IN HW CONCRETE, !- Name", + " MediumSmooth, !- Roughness", + " 0.20; !- Thickness {m}" + ), mat3, + c("Material,", + " C5 - 4 IN HW CONCRETE, !- Name", + " MediumSmooth, !- Roughness", + " 0.20; !- Thickness {m}" + ) + ) ) - expect_silent({del <- del_idf_object(idd_env, idf_env, 21:26, 14, .ref_by = TRUE, .recursive = TRUE)}) - expect_equivalent(setdiff(idf_env$object$object_id, del$object$object_id), c(14L, 21:26)) + expect_equal(names(l), c("object", "value")) + expect_equal(l$object, + data.table( + rleid = 1:6, class_id = c(rep(55L, 2), rep(56L, 4)), + class_name = c(rep("Material", 2), rep("Material:NoMass", 4)), + object_id = c(rep(14L, 2), 12L, 13L, 12L, 13L), + object_name = c(rep("C5 - 4 IN HW CONCRETE", 2), rep(c("R13LAYER", "R31LAYER"), 2)), + object_name_lower = c(rep("c5 - 4 in hw concrete", 2), rep(c("r13layer", "r31layer"), 2)), + comment = c(list(" some comments;"), rep(list(NULL), 5L)) + ) + ) + expect_equal(l$value$rleid, c(rep(1L, 3), rep(2L, 3), rep(3:6, each = 6))) + expect_equal(l$value$class_id, c(rep(55L, 6), rep(56L, 24))) + expect_equal(l$value$object_id, rep(c(14L, 12L, 13L, 12L, 13L), each = 6)) + expect_equal(l$value$object_name, c(rep("C5 - 4 IN HW CONCRETE", 6), rep(rep(c("R13LAYER", "R31LAYER"), 2), each = 6))) + expect_equal(l$value$value_id, c(1:6, rep(87:98, 2))) + expect_equal(l$value$value_num, c(rep(c(NA, NA, 0.2), 2), rep(c(NA, NA, 2.290965, 0.9, 0.75, 0.75, NA, NA, 5.456, 0.9, 0.75, 0.75), 2))) }) # }}} -# RENAME {{{ -test_that("Rename", { +# REGEX {{{ +test_that("regex", { # read idf - idf <- read_idf(example(), 8.8) - idf_env <- ._get_private(idf)$m_idf_env - idd_env <- ._get_private(idf)$idd_env() + idf_env <- parse_idf_file(example(), 8.8) + idd_env <- get_priv_env(use_idd(8.8))$idd_env() - expect_error(rename_idf_object(idd_env, idf_env), class = "error_empty_input") - expect_error(rename_idf_object(idd_env, idf_env, 1), class = "error_rename_version") - expect_error(rename_idf_object(idd_env, idf_env, c(2, 2)), class = "error_rename_multi_time") - expect_error(rename_idf_object(idd_env, idf_env, 3), class = "error_rename_no_new_name") - expect_error( - rename_idf_object(idd_env, idf_env, "R13WALL", "FLOOR", "ROOF31"), - class = "error_rename_no_new_name" - ) - expect_silent(ren <- rename_idf_object(idd_env, idf_env, - r13 = "R13WALL", flr = "FLOOR", roof = "ROOF31", r31 = "R31LAYER") - ) - expect_equal(ren$object$object_name, c("r13", "flr", "roof", "r31")) - expect_equal(ren$value$value_chr, c("r13", "flr", "roof", "r31")) - expect_equal(get_idf_value(idd_env, idf_env, object = 21, field = "Construction Name")$value_chr, "r13") - expect_equal(get_idf_value(idd_env, idf_env, object = 22, field = "Construction Name")$value_chr, "r13") - expect_equal(get_idf_value(idd_env, idf_env, object = 23, field = "Construction Name")$value_chr, "r13") - expect_equal(get_idf_value(idd_env, idf_env, object = 24, field = "Construction Name")$value_chr, "r13") - expect_equal(get_idf_value(idd_env, idf_env, object = 25, field = "Construction Name")$value_chr, "flr") - expect_equal(get_idf_value(idd_env, idf_env, object = 26, field = "Construction Name")$value_chr, "roof") - expect_equal(get_idf_value(idd_env, idf_env, object = 17, field = "Outside Layer")$value_chr, "r31") + # can stop if class contains duplications + expect_error(expand_idf_regex(idd_env, idf_env, "", class = c("a", "a"))) + + expect_is(l <- expand_idf_regex(idd_env, idf_env, "ABC"), "list") + expect_equal(nrow(l$object), 0L) + expect_equal(nrow(l$value), 0L) + + expect_is(l <- expand_idf_regex(idd_env, idf_env, "zn", "Zone", ignore.case = TRUE), "list") + expect_equal(nrow(l$object), 6) + expect_equal(nrow(l$value), 6) + expect_equal(l$value$value_id, c(130L, 152L, 174L, 196L, 218L, 240L)) + expect_equal(substr(l$value$value_chr, 1, 7), rep("Zone001", 6)) }) # }}} -# INSERT {{{ -test_that("Insert", { - # read idf - idf <- read_idf(example(), 8.8) - idf_env <- ._get_private(idf)$m_idf_env - idd_env <- ._get_private(idf)$idd_env() +# NEW OBJECT NAME {{{ +test_that("make_idf_object_name", { + idf_env <- parse_idf_file(example(), 8.8) + idd_env <- get_priv_env(use_idd(8.8))$idd_env() - expect_error(insert_idf_object(idd_env, idf_env), class = "error_empty_input") - expect_error(insert_idf_object(idd_env, idf_env, version = idf$version(), 1), - class = "error_wrong_type" - ) + # can stop if trying to assign names to objects that do not have name attribute expect_error( - insert_idf_object(idd_env, idf_env, version = idf$version(), my_building = idf$Building, .unique = FALSE), - class = "error_insert_unique" + make_idf_object_name(idd_env, idf_env, expand_idf_dots_name(idd_env, idf_env, a = 4)), + class = "eplusr_error_cannot_name" ) + + # can stop if there are duplications in new names expect_error( - insert_idf_object(idd_env, idf_env, version = numeric_version("8.7.0"), idf$Material), - class = "error_not_same_version" + make_idf_object_name(idd_env, idf_env, expand_idf_dots_name(idd_env, idf_env, rp = 8, rp = 8)), + class = "eplusr_error_duplicated_name" ) + + # can stop if input new names are the same as existing ones expect_error( - insert_idf_object(idd_env, idf_env, version = idf$version(), idf$Material, .unique = FALSE), - class = "error_validity" + make_idf_object_name(idd_env, idf_env, expand_idf_dots_name(idd_env, idf_env, "floor" = "floor")), + class = "eplusr_error_conflict_name" ) - # can skip Version object - expect_silent( - ins <- insert_idf_object(idd_env, idf_env, version = idf$version(), idf$Version) + + # can use additional columns as prefixes + expect_equal( + { + obj <- init_idf_object(idd_env, idf_env, rep("Construction", 2), name = FALSE) + set(obj, 1L, "object_name", "Construction") + set(obj, 1L, "object_name_lower", "construction") + set(obj, NULL, "prefix1", "Con") + set(obj, NULL, "prefix2", "Const") + make_idf_object_name(idd_env, idf_env, obj, prefix_col = c("prefix1", "prefix2"), prefix_sep = "-", keep_na = FALSE)[] + }, + data.table(rleid = 1:2, class_id = 90L, class_name = "Construction", + group_id = 5L, object_id = 54:55, + object_name = c("Construction", NA), object_name_lower = c("construction", NA), + comment = list(), + prefix1 = "Con", prefix2 = "Const", + new_object_name = paste0("Con-Const-Construction", c("", " 1")), + new_object_name_lower = paste0("con-const-construction", c("", " 1")) + ) ) - expect_equal(nrow(ins$object), 0L) - expect_equal(nrow(ins$value), 0L) - new_mat <- idf$clone()$Material[[1L]]$set(name = "new_mat") - expect_silent( - ins <- insert_idf_object(idd_env, idf_env, version = idf$version(), new_mat) + + # can use additional columns as prefixes and keep empty names + expect_equal( + { + obj <- init_idf_object(idd_env, idf_env, rep("Construction", 2), name = FALSE) + set(obj, 1L, "object_name", "Construction") + set(obj, 1L, "object_name_lower", "construction") + set(obj, NULL, "prefix1", "Con") + set(obj, NULL, "prefix2", "Const") + make_idf_object_name(idd_env, idf_env, obj, prefix_col = c("prefix1", "prefix2"), prefix_sep = "-", keep_na = TRUE)[] + }, + data.table(rleid = 1:2, class_id = 90L, class_name = "Construction", + group_id = 5L, object_id = 54:55, + object_name = c("Construction", NA), object_name_lower = c("construction", NA), + comment = list(), + prefix1 = "Con", prefix2 = "Const", + new_object_name = c("Con-Const-Construction", NA), + new_object_name_lower = c("con-const-construction", NA) + ) + ) + + # can use additional columns as prefixes and keep empty names + expect_equal( + { + obj <- init_idf_object(idd_env, idf_env, rep("Construction", 2), name = FALSE) + set(obj, NULL, "prefix1", "1") + set(obj, NULL, "prefix2", "2") + make_idf_object_name(idd_env, idf_env, obj, prefix_col = c("prefix1", "prefix2"), prefix_sep = "-", use_old = FALSE) + }, + data.table(rleid = 1:2, class_id = 90L, class_name = "Construction", + group_id = 5L, object_id = 54:55, + object_name = NA_character_, object_name_lower = NA_character_, + comment = list(), prefix1 = "1", prefix2 = "2", + new_object_name = c("1-2-Construction", "1-2-Construction 1"), + new_object_name_lower = c("1-2-construction", "1-2-construction 1") + ) + ) + + # can keep existing new names + expect_equal( + { + obj <- init_idf_object(idd_env, idf_env, rep("Construction", 2), name = FALSE) + set(obj, 1L, "object_name", "Construction") + set(obj, 1L, "object_name_lower", "construction") + set(obj, 1L, "new_object_name", "Const") + set(obj, 1L, "new_object_name_lower", "const") + make_idf_object_name(idd_env, idf_env, obj, include_ori = FALSE)[] + }, + data.table(rleid = 1:2, class_id = 90L, class_name = "Construction", + group_id = 5L, object_id = 54:55, + object_name = c("Construction", NA), object_name_lower = c("construction", NA), + comment = list(), + new_object_name = c("Const", NA), + new_object_name_lower = c("const", NA) + ) + ) + + # can auto name and keep empty name + expect_equal( + { + obj <- init_idf_object(idd_env, idf_env, c(rep("Construction", 3), "Coil:Cooling:Water"), name = FALSE) + set(obj, 1L, "object_name", "Const") + set(obj, 1L, "object_name_lower", "const") + make_idf_object_name(idd_env, idf_env, obj, keep_na = FALSE)[] + }, + data.table(rleid = 1:4, class_id = c(rep(90L, 3), 390L), + class_name = c(rep("Construction", 3), "Coil:Cooling:Water"), + group_id = c(rep(5L, 3), 23L), object_id = 54:57, + object_name = c("Const", rep(NA_character_, 3)), + object_name_lower = c("const", rep(NA_character_, 3)), + comment = list(), + new_object_name = c("Const", "Construction", "Construction 1", "Coil"), + new_object_name_lower = c("const", "construction", "construction 1", "coil") + ) + ) +}) +# }}} + +# DUP {{{ +test_that("Dup", { + # read idf + idf_env <- parse_idf_file(example(), 8.8) + idd_env <- get_priv_env(use_idd(8.8))$idd_env() + + # can stop if version object + expect_error(dup_idf_object(idd_env, idf_env, expand_idf_dots_name(idd_env, idf_env, 1)), class = "eplusr_error_dup_version") + # can stop if duplicate unique object + expect_error(dup_idf_object(idd_env, idf_env, expand_idf_dots_name(idd_env, idf_env, 3)), class = "eplusr_error_dup_unique") + + expect_message(with_option( + list(verbose_info = TRUE), + dup <- dup_idf_object(idd_env, idf_env, expand_idf_dots_name(idd_env, idf_env, 8, Annual = 8, nomass = 13, 13))), + "RunPeriod.*R31LAYER 1" + ) + expect_is(dup, "list") + expect_equal(names(dup), c("object", "value", "reference")) + expect_equal(dup$object, + data.table(rleid = 1:4, class_id = c(22L, 22L, 56L, 56L), + class_name = c("RunPeriod", "RunPeriod", "Material:NoMass", "Material:NoMass"), + object_id = 54:57, + object_name = c("RunPeriod", "Annual", "nomass", "R31LAYER 1"), + object_name_lower = c("runperiod", "annual", "nomass", "r31layer 1"), + comment = list() + ) ) - expect_equivalent(ins$object, - data.table(object_id = 54L, class_id = 55L, comment = list(), - object_name = "new_mat", object_name_lower = "new_mat" + expect_equal(dup$value, + data.table( + rleid = c(rep(1L, 11), rep(2L, 11), rep(3L, 6), rep(4L, 6)), + class_id = c(rep(22L, 22), rep(56L, 12)), + class_name = c(rep("RunPeriod", 22), rep("Material:NoMass", 12)), + object_id = c(rep(54L, 11), rep(55L, 11), rep(56L, 6), rep(57L, 6)), + object_name = c(rep(NA_character_, 22), rep("R31LAYER", 12)), + field_id = c(104:114, 104:114, 7090:7095, 7090:7095), + field_index = c(1:11, 1:11, 1:6, 1:6), + field_name = c( + rep(c("Name", "Begin Month", "Begin Day of Month", "End Month", "End Day of Month", + "Day of Week for Start Day", "Use Weather File Holidays and Special Days", + "Use Weather File Daylight Saving Period", "Apply Weekend Holiday Rule", + "Use Weather File Rain Indicators", "Use Weather File Snow Indicators"), 2L), + rep(c("Name", "Roughness", "Thermal Resistance", "Thermal Absorptance", + "Solar Absorptance", "Visible Absorptance"), 2L)), + value_id = 349:382, + value_chr = c( + "RunPeriod", "1", "1", "12", "31", "Tuesday", "Yes", "Yes", "No", "Yes", "Yes", + "Annual", "1", "1", "12", "31", "Tuesday", "Yes", "Yes", "No", "Yes", "Yes", + "nomass", "Rough", "5.456", "0.9", "0.75", "0.75", + "R31LAYER 1", "Rough", "5.456", "0.9", "0.75", "0.75"), + value_num = c( + NA, 1, 1, 12, 31, NA, NA, NA, NA, NA, NA, + NA, 1, 1, 12, 31, NA, NA, NA, NA, NA, NA, + NA, NA, 5.456, 0.9, 0.75, 0.75, + NA, NA, 5.456, 0.9, 0.75, 0.75) + ) + ) + expect_equal(dup$reference, + data.table(object_id = integer(), value_id = integer(), + src_object_id = integer(), src_value_id = integer(), + src_enum = integer() ) ) - expect_equivalent(ins$value$value_id, 349:357) - expect_equivalent(ins$value$value_chr[[1L]], "new_mat") - expect_equivalent(ins$value$object_id, rep(54L, 9)) - expect_equivalent(ins$value$field_id, 7081:7089) }) # }}} -# LOAD {{{ -test_that("Load", { +# ADD {{{ +test_that("Add", { # read idf idf <- read_idf(example(), 8.8) - idf_env <- ._get_private(idf)$m_idf_env - idd_env <- ._get_private(idf)$idd_env() + idf_env <- get_priv_env(idf)$m_idf_env + idd_env <- get_priv_env(idf)$idd_env() - expect_error(load_idf_object(idd_env, idf_env, 8.8), class = "error_empty_input") + # can stop if adding version + expect_error( + { + l <- expand_idf_dots_value(idd_env, idf_env, Version = list()) + add_idf_object(idd_env, idf_env, l$object, l$value) + }, class = "eplusr_error_add_version") - mat1 <- idf$definition("Material")$to_string() - mat2 <- idf$to_table(class = "Construction") + # can stop if adding existing unique object + expect_error( + { + l <- expand_idf_dots_value(idd_env, idf_env, Building = list()) + add_idf_object(idd_env, idf_env, l$object, l$value) + }, class = "eplusr_error_add_unique") - mat2[4, class := "construction"] - expect_error(load_idf_object(idd_env, idf_env, 8.8, mat1, mat2), class = "error_class_name") + # can stop if adding existing unique object + expect_error( + { + l <- expand_idf_dots_value(idd_env, idf_env, c(rep("Output:SQLite", 2)) := list(), .unique = FALSE) + add_idf_object(idd_env, idf_env, l$object, l$value) + }, class = "eplusr_error_add_unique") - mat2[4, `:=`(class = "Construction", index = 20L)] - expect_error(load_idf_object(idd_env, idf_env, 8.8, mat1, mat2), class = "error_bad_field_index") + # can stop if malformed field values + expect_error( + { + l <- expand_idf_dots_value(idd_env, idf_env, Material := list(1), .unique = FALSE) + add_idf_object(idd_env, idf_env, l$object, l$value) + }, class = "eplusr_error_validity_check") - mat2[4, index := 2L] - expect_error(load_idf_object(idd_env, idf_env, 8.8, mat1, mat2), class = "error_validity") + # can remove input objects that are the same as existing ones + expect_equal( + { + l <- expand_idf_dots_value(idd_env, idf_env, floor = list(), .type = "object") + add_idf_object(idd_env, idf_env, l$object, l$value, level = "none", unique = TRUE) + }, + list( + object = data.table( + rleid = integer(), + class_id = integer(), + class_name = character(), + object_id = integer(), + object_name = character(), + object_name_lower = character(), + comment = list() + ), + value = data.table( + rleid = integer(), + class_id = integer(), + class_name = character(), + object_id = integer(), + object_name = character(), + field_id = integer(), + field_index = integer(), + field_name = character(), + value_id = integer(), + value_chr = character(), + value_num = double() + ), + reference = data.table( + object_id = integer(), + value_id = integer(), + src_object_id = integer(), + src_value_id = integer(), + src_enum = integer() + ) + ) + ) - mat_chr <- c("Construction,", "new_const1,", paste0(idf$Material[[1]]$name(), ";")) + # can handle references + expect_equal( + { + l <- expand_idf_dots_value(idd_env, idf_env, + Construction = list("ROOF13", "R13LAYER"), + Construction = list("NewConst", "NewMat"), + Material = list("NewMat"), .unique = FALSE + ) + add_idf_object(idd_env, idf_env, l$object, l$value, level = custom_validate(reference = TRUE))$reference + }, + data.table(object_id = 54:55, value_id = c(350L, 352L), + src_object_id = c(12L, 56L), src_value_id = c(87L, 353L), src_enum = 2L) + ) - expect_silent(ins <- load_idf_object(idd_env, idf_env, version = idf$version(), mat_chr)) - expect_equivalent(ins$object, - data.table(object_id = 54L, class_id = 90L, comment = list(NULL), - object_name = "new_const1", object_name_lower = "new_const1" + # whole game + expect_equal( + { + l <- expand_idf_dots_value(idd_env, idf_env, + Material := list(paste("Mat", 1:3)), + Construction = list("Const", "Mat1", "Mat2", "Mat3"), + BuildingSurface_Detailed = list("Surf", "Floor", "Const", "Zone"), + Zone = list("Zone"), + .scalar = FALSE, .pair = TRUE, .empty = TRUE, .unique = FALSE + ) + add_idf_object(idd_env, idf_env, l$object, l$value, level = "none", unique = TRUE) + }, + list( + object = data.table( + rleid = 1:6, + class_id = c(55L, 55L, 55L, 90L, 103L, 100L), + class_name = c("Material", "Material", "Material", "Construction", "BuildingSurface:Detailed", "Zone"), + object_id = 54:59, + object_name = c("Mat 1", "Mat 2", "Mat 3", "Const", "Surf", "Zone"), + object_name_lower = c("mat 1", "mat 2", "mat 3", "const", "surf", "zone"), + comment = list() + ), + value = data.table( + rleid = c(rep(1L, 6), rep(2L, 6), rep(3L, 6), rep(4L, 4), rep(5L, 19), 6L), + class_id = c(rep(55L, 18), rep(90L, 4), rep(103L, 19), 100L), + class_name = c(rep("Material", 18), rep("Construction", 4), rep("BuildingSurface:Detailed", 19), "Zone"), + object_id = c(rep(54L, 6), rep(55L, 6), rep(56L, 6), rep(57L, 4), rep(58L, 19), 59L), + object_name = c(rep("Mat 1", 6), rep("Mat 2", 6), rep("Mat 3", 6), rep("Const", 4), rep("Surf", 19), "Zone"), + field_id = c(rep(7081:7086, 3), 11006:11009, 11622:11640, 11105L), + field_index = c(rep(1:6, 3), 1:4, 1:19, 1L), + field_name = c( + rep(c("Name", "Roughness", "Thickness", "Conductivity", "Density", "Specific Heat"), 3), + "Name", "Outside Layer", "Layer 2", "Layer 3", + "Name", "Surface Type", "Construction Name", "Zone Name", "Outside Boundary Condition", + "Outside Boundary Condition Object", "Sun Exposure", "Wind Exposure", + "View Factor to Ground", "Number of Vertices", + "Vertex 1 X-coordinate", "Vertex 1 Y-coordinate", "Vertex 1 Z-coordinate", + "Vertex 2 X-coordinate", "Vertex 2 Y-coordinate", "Vertex 2 Z-coordinate", + "Vertex 3 X-coordinate", "Vertex 3 Y-coordinate", "Vertex 3 Z-coordinate", + "Name"), + value_id = 349:390, + value_chr = c( + "Mat 1", NA, NA, NA, NA, NA, + "Mat 2", NA, NA, NA, NA, NA, + "Mat 3", NA, NA, NA, NA, NA, + "Const", "Mat1", "Mat2", "Mat3", + "Surf", "Floor", "Const", "Zone", NA, NA, "SunExposed", + "WindExposed", "autocalculate", "autocalculate", + NA, NA, NA, NA, NA, NA, NA, NA, NA, "Zone"), + value_num = NA_real_ + ), + reference = data.table( + object_id = c(57L, 57L, 57L, 58L, 58L), + value_id = c(368L, 369L, 370L, 373L, 374L), + src_object_id = c(NA, NA, NA, 57L, 59L), + src_value_id = c(NA, NA, NA, 367L, 390L), + src_enum = c(NA, NA, NA, 2L, 2L) + ) ) ) - expect_equivalent(ins$value, - data.table(value_id = 349:350, value_chr = c("new_const1", "C5 - 4 IN HW CONCRETE"), - value_num = rep(NA_real_, 2), object_id = 54L, field_id = 11006:11007 +}) +# }}} + +# SET {{{ +test_that("Set", { + idf_env <- parse_idf_file(example(), 8.8) + idd_env <- get_priv_env(use_idd(8.8))$idd_env() + + # can stop if modifying version + expect_error( + { + l <- expand_idf_dots_value(idd_env, idf_env, ..1 = list(), .type = "object") + set_idf_object(idd_env, idf_env, l$object, l$value) + }, + class = "eplusr_error_set_version" + ) + + # can stop if modifying multiple times + expect_error( + { + l <- expand_idf_dots_value(idd_env, idf_env, Zone := list(), `zone one` = list(), .type = "object", .unique = FALSE) + set_idf_object(idd_env, idf_env, l$object, l$value) + }, + class = "eplusr_error_set_same" + ) + + expect_is(class = "list", + { + l <- expand_idf_dots_value(idd_env, idf_env, ..8 = list(Name = "Test"), .type = "object") + rp <- set_idf_object(idd_env, idf_env, l$object, l$value) + } + ) + expect_equal(nrow(rp$object), 1L) + expect_equal(rp$object$object_id, 8L) + expect_equal(rp$object$object_name, "Test") + expect_equal(rp$object$object_name_lower, "test") + expect_equal(nrow(rp$value), 11L) + expect_equal(rp$value$value_chr[1L], "Test") + expect_equal(nrow(rp$reference), 0L) + + expect_is(class = "list", + { + l <- expand_idf_dots_value(idd_env, idf_env, FLOOR = list(Name = "Flr"), .type = "object") + floor <- set_idf_object(idd_env, idf_env, l$object, l$value) + } + ) + expect_equal(nrow(floor$object), 1L) + expect_equal(floor$object$object_id, 16) + expect_equal(floor$object$object_name, "Flr") + expect_equal(floor$object$object_name_lower, "flr") + expect_equal(nrow(floor$value), 2) + expect_equal(floor$value$value_chr[1L], "Flr") + expect_equal(floor$reference, + data.table(object_id = c(16L, 25L), value_id = c(111L, 220L), + src_object_id = c(14L, 16L), src_value_id = c(99L, 110L), + src_enum = 2L + ) + ) + + # delete fields + expect_is(class = "list", + { + l <- expand_idf_dots_value(idd_env, idf_env, ..8 = list(name = "name", start_year = NULL), .type = "object", .default = FALSE) + rp <- set_idf_object(idd_env, idf_env, l$object, l$value) + } + ) + expect_equal(nrow(rp$object), 1L) + expect_equal(rp$object$object_id, 8L) + expect_equal(rp$object$object_name, "name") + expect_equal(rp$object$object_name_lower, "name") + expect_equal(nrow(rp$value), 11L) + expect_equal(rp$value$value_chr[1L], "name") + expect_equal(nrow(rp$reference), 0L) + + # can set whole class + expect_is(class = "list", + { + l <- expand_idf_dots_value(idd_env, idf_env, .type = "object", + Material_NoMass := list(roughness = "smooth", thermal_absorptance = 0.8) + ) + mat <- set_idf_object(idd_env, idf_env, l$object, l$value) + } + ) + expect_equal(nrow(mat$object), 2L) + expect_equal(mat$object$object_id, 12:13) + expect_equal(mat$object$object_name, c("R13LAYER", "R31LAYER")) + expect_equal(mat$object$object_name_lower, c("r13layer", "r31layer")) + expect_equal(nrow(mat$value), 8L) + expect_equal(mat$value$field_index, rep(1:4, 2)) + expect_equal(mat$value$value_chr[c(4, 8)], c("0.8", "0.8")) + expect_equal(mat$reference, + data.table(object_id = c(15L, 17L), value_id = c(109L, 113L), + src_object_id = c(12L, 13L), src_value_id = c(87L, 93L), + src_enum = 2L + ) + ) + + # can handle references + expect_equal(class = "list", + { + l <- expand_idf_dots_value(idd_env, idf_env, .type = "object", + ROOF31 = list(outside_layer = "R13LAYER"), + FLOOR = list(outside_layer = "NoSuchMaterial") + ) + set_idf_object(idd_env, idf_env, l$object, l$value, level = "none")$reference + }, + data.table( + object_id = c(17L, 16L, 26L, 25L), + value_id = c(113L, 111L, 242L, 220L), + src_object_id = c(12L, NA, 17L, 16L), + src_value_id = c(87L, NA, 112L, 110L), + src_enum = c(2L, NA, 2L, 2L) ) ) + }) # }}} -# UPDATE {{{ -test_that("Update", { +# DEL {{{ +test_that("Del", { # read idf - idf <- read_idf(example(), 8.8) - idf_env <- ._get_private(idf)$m_idf_env - idd_env <- ._get_private(idf)$idd_env() + idf_env <- parse_idf_file(example(), 8.8) + idd_env <- get_priv_env(use_idd(8.8))$idd_env() + + expect_error(del_idf_object(idd_env, idf_env, get_idf_object(idd_env, idf_env, "Version")), class = "eplusr_error_del_version") + expect_error(del_idf_object(idd_env, idf_env, get_idf_object(idd_env, idf_env, object = 3)), class = "eplusr_error_del_required") + expect_error(del_idf_object(idd_env, idf_env, get_idf_object(idd_env, idf_env, object = 7)), class = "eplusr_error_del_unique") + expect_error(del_idf_object(idd_env, idf_env, get_idf_object(idd_env, idf_env, object = c("R13WALL", "FLOOR", "ROOF31"))), class = "eplusr_error_del_referenced") + expect_message({del <- with_option(list(verbose_info = TRUE), del_idf_object(idd_env, idf_env, get_idf_object(idd_env, idf_env, object = c(21:26, 14)), ref_to = TRUE, ref_by = TRUE, recursive = TRUE))}, "relation") + expect_equivalent(setdiff(idf_env$object$object_id, del$object$object_id), c(14:17, 21:26)) +}) +# }}} - expect_error(update_idf_object(idd_env, idf_env, 8.8), class = "error_empty_input") +# PURGE {{{ +test_that("Purge", { + # read idf + idf_env <- parse_idf_file(example(), 8.8) + idd_env <- get_priv_env(use_idd(8.8))$idd_env() + + expect_message(pu <- with_option(list(verbose_info = TRUE), purge_idf_object(idd_env, idf_env, get_idf_object(idd_env, idf_env, "SimulationControl"))), "ignored") + expect_equal(pu$object, data.table()) + expect_equal(pu$value, data.table()) + expect_equal(pu$reference, data.table()) + + expect_is(pu <- purge_idf_object(idd_env, idf_env, get_idf_object(idd_env, idf_env, "Material:NoMass")), "list") + expect_equal(pu$object, data.table()) + expect_equal(pu$value, data.table()) + expect_equal(pu$reference, data.table()) + + expect_is(pu <- purge_idf_object(idd_env, idf_env, get_idf_object(idd_env, idf_env, "RunPeriod")), "list") + expect_equal(pu$object$object_id, 8L) + expect_equal(nrow(pu$value), 11L) + expect_equal(nrow(pu$reference), 0L) +}) +# }}} - mat <- idf$definition("Material")$to_string() - const <- idf$to_table(class = "Construction") +# DUPLICATED {{{ +test_that("Duplicated", { + # read idf + idf_env <- parse_idf_file(example(), 8.8) + idd_env <- get_priv_env(use_idd(8.8))$idd_env() - const[4, class := "construction"] - expect_error(update_idf_object(idd_env, idf_env, 8.8, mat, const), class = "error_class_name") + dup_idf_object(idd_env, idf_env, get_idf_object(idd_env, idf_env, "SimulationControl"), "none") + expect_equal(duplicated_idf_object(idd_env, idf_env, get_idf_object(idd_env, idf_env))$duplicated, rep(FALSE, 53)) + expect_equal(duplicated_idf_object(idd_env, idf_env, get_idf_object(idd_env, idf_env))$duplicated, rep(FALSE, 53)) +}) +# }}} - const[4, `:=`(class = "Construction", id = 100L)] - expect_error(update_idf_object(idd_env, idf_env, 8.8, mat, const), class = "error_object_id") +# UNIQUE {{{ +test_that("Unique", { + # read idf + idf_env <- parse_idf_file(example(), 8.8) + idd_env <- get_priv_env(use_idd(8.8))$idd_env() - const[4, `:=`(id = 16L, index = 20L)] - expect_error(update_idf_object(idd_env, idf_env, 8.8, mat, const, const), class = "error_set_multi_time") - expect_error(update_idf_object(idd_env, idf_env, 8.8, mat, const), class = "error_bad_field_index") + expect_equal(duplicated_idf_object(idd_env, idf_env, get_idf_object(idd_env, idf_env))$duplicated, rep(FALSE, 53)) +}) +# }}} - const[4, index := 2L] - expect_error(update_idf_object(idd_env, idf_env, 8.8, mat, const), class = "error_missing_object_name") +# RENAME {{{ +test_that("Rename", { + # read idf + idf_env <- parse_idf_file(example(), 8.8) + idd_env <- get_priv_env(use_idd(8.8))$idd_env() - mat_chr <- c("Construction,", "new_const1,", paste0(idf$Material[[1]]$name(), ";")) - expect_error(update_idf_object(idd_env, idf_env, version = idf$version(), mat_chr), class = "error_object_name") + # can stop if try to rename same object multiple times + expect_error( + { + obj <- expand_idf_dots_name(idd_env, idf_env, Floor = "floor", Floo1 = "floor") + rename_idf_object(idd_env, idf_env, obj) + }, + class = "eplusr_error_rename_same" + ) - expect_silent(upd <- update_idf_object(idd_env, idf_env, version = idf$version(), const, idf$Material[[1]]$to_string())) + # can stop if no new names are given + expect_error( + { + obj <- expand_idf_dots_name(idd_env, idf_env, "floor", "zone one", .keep_name = FALSE) + rename_idf_object(idd_env, idf_env, obj) + }, + class = "eplusr_error_rename_no_new_name" + ) + expect_error( + { + obj <- expand_idf_dots_name(idd_env, idf_env, "floor", "zone one") + rename_idf_object(idd_env, idf_env, obj) + }, + class = "eplusr_error_rename_no_new_name" + ) - expect_equivalent(upd$object, - data.table(object_id = c(15:17, 14L), class_id = c(rep(90L, 3), 55L), comment = list(NULL), - object_name = c("R13WALL", "FLOOR", "ROOF31", "C5 - 4 IN HW CONCRETE"), - object_name_lower = c("r13wall", "floor", "roof31", "c5 - 4 in hw concrete") - ) + # can stop if try to assign names to objects without name attribute + expect_error( + { + obj <- expand_idf_dots_name(idd_env, idf_env, version = 1) + rename_idf_object(idd_env, idf_env, obj) + }, + class = "eplusr_error_cannot_name" ) - mat <- idf$Material[[1]]$to_table() - expect_equivalent(upd$value, - data.table(value_id = c(99:113), - value_chr = c(mat$value, const$value), - value_num = c(suppressWarnings(as.double(c(mat$value, const$value)))), - object_id = c(rep(14L, 9), rep(15:17, each = 2)), - field_id = c(7081:7089, rep(11006:11007, 3)) - ) + # can stop if new name has been used by other objects in the same class + expect_error( + { + obj <- expand_idf_dots_name(idd_env, idf_env, Floor = "floor") + rename_idf_object(idd_env, idf_env, obj) + }, + class = "eplusr_error_conflict_name" ) - expect_equivalent(upd$reference, idf_env$reference) - # can also update objects without name using character vector - expect_silent(upd <- update_idf_object(idd_env, idf_env, idf$version(), idf$SimulationControl$to_string())) - expect_equivalent(upd$object, - data.table(object_id = 7L, class_id = 2L, comment = list(NULL), - object_name = NA_character_, object_name_lower = NA_character_ - ) + expect_is(class = "list", + { + obj <- expand_idf_dots_name(idd_env, idf_env, r13 = "R13WALL", flr = "FLOOR", roof = "ROOF31", r31 = "R31LAYER") + l <- rename_idf_object(idd_env, idf_env, obj) + } ) - expect_equivalent(upd$value, - data.table(value_id = c(14:18), value_chr = c("No", "No", "No", "Yes", "Yes"), - value_num = rep(NA_real_, 5L), object_id = rep(7L, 5L), field_id = 2:6 - ) + expect_equal(l$object$object_name, c("r13", "flr", "roof", "r31")) + expect_equal(l$value[field_index == 1L, value_chr], c("r13", "flr", "roof", "r31")) + expect_equal(nrow(l$reference), 7) + expect_equal(idf_env$value[J(l$reference$value_id), on = "value_id", value_chr], + c(rep("r13", 4), "flr", "roof", "r31") ) - expect_equivalent(upd$reference, idf_env$reference) - - expect_silent(update_idf_object(idd_env, idf_env, idf$version(), mat[4])) }) # }}} -# SAVE {{{ -test_that("Save", { - # read idf - idf <- read_idf(example(), 8.8) - idf_env <- ._get_private(idf)$m_idf_env - idd_env <- ._get_private(idf)$idd_env() +# IDF EDITOR {{{ +test_that("Parsing IDF EDITOR Copy Contents", { + skip_if_not(is_windows()) - expect_silent( - save_idf(idd_env, idf_env, idf_env$object[, list(object_id, object_order = 0)], - tempfile(fileext = ".idf"), format = "sorted" - ) - ) - expect_silent( - save_idf(idd_env, idf_env, idf_env$object[, list(object_id, object_order = 0)], - tempfile(fileext = ".idf"), format = "new_top" + # read idf + idf_env <- parse_idf_file(example(), 8.8) + idd_env <- get_priv_env(use_idd(8.8))$idd_env() + + text <- "IDF,BuildingSurface:Detailed,Surface,Wall,R13WALL,ZONE ONE,Outdoors,,SunExposed,WindExposed,0.5000000,4,0,0,4.572000,0,0,0,15.24000,0,0,15.24000,0,4.572000,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,;" + writeClipboard(text) + expect_is(l <- read_idfeditor_copy(idd_env, idf_env), "list") + expect_equal(l$object, + data.table(rleid = 1L, class_id = 103L, class_name = "BuildingSurface:Detailed", + object_id = 1L, object_name = "Surface", object_name_lower = "surface", + comment = list(NULL) ) ) - expect_silent( - save_idf(idd_env, idf_env, idf_env$object[, list(object_id, object_order = 0)], - tempfile(fileext = ".idf"), format = "new_bot" + expect_equal(l$value, + data.table( + rleid = 1L, class_id = 103L, class_name = "BuildingSurface:Detailed", + object_id = 1L, object_name = "Surface", field_id = 11622:11643, + field_index = 1:22, + field_name = c("Name", "Surface Type", "Construction Name", "Zone Name", + "Outside Boundary Condition", "Outside Boundary Condition Object", + "Sun Exposure", "Wind Exposure", "View Factor to Ground", "Number of Vertices", + "Vertex 1 X-coordinate", "Vertex 1 Y-coordinate", "Vertex 1 Z-coordinate", + "Vertex 2 X-coordinate", "Vertex 2 Y-coordinate", "Vertex 2 Z-coordinate", + "Vertex 3 X-coordinate", "Vertex 3 Y-coordinate", "Vertex 3 Z-coordinate", + "Vertex 4 X-coordinate", "Vertex 4 Y-coordinate", "Vertex 4 Z-coordinate"), + value_id = 1:22, + value_chr = c("Surface", "Wall", "R13WALL", "ZONE ONE", "Outdoors", + NA, "SunExposed", "WindExposed", "0.5", "4", "0", "0", "4.572", + "0", "0", "0", "15.24", "0", "0", "15.24", "0", "4.572"), + value_num = c(NA, NA, NA, NA, NA, NA, NA, NA, 0.5, 4, 0, 0, 4.572, + 0, 0, 0, 15.24, 0, 0, 15.24, 0, 4.572) ) ) + expect_equal(l$reference, idf_env$reference[0L]) }) # }}} # TO_TABLE {{{ -test_that("TO_TABLE", { +test_that("to_table", { # read idf - idf <- read_idf(example(), 8.8) - idf_env <- ._get_private(idf)$m_idf_env - idd_env <- ._get_private(idf)$idd_env() + idf_env <- parse_idf_file(example(), 8.8) + idd_env <- get_priv_env(use_idd(8.8))$idd_env() expect_equivalent(get_idf_table(idd_env, idf_env, "Material"), data.table(id = 14L, name = "C5 - 4 IN HW CONCRETE", class = "Material", @@ -1103,3 +2123,63 @@ test_that("TO_TABLE", { ) }) # }}} + +# DT_TO_LOAD {{{ +test_that("dt_to_load", { + # read idf + idf_env <- parse_idf_file(example(), 8.8) + idd_env <- get_priv_env(use_idd(8.8))$idd_env() + + dt_long <- get_idf_table(idd_env, idf_env, "Material") + dt_wide <- get_idf_table(idd_env, idf_env, "Material", wide = TRUE) + expect_equivalent(dt_to_load(dt_wide), dt_long) + + dt_long <- get_idf_table(idd_env, idf_env, "Material", string_value = FALSE) + dt_wide <- get_idf_table(idd_env, idf_env, "Material", string_value = FALSE, wide = TRUE) + expect_equivalent(dt_to_load(dt_wide, FALSE), dt_long) +}) +# }}} + +# TO_STRING {{{ +test_that("to_string", { + # read idf + idf_env <- parse_idf_file(example(), 8.8) + idd_env <- get_priv_env(use_idd(8.8))$idd_env() + + expect_equal(length(get_idf_string(idd_env, idf_env)), 634) + expect_equal(length(get_idf_string(idd_env, idf_env, comment = FALSE)), 541) + + expect_equal(length(get_idf_string(idd_env, idf_env, idf_env$object[0, list(object_id, object_order = integer())], format = "new_top")), 553) + expect_equal(length(get_idf_string(idd_env, idf_env, idf_env$object[0, list(object_id, object_order = integer())], format = "new_top", comment = FALSE)), 460) + + expect_equal(length(get_idf_string(idd_env, idf_env, class = "Version")), 97) + expect_equal(length(get_idf_string(idd_env, idf_env, class = "Version", comment = FALSE)), 12) + expect_equal(length(get_idf_string(idd_env, idf_env, class = "Version", comment = FALSE, header = FALSE)), 5) + expect_equal(length(get_idf_string(idd_env, idf_env, class = "Material", header = FALSE, in_ip = TRUE)), 13L) +}) +# }}} + +# SAVE {{{ +test_that("Save", { + # read idf + idf_env <- parse_idf_file(example(), 8.8) + idd_env <- get_priv_env(use_idd(8.8))$idd_env() + + expect_silent( + save_idf(idd_env, idf_env, idf_env$object[, list(object_id, object_order = 0)], + tempfile(fileext = ".idf"), format = "sorted" + ) + ) + expect_silent( + save_idf(idd_env, idf_env, idf_env$object[, list(object_id, object_order = 0)], + tempfile(fileext = ".idf"), format = "new_top" + ) + ) + expect_silent( + save_idf(idd_env, idf_env, idf_env$object[, list(object_id, object_order = 0)], + tempfile(fileext = ".idf"), format = "new_bot" + ) + ) +}) +# }}} + From 4931bf27b124ff21b990eb96f1e1d9649d490a2e Mon Sep 17 00:00:00 2001 From: Hongyuan Jia Date: Mon, 13 Jul 2020 13:36:28 +0800 Subject: [PATCH 24/43] [refactor] Refactor basic implementation --- DESCRIPTION | 3 +- NAMESPACE | 68 ++ R/idd.R | 17 +- R/idf.R | 488 ++++---- R/{idf_object.R => idfobj.R} | 162 ++- R/impl-idd.R | 43 +- R/impl-idf.R | 665 +++++------ R/impl-idfobj.R | 145 +-- R/impl.R | 17 +- R/parse.R | 135 ++- _pkgdown.yml | 1 + man/Idf.Rd | 23 +- man/IdfObject.Rd | 2 +- man/add_idf_object.Rd | 14 +- man/as.character.IdfObject.Rd | 13 +- man/assign_idf_value_default.Rd | 24 + man/del_idf_object.Rd | 11 +- man/dt_to_load.Rd | 15 +- man/dup_idf_object.Rd | 11 +- man/duplicated_idf_object.Rd | 7 +- man/expand_idf_regex.Rd | 2 + man/format.IddObject.Rd | 4 +- man/format.IdfObject.Rd | 2 +- man/get_idd_field.Rd | 9 +- man/get_idf_node_relation.Rd | 60 + man/get_object_info.Rd | 46 + man/idf_object.Rd | 2 +- man/make_idf_object_name.Rd | 4 +- man/purge_idf_object.Rd | 13 +- man/remove_duplicated_objects.Rd | 27 + man/remove_empty_fields.Rd | 24 + man/rename_idf_object.Rd | 21 +- man/set_idf_object.Rd | 17 +- man/unique_idf_object.Rd | 11 +- tests/testthat/{test_idd.R => test-idd.R} | 0 .../testthat/{test_iddobj.R => test-iddobj.R} | 0 tests/testthat/{test_idf.R => test-idf.R} | 1010 ++++++++++++----- tests/testthat/test-idfobj.R | 393 +++++-- .../{test_impl-idd.R => test-impl-idd.R} | 6 +- ...{test_impl-iddobj.R => test-impl-iddobj.R} | 0 .../{test_impl-idf.R => test-impl-idf.R} | 642 +++++++---- tests/testthat/test-impl-idfobj.R | 199 ++++ tests/testthat/{test_impl.R => test-impl.R} | 2 +- .../{test_options.R => test-options.R} | 0 tests/testthat/{test_parse.R => test-parse.R} | 25 +- tests/testthat/{test_run.R => test-run.R} | 0 tests/testthat/{test_utils.R => test-utils.R} | 0 tests/testthat/test_param.R | 2 +- 48 files changed, 2866 insertions(+), 1519 deletions(-) rename R/{idf_object.R => idfobj.R} (95%) create mode 100644 man/assign_idf_value_default.Rd create mode 100644 man/get_idf_node_relation.Rd create mode 100644 man/get_object_info.Rd create mode 100644 man/remove_duplicated_objects.Rd create mode 100644 man/remove_empty_fields.Rd rename tests/testthat/{test_idd.R => test-idd.R} (100%) rename tests/testthat/{test_iddobj.R => test-iddobj.R} (100%) rename tests/testthat/{test_idf.R => test-idf.R} (55%) rename tests/testthat/{test_impl-idd.R => test-impl-idd.R} (98%) rename tests/testthat/{test_impl-iddobj.R => test-impl-iddobj.R} (100%) rename tests/testthat/{test_impl-idf.R => test-impl-idf.R} (81%) create mode 100644 tests/testthat/test-impl-idfobj.R rename tests/testthat/{test_impl.R => test-impl.R} (98%) rename tests/testthat/{test_options.R => test-options.R} (100%) rename tests/testthat/{test_parse.R => test-parse.R} (93%) rename tests/testthat/{test_run.R => test-run.R} (100%) rename tests/testthat/{test_utils.R => test-utils.R} (100%) diff --git a/DESCRIPTION b/DESCRIPTION index 08135f0e9..f9c6e51f2 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -20,6 +20,7 @@ Depends: R (>= 3.2.0) Imports: callr (>= 2.0.4), + checkmate, cli (>= 1.1.0), crayon, data.table (>= 1.12.4), @@ -64,7 +65,7 @@ Collate: 'group.R' 'impl-idd.R' 'idd.R' - 'idd_object.R' + 'iddobj.R' 'impl-idf.R' 'idf.R' 'impl-idfobj.R' diff --git a/NAMESPACE b/NAMESPACE index bfdc0c670..924fb78c4 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -88,27 +88,44 @@ export(IddObject) export(Idf) export(IdfObject) export(ParametricJob) +export(add_idf_object) +export(assign_idf_value_default) export(avail_eplus) export(avail_idd) export(clean_wd) export(custom_validate) +export(del_idf_object) export(download_eplus) export(download_idd) export(download_weather) export(dt_to_load) +export(dup_idf_object) +export(duplicated_idf_object) export(empty_idf) export(eplus_config) export(eplus_job) export(eplus_sql) export(eplusr_option) +export(expand_idf_dots_literal) +export(expand_idf_dots_name) +export(expand_idf_dots_object) +export(expand_idf_dots_value) +export(expand_idf_regex) export(get_idd_class) export(get_idd_field) export(get_idd_relation) +export(get_idf_node_relation) +export(get_idf_object) +export(get_idf_relation) +export(get_idf_value) +export(get_object_info) export(get_priv_env) export(get_self_env) export(group_job) export(idd_object) export(idf_object) +export(init_idf_object) +export(init_idf_value) export(install_eplus) export(is_avail_eplus) export(is_avail_idd) @@ -121,18 +138,27 @@ export(is_iddobject) export(is_idf) export(is_idfobject) export(level_checks) +export(make_idf_object_name) export(mdd_to_load) export(param_job) +export(parse_dots_value) +export(purge_idf_object) export(rdd_to_load) export(read_epw) export(read_err) export(read_idf) +export(read_idfeditor_copy) export(read_mdd) export(read_rdd) export(reload) +export(remove_duplicated_objects) +export(remove_empty_fields) +export(rename_idf_object) export(run_idf) export(run_multi) +export(set_idf_object) export(transition) +export(unique_idf_object) export(use_eplus) export(use_idd) export(version_updater) @@ -148,6 +174,47 @@ importFrom(RSQLite,dbGetQuery) importFrom(RSQLite,dbListTables) importFrom(RSQLite,dbReadTable) importFrom(callr,r_bg) +importFrom(checkmate,assert) +importFrom(checkmate,assert_character) +importFrom(checkmate,assert_choice) +importFrom(checkmate,assert_class) +importFrom(checkmate,assert_count) +importFrom(checkmate,assert_data_frame) +importFrom(checkmate,assert_data_table) +importFrom(checkmate,assert_directory_exists) +importFrom(checkmate,assert_file) +importFrom(checkmate,assert_file_exists) +importFrom(checkmate,assert_flag) +importFrom(checkmate,assert_function) +importFrom(checkmate,assert_integer) +importFrom(checkmate,assert_integerish) +importFrom(checkmate,assert_list) +importFrom(checkmate,assert_logical) +importFrom(checkmate,assert_names) +importFrom(checkmate,assert_number) +importFrom(checkmate,assert_numeric) +importFrom(checkmate,assert_posixct) +importFrom(checkmate,assert_scalar) +importFrom(checkmate,assert_string) +importFrom(checkmate,assert_subset) +importFrom(checkmate,assert_true) +importFrom(checkmate,assert_vector) +importFrom(checkmate,check_character) +importFrom(checkmate,check_integerish) +importFrom(checkmate,check_string) +importFrom(checkmate,qassert) +importFrom(checkmate,qassertr) +importFrom(checkmate,qtestr) +importFrom(checkmate,test_character) +importFrom(checkmate,test_choice) +importFrom(checkmate,test_class) +importFrom(checkmate,test_file_exists) +importFrom(checkmate,test_flag) +importFrom(checkmate,test_integerish) +importFrom(checkmate,test_list) +importFrom(checkmate,test_names) +importFrom(checkmate,test_r6) +importFrom(checkmate,test_string) importFrom(cli,boxx) importFrom(cli,cat_boxx) importFrom(cli,cat_bullet) @@ -183,6 +250,7 @@ importFrom(data.table,setnafill) importFrom(data.table,setnames) importFrom(data.table,setorder) importFrom(data.table,setorderv) +importFrom(data.table,transpose) importFrom(grDevices,rgb) importFrom(lubridate,"year<-") importFrom(lubridate,as_datetime) diff --git a/R/idd.R b/R/idd.R index 7ec41f42c..c156abd10 100644 --- a/R/idd.R +++ b/R/idd.R @@ -920,7 +920,7 @@ idd_print <- function (self, private) { private <- get_priv_env(x) - cls_id <- chmatch(i, private$m_idd_env$class$class_name_us) + cls_id <- chmatch(underscore_name(i), private$m_idd_env$class$class_name_us) # skip if not a valid IDD class name if (is.na(cls_id)) return(NextMethod()) @@ -937,6 +937,19 @@ str.Idd <- function (object, ...) { } # }}} +#' Format an Idd +#' +#' Format an [Idd] into a string. +#' +#' @param x An [Idd] object. +#' @param ... Further arguments passed to or from other methods. +#' +#' @return A single length character vector. +#' @examples +#' \dontrun{ +#' format(use_idd(8.8, download = "auto")) +#' } +#' #' @export # format.Idd {{{ format.Idd <- function (x, ...) { @@ -1279,7 +1292,7 @@ find_idd_from_updater <- function (ver) { line_break <- if (i == 1L) "" else "\n" dir <- file.path(eplus_config(vers[i])$dir, "PreProcess", "IDFVersionUpdater") idd_path <- normalizePath(file.path(dir, file), mustWork = FALSE) - msg <- paste0(msg, line_break, "Try to locate `", file, "` in EnergyPlus v", + msg <- paste0(msg, line_break, "Try to locate ", surround(file), " in EnergyPlus v", vers[i], " IDFVersionUpdater folder ", surround(dir), "." ) diff --git a/R/idf.R b/R/idf.R index 762de25f6..cab3dcce6 100644 --- a/R/idf.R +++ b/R/idf.R @@ -132,7 +132,6 @@ Idf <- R6::R6Class(classname = "Idf", lock_objects = FALSE, , object_order := 0L] private$m_log$view_in_ip <- eplusr_option("view_in_ip") - private$m_log$num_digits <- eplusr_option("num_digits") private$m_log$save_format <- idf_file$options$save_format }, # }}} @@ -552,6 +551,9 @@ Idf <- R6::R6Class(classname = "Idf", lock_objects = FALSE, #' #' @param which A single integer specifying the object ID or a single #' string specifying the object name. + #' @param class A character vector that contains valid class names for + #' current `Idf` object used to locate objects. If `NULL`, all + #' classes in current `Idf` object are used. Default: `NULL`. #' #' @return An [IdfObject] object. #' @@ -565,8 +567,8 @@ Idf <- R6::R6Class(classname = "Idf", lock_objects = FALSE, #' idf$object("simple one zone (wireframe dxf)") #' } #' - object = function (which) - idf_obj(self, private, which), + object = function (which, class = NULL) + idf_obj(self, private, which, class), # }}} # objects {{{ @@ -1079,7 +1081,7 @@ Idf <- R6::R6Class(classname = "Idf", lock_objects = FALSE, #' } #' add = function (..., .default = TRUE, .all = FALSE) - idf_add(self, private, ..., .default = .default, .all = .all), + idf_add(self, private, ..., .default = .default, .all = .all, .env = parent.frame()), # }}} # set {{{ @@ -1192,7 +1194,7 @@ Idf <- R6::R6Class(classname = "Idf", lock_objects = FALSE, #' } #' set = function (..., .default = TRUE, .empty = FALSE) - idf_set(self, private, ..., .default = .default, .empty = .empty), + idf_set(self, private, ..., .default = .default, .empty = .empty, .env = parent.frame()), # }}} # del {{{ @@ -1351,7 +1353,8 @@ Idf <- R6::R6Class(classname = "Idf", lock_objects = FALSE, #' * `class`: Character. Names of classes that input objects belong to #' * `id`: Integer. Input object IDs #' * `name`: Character. Input object names - #' * `duplicated`: Logical. Whether this object is a duplication or not + #' * `duplicate`: Integer. The IDs of objects that input objects + #' duplicate. If input object is not a duplication, `NA` is returned #' #' @examples #' \dontrun{ @@ -2204,6 +2207,10 @@ Idf <- R6::R6Class(classname = "Idf", lock_objects = FALSE, #' with lots of columns. But may be useful when you know that #' target classes have the exact same fields, e.g. #' `Ceiling:Adiabatic` and `Floor:Adiabatic`. Default: `FALSE`. + #' @param init If `TRUE`, a table for new object input will be returned + #' with all values filled with defaults. In this case, `object` + #' input will be ignored. The `id` column will be filled with + #' possible new object IDs. Default: `FALSE`. #' #' @return A [data.table][data.table::data.table()] with 6 columns (if #' `wide` is `FALSE`) or at least 6 columns (if `wide` is `TRUE`). @@ -2253,14 +2260,18 @@ Idf <- R6::R6Class(classname = "Idf", lock_objects = FALSE, #' idf$to_table(class = "BuildingSurface:Detailed", group_ext = "index", #' wide = TRUE, string_value = FALSE, unit = TRUE #' ) + #' + #' # create table for new object input + #' idf$to_table(class = "BuildingSurface:Detailed", init = TRUE) #' } #' to_table = function (which = NULL, class = NULL, string_value = TRUE, unit = FALSE, wide = FALSE, align = FALSE, all = FALSE, - group_ext = c("none", "group", "index"), force = FALSE) + group_ext = c("none", "group", "index"), force = FALSE, + init = FALSE) idf_to_table(self, private, which = which, class = class, string_value = string_value, unit = unit, wide = wide, align = align, - all = all, group_ext = match.arg(group_ext), force = force), + all = all, group_ext = match.arg(group_ext), force = force, init = init), # }}} # is_unsaved {{{ @@ -2678,17 +2689,13 @@ Idf <- R6::R6Class(classname = "Idf", lock_objects = FALSE, # }}} idd_env = function () { - ._get_private(private$m_idd)$m_idd_env + get_priv_env(private$m_idd)$m_idd_env }, idf_env = function () { private$m_idf_env }, - log_env = function () { - private$m_log - }, - deep_clone = function (name, value) { idf_deep_clone(self, private, name, value) } @@ -2777,26 +2784,30 @@ idf_object_num <- function (self, private, class = NULL) { } # }}} # idf_is_valid_group_name {{{ +#' @importFrom checkmate assert_character idf_is_valid_group_name <- function (self, private, group, all = FALSE) { - assert(is.character(group), msg = "`group` should be a character vector.") - group %in% idf_group_name(self, private, all, FALSE) + assert_valid_type(group, "Group Name", type = "name") + group %chin% idf_group_name(self, private, all, FALSE) } # }}} # idf_is_valid_class_name {{{ +#' @importFrom checkmate assert_character idf_is_valid_class_name <- function (self, private, class, all = FALSE) { - assert(is.character(class), msg = "`class` should be a character vector.") + assert_valid_type(class, "Class Name", type = "name") class %in% idf_class_name(self, private, all, FALSE) } # }}} # idf_is_valid_object_id {{{ +#' @importFrom checkmate assert_integerish idf_is_valid_object_id <- function (self, private, id) { - assert(are_count(id)) + assert_valid_type(id, "Object ID", type = "id") + id <- assert_integerish(id, any.missing = FALSE, coerce = TRUE) id %in% idf_object_id(self, private, NULL, simplify = TRUE) } # }}} # idf_is_valid_object_name {{{ idf_is_valid_object_name <- function (self, private, name) { - assert(is.character(name), msg = "`name` should be a character vector.") + assert_valid_type(name, "Object Name", type = "name") stri_trans_tolower(name) %chin% private$idf_env()$object[!is.na(object_name), object_name_lower] } # }}} @@ -2815,66 +2826,59 @@ idf_definition <- function (self, private, class = NULL) { } # }}} # idf_obj {{{ -idf_obj <- function (self, private, which) { - assert(!is.null(which), is_scalar(which)) - obj <- get_idf_object(private$idd_env(), private$idf_env(), class = NULL, object = which, - ignore_case = TRUE +#' @importFrom checkmate assert +idf_obj <- function (self, private, which, class = NULL) { + assert_valid_type(which, "Object ID|Name", len = 1L) + obj <- get_idf_object(private$idd_env(), private$idf_env(), + class = class, object = which, ignore_case = TRUE ) - add_idfobj_field_bindings(IdfObject$new(obj$object_id, obj$class_id, parent = self)) + idf_return_matched(self, private, obj)[[1L]] } # }}} # idf_object_unique {{{ idf_object_unique <- function (self, private, class) { - assert(is_scalar(class)) + assert_valid_type(class, "Class Name", len = 1L, type = "name") obj <- get_idf_object(private$idd_env(), private$idf_env(), class) - if (!unique(obj$class_id) %in% private$idd_env()$class[unique_object == TRUE, class_id]) { - abort("error_idf_not_unique_class", - paste0(surround(unique(obj$class_name)), " is not a valid unique-object class index or name.") - ) + if (!unique(obj$class_id) %in% private$idd_env()$class[J(TRUE), on = "unique_object", class_id, nomatch = NULL]) { + abort(paste0(surround(unique(obj$class_name)), " is not a valid unique-object class index or name.")) } if (nrow(obj) > 1L) { - abort("error_idf_dup_unique_class", - paste0(surround(unique(obj$class_name)), " class have more than one ", - "objects:\n", - get_object_info(obj[, rleid := .I], c("id", "name"), collapse = "\n"), - "\nPlease see `$validate()` for more details." - ) - ) + abort(paste0("Unique-object class ", surround(unique(obj$class_name)), " have more than one objects:\n", + get_object_info(obj[, rleid := .I], c("id", "name"), collapse = "\n"), + "\nPlease see '$validate()' for more details." + )) } - add_idfobj_field_bindings(IdfObject$new(obj$object_id, obj$class_id, parent = self)) + idf_return_matched(self, private, obj)[[1L]] } # }}} # idf_objects {{{ -idf_objects <- function (self, private, which) { - assert(!is.null(which)) - obj <- get_idf_object(private$idd_env(), private$idf_env(), class = NULL, object = which, - ignore_case = TRUE +#' @importFrom checkmate assert check_character check_integerish +idf_objects <- function (self, private, which, class = NULL) { + assert_valid_type(which, "Object ID|Name") + obj <- get_idf_object(private$idd_env(), private$idf_env(), + class = class, object = which, ignore_case = TRUE ) - res <- apply2(obj$object_id, obj$class_id, IdfObject$new, list(parent = self)) - res <- lapply(res, add_idfobj_field_bindings) - setattr(res, "names", obj$object_name) - res + idf_return_matched(self, private, obj) } # }}} # idf_objects_in_class {{{ +#' @importFrom checkmate assert_string idf_objects_in_class <- function (self, private, class) { - assert(is_string(class)) + assert_valid_type(class, "Class Name", type = "name") obj <- get_idf_object(private$idd_env(), private$idf_env(), class) - res <- apply2(obj$object_id, obj$class_id, IdfObject$new, list(parent = self)) - res <- lapply(res, add_idfobj_field_bindings) - setattr(res, "names", obj$object_name) - res + idf_return_matched(self, private, obj) } # }}} # idf_objects_in_group {{{ +#' @importFrom checkmate assert_string idf_objects_in_group <- function (self, private, group) { - assert(is_string(group)) + assert_string(group) add_joined_cols(private$idd_env()$class, private$idf_env()$object, "class_id", "group_id") add_joined_cols(private$idd_env()$group, private$idf_env()$object, "group_id", "group_name") @@ -2884,18 +2888,16 @@ idf_objects_in_group <- function (self, private, group) { obj <- join_from_input(private$idf_env()$object, grp_in, "group_id") - res <- apply2(obj$object_id, obj$class_id, IdfObject$new, list(parent = self)) - res <- lapply(res, add_idfobj_field_bindings) - setattr(res, "names", obj$object_name) - res + idf_return_matched(self, private, obj) } # }}} # idf_object_relation {{{ +#' @importFrom checkmate assert check_string idf_object_relation <- function (self, private, which, direction = c("all", "ref_to", "ref_by", "node"), object = NULL, class = NULL, group = NULL, depth = 0L, keep = FALSE, class_ref = c("both", "none", "all")) { - assert(is_scalar(which)) + assert_valid_type(which, "Object ID|Name") obj <- get_idf_object(private$idd_env(), private$idf_env(), object = which, ignore_case = TRUE @@ -2912,7 +2914,7 @@ idf_object_relation <- function (self, private, which, idf_objects_in_relation <- function (self, private, which, direction = c("ref_to", "ref_by", "node"), object = NULL, class = NULL, group = NULL, depth = 0L, class_ref = c("both", "none", "all")) { - assert(is_scalar(which)) + assert_valid_type(which, "Object ID|Name") direction <- match.arg(direction) obj <- get_idf_object(private$idd_env(), private$idf_env(), object = which, ignore_case = TRUE) @@ -2932,7 +2934,7 @@ idf_objects_in_relation <- function (self, private, which, direction = c("ref_to setattr(obj_self, "names", obj$object_name) if (!length(id_ref)) { - if (eplusr_option("verbose_info")) { + if (in_verbose()) { dir <- switch(direction, ref_to = "does not refer to", ref_by = "is not referred by", node = "has no node or their nodes have no reference to" ) @@ -2962,9 +2964,7 @@ idf_objects_in_relation <- function (self, private, which, direction = c("ref_to idf_search_object <- function (self, private, pattern, class = NULL, ignore.case = FALSE, perl = FALSE, fixed = FALSE, useBytes = FALSE) { if (!is.null(class) && anyDuplicated(class)) { - abort("error_search_object_dup_class", - "Class should not contain any duplication.", class = class - ) + abort("Class should not contain any duplication.") } obj <- get_idf_object(private$idd_env(), private$idf_env(), class) @@ -2978,238 +2978,283 @@ idf_search_object <- function (self, private, pattern, class = NULL, ignore.case return(invisible()) } - res <- apply2(obj$object_id, obj$class_id, IdfObject$new, list(parent = self)) - res <- lapply(res, add_idfobj_field_bindings) - setattr(res, "names", obj$object_name) - res + idf_return_matched(self, private, obj) } # }}} -# idf_return_modified {{{ -idf_return_modified <- function (self, private, modified) { - res <- apply2(modified$object$object_id, modified$object$class_id, IdfObject$new, list(parent = self)) +# idf_return_matched {{{ +idf_return_matched <- function (self, private, matched, object_id) { + if (is.numeric(matched)) { + matched <- private$idf_env()$object[J(matched), on = "object_id", nomatch = NULL] + } + + res <- apply2(matched$object_id, matched$class_id, IdfObject$new, list(parent = self)) res <- lapply(res, add_idfobj_field_bindings) - setattr(res, "names", modified$object$object_name) - res + setattr(res, "names", matched$object_name) +} +# }}} +# idf_update_idf_env {{{ +idf_update_idf_env <- function (self, private, lst) { + idf_env <- private$idf_env() + idf_env$object <- lst$object + idf_env$value <- lst$value + idf_env$reference <- lst$reference } # }}} # idf_dup {{{ idf_dup <- function (self, private, ...) { - dup <- dup_idf_object(private$idd_env(), private$idf_env(), ...) - merge_idf_data(private$idf_env(), dup) + obj <- expand_idf_dots_name(private$idd_env(), private$idf_env(), ...) + dup <- dup_idf_object(private$idd_env(), private$idf_env(), obj) # log - log_new_order(private$m_log, dup$object$object_id) + log_new_order(private$m_log, dup$changed) log_unsaved(private$m_log) log_new_uuid(private$m_log) - idf_return_modified(self, private, dup) + idf_update_idf_env(self, private, dup) + idf_return_matched(self, private, dup$changed) } # }}} # idf_add {{{ -idf_add <- function (self, private, ..., .default = TRUE, .all = FALSE, .env = parent.frame(2)) { - add <- add_idf_object(private$idd_env(), private$idf_env(), ..., .default = .default, .all = .all, .env = .env) - merge_idf_data(private$idf_env(), add) +idf_add <- function (self, private, ..., .default = TRUE, .all = FALSE, .env = parent.frame()) { + l <- expand_idf_dots_value(private$idd_env(), private$idf_env(), ..., + .type = "class", .complete = TRUE, .all = .all, + .scalar = FALSE, .pair = TRUE, .ref_assign = TRUE, + .unique = FALSE, .empty = TRUE, .default = .default, .env = .env + ) + + add <- add_idf_object(private$idd_env(), private$idf_env(), + l$object, l$value, default = FALSE, unique = FALSE, empty = .all) + + if (!length(add$changed)) return(invisible(NULL)) # log - log_new_order(private$m_log, add$object$object_id) + log_new_order(private$m_log, add$changed) log_unsaved(private$m_log) log_new_uuid(private$m_log) - idf_return_modified(self, private, add) + idf_update_idf_env(self, private, add) + idf_return_matched(self, private, add$changed) } # }}} # idf_set {{{ -idf_set <- function (self, private, ..., .default = TRUE, .empty = FALSE, .env = parent.frame(2)) { - set <- set_idf_object(private$idd_env(), private$idf_env(), ..., .default = .default, .empty = .empty, .env = .env) - merge_idf_data(private$idf_env(), set, by_object = TRUE) +idf_set <- function (self, private, ..., .default = TRUE, .empty = FALSE, .env = parent.frame()) { + l <- expand_idf_dots_value(private$idd_env(), private$idf_env(), ..., + .type = "object", .complete = TRUE, .all = FALSE, + .scalar = FALSE, .pair = TRUE, .ref_assign = TRUE, + .unique = TRUE, .empty = TRUE, .default = .default, .env = .env + ) + + set <- set_idf_object(private$idd_env(), private$idf_env(), + l$object, l$value, empty = .empty) # log - log_add_order(private$m_log, set$object$object_id) + log_add_order(private$m_log, c(set$changed, set$updated)) log_unsaved(private$m_log) log_new_uuid(private$m_log) - idf_return_modified(self, private, set) + idf_update_idf_env(self, private, set) + idf_return_matched(self, private, set$changed) } # }}} # idf_del {{{ idf_del <- function (self, private, ..., .ref_by = FALSE, .ref_to = FALSE, .recursive = FALSE, .force = FALSE) { - del <- del_idf_object(private$idd_env(), private$idf_env(), ..., - .ref_by = .ref_by, .ref_to = .ref_to, .recursive = .recursive, .force = .force - ) - - private$m_idf_env$object <- del$object - private$m_idf_env$value <- del$value - private$m_idf_env$reference <- del$reference + obj <- expand_idf_dots_name(private$idd_env(), private$idf_env(), ..., .keep_name = FALSE) + del <- del_idf_object(private$idd_env(), private$idf_env(), obj, + ref_to = .ref_to, ref_by = .ref_by, recursive = .recursive, force = .force) # log - log_del_order(private$m_log, del$object$object_id) + log_del_order(private$m_log, del$changed) log_unsaved(private$m_log) log_new_uuid(private$m_log) + idf_update_idf_env(self, private, del) + invisible(self) } # }}} # idf_purge {{{ idf_purge <- function (self, private, object = NULL, class = NULL, group = NULL) { - purge <- purge_idf_object(private$idd_env(), private$idf_env(), object, class, group) + obj <- get_idf_object_multi_scope(private$idd_env(), private$idf_env(), object, class, group) + purge <- purge_idf_object(private$idd_env(), private$idf_env(), obj) - private$m_idf_env$object <- purge$object - private$m_idf_env$value <- purge$value - private$m_idf_env$reference <- purge$reference + if (!length(purge$changed)) return(invisible(self)) # log - log_del_order(private$m_log, purge$object$object_id) + log_del_order(private$m_log, purge$changed) log_unsaved(private$m_log) log_new_uuid(private$m_log) + idf_update_idf_env(self, private, purge) + invisible(self) } # }}} # idf_duplicated {{{ idf_duplicated <- function (self, private, object = NULL, class = NULL, group = NULL) { - dup <- duplicated_idf_object(private$idd_env(), private$idf_env(), object, class, group) - dup$object[, list(class = class_name, id = object_id, name = object_name, duplicated)] + obj <- get_idf_object_multi_scope(private$idd_env(), private$idf_env(), object, class, group) + duplicated_idf_object(private$idd_env(), private$idf_env(), obj)[ + , list(class = class_name, id = object_id, name = object_name, duplicate = unique_object_id)] } # }}} # idf_unique {{{ idf_unique <- function (self, private, object = NULL, class = NULL, group = NULL) { - uni <- unique_idf_object(private$idd_env(), private$idf_env(), object, class, group) + obj <- get_idf_object_multi_scope(private$idd_env(), private$idf_env(), object, class, group) + uni <- unique_idf_object(private$idd_env(), private$idf_env(), obj) - private$m_idf_env$object <- uni$object - private$m_idf_env$value <- uni$value - private$m_idf_env$reference <- uni$reference + if (!length(uni$changed)) return(invisible(self)) # log - log_del_order(private$m_log, uni$object$object_id) + log_del_order(private$m_log, uni$changed) log_unsaved(private$m_log) log_new_uuid(private$m_log) + idf_update_idf_env(self, private, uni) + invisible(self) } # }}} # idf_rename {{{ idf_rename <- function (self, private, ...) { - ren <- rename_idf_object(private$idd_env(), private$idf_env(), ...) - - merge_idf_data(private$idf_env(), ren) + obj <- expand_idf_dots_name(private$idd_env(), private$idf_env(), ..., .keep_name = TRUE) + ren <- rename_idf_object(private$idd_env(), private$idf_env(), obj) # log - log_add_order(private$m_log, ren$object$object_id) + log_add_order(private$m_log, c(ren$changed, ren$updated)) log_unsaved(private$m_log) log_new_uuid(private$m_log) - res <- apply2(ren$object$object_id, ren$object$class_id, IdfObject$new, list(parent = self)) - setattr(res, "names", ren$object$object_name) - res + idf_update_idf_env(self, private, ren) + idf_return_matched(self, private, ren$changed) } # }}} # idf_insert {{{ idf_insert <- function (self, private, ..., .unique = TRUE, .empty = FALSE) { - ins <- insert_idf_object(private$idd_env(), private$idf_env(), private$m_version, ..., .unique = .unique, .empty = .empty) + l <- expand_idf_dots_object(private$idd_env(), private$idf_env(), ..., + .unique = FALSE, .strict = TRUE) + + # ignore Version object + if (any(l$object$class_id == 1L)) { + if (in_verbose()) { + m <- l$object[class_id == 1L, paste0(" #", rleid, "| Object [", object_id, ", ] --> Class 'Version'", collapse = "\n")] + verbose_info("'Version' objects in input below have been automatically skipped:\n", m) + } + l$object <- l$object[!J(1L), on = "class_id"] + l$value <- l$value[J(l$object$rleid), on = "rleid"] - if (!nrow(ins$object)) { - verbose_info("After deleting duplications, nothing to add.") - return(invisible()) + if (!nrow(l$object)) { + verbose_info("After removing Version objects, nothing to add.") + return(invisible()) + } } - merge_idf_data(private$idf_env(), ins, by_object = TRUE) + ins <- add_idf_object(private$idd_env(), private$idf_env(), l$object, l$value, + default = FALSE, unique = .unique, empty = .empty + ) + + if (!length(ins$changed)) return(invisible()) # log - log_new_order(private$m_log, ins$object$object_id) + log_new_order(private$m_log, ins$changed) log_unsaved(private$m_log) log_new_uuid(private$m_log) - idf_return_modified(self, private, ins) + idf_update_idf_env(self, private, ins) + idf_return_matched(self, private, ins$changed) } # }}} # idf_search_value {{{ idf_search_value <- function (self, private, pattern, class = NULL, ignore.case = FALSE, perl = FALSE, fixed = FALSE, useBytes = FALSE) { - val <- search_idf_value(private$idd_env(), private$idf_env(), pattern, class, - ignore.case, perl, fixed, useBytes - ) + l <- expand_idf_regex(private$idd_env(), private$idf_env(), pattern, + replacement = NULL, class, ignore.case, perl, fixed, useBytes) - if (is.null(val)) return(invisible()) + if (!nrow(l$object)) { + verbose_info("No matched result found.") + return(invisible()) + } - obj <- val[, list(object_name = object_name[[1L]]), by = c("class_id", "object_id")] - idf_return_modified(self, private, list(object = obj)) + idf_return_matched(self, private, l$object) } # }}} # idf_replace_value {{{ idf_replace_value <- function (self, private, pattern, replacement, class = NULL, ignore.case = FALSE, perl = FALSE, fixed = FALSE, useBytes = FALSE) { - rep <- replace_idf_value(private$idd_env(), private$idf_env(), pattern, replacement, - class, ignore.case, perl, fixed, useBytes) + l <- expand_idf_regex(private$idd_env(), private$idf_env(), pattern, + replacement, class, ignore.case, perl, fixed, useBytes) - if (is.null(rep)) return(invisible()) + if (!nrow(l$object)) { + verbose_info("No matched result found.") + return(invisible()) + } - merge_idf_data(private$idf_env(), rep) + rep <- set_idf_object(private$idd_env(), private$idf_env(), l$object, l$value, empty = FALSE) # log - log_add_order(private$m_log, rep$object$object_id) + log_add_order(private$m_log, c(rep$changed, rep$updated)) log_unsaved(private$m_log) log_new_uuid(private$m_log) - idf_return_modified(self, private, rep) + idf_update_idf_env(self, private, rep) + idf_return_matched(self, private, rep$changed) } # }}} # idf_paste {{{ idf_paste <- function (self, private, in_ip = FALSE, ver = NULL, unique = TRUE, empty = FALSE) { - pas <- paste_idf_object(private$idd_env(), private$idf_env(), - version = private$m_version, in_ip = in_ip, unique = unique, empty = empty - ) + if (is.null(ver)) ver <- private$m_version - if (!nrow(pas$object)) { - verbose_info("After deleting duplications, nothing to add.") - return(invisible()) - } + l <- read_idfeditor_copy(private$idd_env(), private$idf_env(), version = ver, in_ip = in_ip) - merge_idf_data(private$idf_env(), pas, by_object = TRUE) + pst <- add_idf_object(private$idd_env(), private$idf_env(), + l$object, l$value, default = FALSE, unique = unique, empty = empty) + + if (!length(pst$changed)) return(invisible()) # log - log_new_order(private$m_log, pas$object$object_id) + log_new_order(private$m_log, pst$changed) log_unsaved(private$m_log) log_new_uuid(private$m_log) - idf_return_modified(self, private, pas) + idf_update_idf_env(self, private, pst) + idf_return_matched(self, private, pst$changed) } # }}} # idf_load {{{ idf_load <- function (self, private, ..., .unique = TRUE, .default = TRUE, .empty = FALSE) { - l <- load_idf_object(private$idd_env(), private$idf_env(), private$m_version, - ..., .unique = .unique, .default = .default, .empty = .empty + l <- expand_idf_dots_literal(private$idd_env(), private$idf_env(), ..., + .default = .default, .exact = FALSE ) - if (!nrow(l$object)) { - verbose_info("After deleting duplications, nothing to add.") - return(invisible()) - } + ld <- add_idf_object(private$idd_env(), private$idf_env(), + l$object, l$value, default = FALSE, unique = .unique, empty = .empty) - merge_idf_data(private$idf_env(), l, by_object = TRUE) + if (!length(ld$changed)) return(invisible()) # log - log_new_order(private$m_log, l$object$object_id) + log_new_order(private$m_log, ld$changed) log_unsaved(private$m_log) log_new_uuid(private$m_log) - idf_return_modified(self, private, l) + idf_update_idf_env(self, private, ld) + idf_return_matched(self, private, ld$changed) } # }}} # idf_update {{{ idf_update <- function (self, private, ..., .default = TRUE, .empty = FALSE) { - l <- update_idf_object(private$idd_env(), private$idf_env(), private$m_version, - ..., .default = .default, .empty = .empty + l <- expand_idf_dots_literal(private$idd_env(), private$idf_env(), ..., + .default = .default, .exact = TRUE ) - merge_idf_data(private$idf_env(), l, by_object = TRUE) + upd <- set_idf_object(private$idd_env(), private$idf_env(), + l$object, l$value, empty = .empty) # log - log_new_order(private$m_log, l$object$object_id) + log_add_order(private$m_log, c(upd$changed, upd$updated)) log_unsaved(private$m_log) log_new_uuid(private$m_log) - idf_return_modified(self, private, l) + idf_update_idf_env(self, private, upd) + idf_return_matched(self, private, upd$changed) } # }}} # idf_validate {{{ @@ -3235,8 +3280,10 @@ idf_to_string <- function (self, private, which = NULL, class = NULL, } # }}} # idf_to_table {{{ -idf_to_table <- function (self, private, which = NULL, class = NULL, string_value = TRUE, unit = FALSE, wide = FALSE, align = FALSE, all = FALSE, group_ext = c("none", "group", "index"), force = FALSE) { - get_idf_table(private$idd_env(), private$idf_env(), class, which, string_value, unit, wide, align, all, group_ext, force) +idf_to_table <- function (self, private, which = NULL, class = NULL, string_value = TRUE, unit = FALSE, wide = FALSE, align = FALSE, all = FALSE, group_ext = c("none", "group", "index"), force = FALSE, init = FALSE) { + get_idf_table(private$idd_env(), private$idf_env(), class = class, object = which, + string_value = string_value, unit = unit, wide = wide, align = align, + all = all, group_ext = group_ext, force = force, init = init) } # }}} # idf_save {{{ @@ -3244,12 +3291,7 @@ idf_save <- function (self, private, path = NULL, format = eplusr_option("save_f overwrite = FALSE, copy_external = TRUE) { if (is.null(path)) { if (is.null(private$m_path)) { - abort("error_not_local", - paste0( - "The Idf object is not created from local file. ", - "Please give the path to save." - ) - ) + abort("The Idf object is not created from local file. Please give the path to save.") } else { path <- private$m_path } @@ -3322,14 +3364,14 @@ idf_save_view <- function (self, private, filename, autoview = FALSE, autoclose if (autoview) { self$view() } else { - abort("error_no_geom_ready", "No geometry has been created yet. Please run '$view()' first.") + abort("No geometry has been created yet. Please run '$view()' first.") } } private$m_log$geometry$save_snapshot(filename, bring_to_front, axis) if (autoclose) { - rgl::rgl.set(._get_private(private$m_log$geometry)$m_log$id$device) + rgl::rgl.set(get_priv_env(private$m_log$geometry)$m_log$id$device) rgl::rgl.close() } @@ -3425,11 +3467,11 @@ idf_add_output_sqlite <- function (idf) { if (type != "SIMPLEANDTABULAR") { sql$set("SimpleAndTabular") verbose_info("Setting `Option Type` in ", - "`Output:SQLite` to from", surround(type), " to `SimpleAndTabular`.") + "`Output:SQLite` to from ", surround(type), " to `SimpleAndTabular`.") added <- TRUE } } else { - invisible(idf$add(Output_SQLite = list("SimpleAndTabular"))) + idf$add(Output_SQLite = list("SimpleAndTabular")) verbose_info("Adding an object in class `Output:SQLite` and setting its ", "`Option Type` to `SimpleAndTabular` in order to create SQLite output file.") added <- TRUE @@ -3446,14 +3488,14 @@ idf_add_output_vardict <- function (idf) { key <- toupper(dict$value()[[1]]) if (!key %chin% c("IDF", "REGULAR")) { dict$set("IDF") - verbose_info("Setting `Key Field` in ", - "`Output:VariableDictionary` to from", surround(key), " to `IDF`.") + verbose_info("Setting 'Key Field' in ", + "'Output:VariableDictionary' to from ", surround(key), " to 'IDF'.") added <- TRUE } } else { - invisible(idf$add(Output_VariableDictionary = list("IDF"))) - verbose_info("Adding an object in class `Output:VariableDictionary` and setting its ", - "`Key Field` to `IDF` in order to create RDD and MDD output file.") + with_silent(idf$add(Output_VariableDictionary = list("IDF"))) + verbose_info("Adding an object in class 'Output:VariableDictionary' and setting its ", + "'Key Field' to 'IDF' in order to create RDD and MDD output file.") added <- TRUE } added @@ -3615,18 +3657,11 @@ replace_objects_in_class <- function (self, private, class, value, unique_object } # disable unique object checking - if (exist && unique_object) { - ori <- eplusr_option("validate_level") - on.exit(eplusr_option(validate_level = ori), add = TRUE) - - chk <- level_checks(ori) - chk$unique_object <- FALSE - eplusr_option(validate_level = chk) - } + chk <- level_checks() + if (exist && unique_object) chk$unique_object <- FALSE # get new object data - l <- load_idf_object(private$idd_env(), private$idf_env(), version = private$m_version, - value, .unique = FALSE) + l <- expand_idf_dots_literal(private$idd_env(), private$idf_env(), value) # stop if not from the same class cls_in <- private$idd_env()$class$class_name[l$object$class_id] @@ -3639,35 +3674,35 @@ replace_objects_in_class <- function (self, private, class, value, unique_object } invld_cls <- cls_in[cls_in != class] - abort("error_invalid_input_object_class", - paste0( - "Input IdfObjects should from class `", class, "`. ", - " Invalid input class: ", collapse(invld_cls) - ) - ) + abort(paste0("Input IdfObjects should from class ", surround(class), ". ", + "Invalid input class: ", collapse(invld_cls) + )) } # if everything looks good, add new objects - merge_idf_data(private$idf_env(), l, by_object = TRUE) - log_new_order(private$m_log, l$object$object_id) + l <- add_idf_object(private$idd_env(), private$idf_env(), l$object, l$value, + default = TRUE, unique = FALSE, empty = FALSE, level = chk + ) + idf_update_idf_env(self, private, l) + log_new_order(private$m_log, l$changed) log_unsaved(private$m_log) log_new_uuid(private$m_log) # delete original objects if (exist) { - invisible(self$del(obj_main$object_id, .force = TRUE)) + with_silent(self$del(obj_main$object_id, .force = TRUE)) } # if a list of IdfObjects, use `$insert()` - } else if (is.list(value) && all(vlapply(value, is_idfobject))) { + } else if (checkmate::test_list(value, "IdfObject", any.missing = FALSE)) { # check if input is from the same model # get uuid if idf uuid_main <- private$m_log$uuid # get uuids of input - uuid_in <- vcapply(value, function (obj) .subset2(.subset2(._get_private(obj), "log_env")(), "uuid")) + uuid_in <- vcapply(value, function (obj) .subset2(.subset2(get_priv_env(obj), "log_env")(), "uuid")) # get id of input - obj_id_in <- viapply(value, function (obj) .subset2(._get_private(obj), "m_object_id")) + obj_id_in <- viapply(value, function (obj) .subset2(get_priv_env(obj), "m_object_id")) # ignore ones that is from the same idf if (exist) { @@ -3683,20 +3718,14 @@ replace_objects_in_class <- function (self, private, class, value, unique_object if (all(uuid_main == uuid_in) && same_num && all(same_id)) return(invisible(self)) # stop if not from the same class - cls_id_in <- viapply(value, function (obj) .subset2(._get_private(obj), "m_class_id")) + cls_id_in <- viapply(value, function (obj) .subset2(get_priv_env(obj), "m_class_id")) cls_in <- private$idd_env()$class$class_name[cls_id_in] if (any(cls_in != class)) { invld_cls <- vcapply(value[cls_in != class], function (obj) .subset2(obj, "class_name")()) msg <- paste0(" #", which(cls_in != class), "| --> Class: ", surround(invld_cls), collapse = "\n" ) - abort("error_invalid_input_object_class", - paste0( - "Input IdfObjects should from class `", class, "`. ", - " Invalid input:\n", msg - - ) - ) + abort(paste0("Input IdfObjects should from class '", class, "'. Invalid input:\n", msg)) } # ignore same objects and insert new ones @@ -3709,12 +3738,9 @@ replace_objects_in_class <- function (self, private, class, value, unique_object } else { mes <- if (unique_object) "an IdfObject" else "a list of IdfObjects" - abort("error_invalid_active_binding_value", - paste0( - "Value should be ", mes, ", a character vector or a data.frame. ", - "Input class: ", surround(class(value)[[1]]), "." - ) - ) + abort(paste0("Value should be ", mes, ", a character vector or a data.frame. ", + "Input class: ", surround(class(value)[[1]]), "." + )) } invisible(self) @@ -3726,7 +3752,7 @@ replace_objects_in_class <- function (self, private, class, value, unique_object `$.Idf` <- function (x, i) { if (i %chin% ls(x)) return(NextMethod()) - private <- ._get_private(x) + private <- get_priv_env(x) cls_id <- chmatch(i, private$idd_env()$class$class_name_us) if (is.na(cls_id)) cls_id <- chmatch(i, private$idd_env()$class$class_name) @@ -3749,9 +3775,11 @@ replace_objects_in_class <- function (self, private, class, value, unique_object #' @export # [[.Idf {{{ `[[.Idf` <- function (x, i) { + if (!checkmate::test_string(i)) return(NextMethod()) + if (i %chin% ls(x)) return(NextMethod()) - private <- ._get_private(x) + private <- get_priv_env(x) cls_id <- chmatch(i, private$idd_env()$class$class_name) @@ -3773,10 +3801,11 @@ replace_objects_in_class <- function (self, private, class, value, unique_object #' @export # $<-.Idf {{{ `$<-.Idf` <- function (x, name, value) { - if (name %chin% ls(x)) return(NextMethod()) + # all field names start with a capital letter + if (!substr(name, 1, 1) %chin% LETTERS && name %chin% ls(x)) return(NextMethod()) - self <- ._get_self(x) - private <- ._get_private(x) + self <- get_self_env(x) + private <- get_priv_env(x) # match both normal and underscore class names cls_id <- chmatch(name, private$idd_env()$class$class_name) @@ -3804,29 +3833,28 @@ replace_objects_in_class <- function (self, private, class, value, unique_object #' @export # [[<-.Idf {{{ `[[<-.Idf` <- function (x, name, value) { - if (length(name) != 1L) return(NextMethod()) + if (!checkmate::test_string(name)) return(NextMethod()) - if (name %chin% ls(x)) { - NextMethod() - } else { - self <- ._get_self(x) - private <- ._get_private(x) + # all field names start with a capital letter + if (!substr(name, 1, 1) %chin% LETTERS && name %chin% ls(x)) return(NextMethod()) - # match only normal class names - cls_id <- chmatch(name, private$idd_env()$class$class_name) + self <- get_self_env(x) + private <- get_priv_env(x) - # skip if not a valid IDD class name - # imitate error message of a locked environment - if (is.na(cls_id)) stop("cannot add bindings to a locked environment") + # match only normal class names + cls_id <- chmatch(name, private$idd_env()$class$class_name) - cls_nm <- private$idd_env()$class$class_name[cls_id] - uni <- private$idd_env()$class$unique_object[cls_id] + # skip if not a valid IDD class name + # imitate error message of a locked environment + if (is.na(cls_id)) stop("cannot add bindings to a locked environment") - replace_objects_in_class(self, private, cls_nm, value, uni) - # if not an existing IDF class name, add active bindings - if (!cls_id %in% private$idf_env()$object$class_id) { - add_idf_class_bindings(x, cls_id) - } + cls_nm <- private$idd_env()$class$class_name[cls_id] + uni <- private$idd_env()$class$unique_object[cls_id] + + replace_objects_in_class(self, private, cls_nm, value, uni) + # if not an existing IDF class name, add active bindings + if (!cls_id %in% private$idf_env()$object$class_id) { + add_idf_class_bindings(x, cls_id) } invisible(x) @@ -3853,7 +3881,7 @@ str.Idf <- function (object, zoom = "class", ...) { # ==.Idf {{{ `==.Idf` <- function (e1, e2) { if (!is_idf(e2)) return(FALSE) - identical(._get_private(e1)$m_log$uuid, ._get_private(e2)$m_log$uuid) + identical(get_priv_env(e1)$m_log$uuid, get_priv_env(e2)$m_log$uuid) } # }}} diff --git a/R/idf_object.R b/R/idfobj.R similarity index 95% rename from R/idf_object.R rename to R/idfobj.R index 9c67a92a1..3e6670b31 100644 --- a/R/idf_object.R +++ b/R/idfobj.R @@ -51,18 +51,18 @@ IdfObject <- R6::R6Class(classname = "IdfObject", lock_objects = FALSE, #' mat <- idf$Material[["C5 - 4 IN HW CONCRETE"]] #' } #' + #' @importFrom checkmate assert_count initialize = function (object, class = NULL, parent) { if (missing(parent) || !is_idf(parent)) { - abort("error_idfobject_missing_parent", - paste("IdfObject can only be created based a parent Idf object.", - "Please give `parent`, which should be an Idf object.") + abort(paste("IdfObject can only be created based a parent Idf object.", + "Please give 'parent', which should be an Idf object.") ) } else { private$m_parent <- parent } - assert(is_count(object)) + object <- assert_count(object, positive = TRUE, coerce = TRUE) if (!is.null(class)) { - assert(is_count(class)) + class <- assert_count(class, positive = TRUE, coerce = TRUE) } else { class <- get_idf_object(private$idd_env(), private$idf_env(), NULL, object)$class_id } @@ -1401,15 +1401,15 @@ IdfObject <- R6::R6Class(classname = "IdfObject", lock_objects = FALSE, # }}} idf_env = function () { - ._get_private(private$m_parent)$m_idf_env + get_priv_env(private$m_parent)$m_idf_env }, idd_env = function () { - ._get_private(private$m_parent)$idd_env() + get_priv_env(private$m_parent)$idd_env() }, log_env = function () { - ._get_private(private$m_parent)$m_log + get_priv_env(private$m_parent)$m_log } ) ) @@ -1462,66 +1462,30 @@ IdfObject <- R6::R6Class(classname = "IdfObject", lock_objects = FALSE, #' } #' @export # idf_object {{{ +#' @importFrom checkmate assert_string idf_object <- function (parent, object = NULL, class = NULL) { if (missing(parent) || !is_idf(parent)) { - abort("error_idfobject_missing_parent", - paste("IdfObject can only be created based a parent Idf object.", - "Please give `parent`, which should be an Idf object.") + abort(paste("IdfObject can only be created based a parent Idf object.", + "Please give `parent`, which should be an Idf object.") ) } - idd_env <- ._get_private(parent)$idd_env() - idf_env <- ._get_private(parent)$idf_env() + idd_env <- get_priv_env(parent)$idd_env() + idf_env <- get_priv_env(parent)$idf_env() # add an empty object if (is.null(object)) { - assert(!is.null(class), - msg = paste0("`class` must be given when `object` is not.") - ) - - assert(is_string(class)) - - # add field property - prop <- c("units", "ip_units", "default_chr", "default_num", "is_name", - "required_field", "src_enum", "type_enum", "extensible_group" - ) - - cls <- get_idd_class(idd_env, class) - fld <- get_idd_field(idd_env, cls$class_id, property = prop) - - obj <- set(cls, NULL, c("object_id", "object_name", "object_name_lower", "comment"), - list(new_id(idf_env$object, "object_id", 1L), NA_character_, NA_character_, list()) - ) - - dot <- data.table(rleid = 1L, object_rleid = 1L, dep = 1, dot = class, dot_nm = NA_character_) - - assert_can_do(idd_env, idf_env, dot, obj, action = "add") - - val <- set(fld, NULL, c("value_id", "value_chr", "value_num", "object_id", "defaulted"), - list(new_id(idf_env$value, "value_id", nrow(fld)), - NA_character_, NA_real_, obj$object_id, - TRUE - ) - ) - - # assign default values - val <- assign_default_value(idd_env, idf_env, val) + if (is.null(class)) stop("'class' must be given when 'object' is not") - # validate - assert_valid(idd_env, idf_env, obj, val, action = "add") + assert_string(class) - idf_env$object <- append_dt(idf_env$object, obj) - idf_env$value <- append_dt(idf_env$value, val) - - object <- obj$object_id - class <- obj$class_id - - # validate - assert_valid(idd_env, idf_env, obj, val, action = "add") + lst <- list(list()) + names(lst) <- class + obj <- parent$add(lst)[[1L]] verbose_info( - paste0("New empty object [ID:", obj$object_id, "] in class ", - surround(obj$class_name), " created." + paste0("New empty object [ID:", obj$id(), "] in class ", + surround(obj$class_name()), " created." ) ) } else { @@ -1529,10 +1493,9 @@ idf_object <- function (parent, object = NULL, class = NULL) { object <- obj$object_id class <- obj$class_id + obj <- IdfObject$new(object, class, parent) } - obj <- IdfObject$new(object, class, parent) - add_idfobj_field_bindings(obj) } # }}} @@ -1566,8 +1529,9 @@ add_idfobj_field_bindings <- function (obj, field_index = NULL, update = FALSE) if (missing(value)) { self$value(field)[[1L]] } else { + lst <- list(value) names(value) <- field - self$set(c(value)) + do.call(self$set, lst) invisible(self) } }) @@ -1617,16 +1581,17 @@ idfobj_class_name <- function (self, private) { # }}} # idfobj_definition {{{ idfobj_definition <- function (self, private) { - IddObject$new(private$m_class_id, ._get_private(private$m_parent)$m_idd) + IddObject$new(private$m_class_id, get_priv_env(private$m_parent)$m_idd) } # }}} # idfobj_comment {{{ +#' @importFrom checkmate assert_character idfobj_comment <- function (self, private, comment, append = TRUE, width = 0L) { if (missing(comment)) { return(private$idf_env()$object[J(private$m_object_id), on = "object_id"]$comment[[1L]]) } - assert(is.atomic(comment), msg = "`comment` should be NULL or a character vector.") + assert_character(comment, null.ok = TRUE) obj <- set_idfobj_comment(private$idd_env(), private$idf_env(), private$m_object_id, comment = comment, append = append, width = width ) @@ -1636,7 +1601,7 @@ idfobj_comment <- function (self, private, comment, append = TRUE, width = 0L) { log_new_uuid(private$log_env()) # update object in parent - merge_idfobj_data(private$idf_env(), obj, "object") + private$idf_env()[obj, on = "object_id", `:=`(comment = i.comment)] self } @@ -1648,15 +1613,11 @@ idfobj_value <- function (self, private, which = NULL, all = FALSE, simplify = F # }}} # idfobj_set {{{ idfobj_set <- function (self, private, ..., .default = TRUE, .empty = FALSE) { - set <- set_idfobj_value(private$idd_env(), private$idf_env(), - private$m_object_id, ..., .default = .default, .empty = .empty + lst <- list(list(...)) + names(lst) <- paste0("..", private$m_object_id) + idf_set(get_self_env(private$m_parent), get_priv_env(private$m_parent), + lst, .default = .default, .empty = .empty, .env = environment() ) - merge_idf_data(private$idf_env(), set, by_object = TRUE) - - # log - log_add_order(private$log_env(), set$object$object_id) - log_unsaved(private$log_env()) - log_new_uuid(private$log_env()) self } @@ -1710,13 +1671,13 @@ idfobj_ref_to_object <- function (self, private, which = NULL, object = NULL, )[!is.na(src_value_id)] if (!nrow(rel)) { - if (eplusr_option("verbose_info")) { + if (in_verbose()) { msg <- paste("Target object does not refer to any objects") if (is.null(object) && is.null(class) && is.null(group)) { verbose_info(msg, ".") } else { - verbose_info(msg, "specifed.") + verbose_info(msg, " specifed.") } } return(invisible()) @@ -1754,7 +1715,7 @@ idfobj_ref_by_object <- function (self, private, which = NULL, object = NULL, if (is.null(object) && is.null(class) && is.null(group)) { verbose_info(msg, ".") } else { - verbose_info(msg, "specifed.") + verbose_info(msg, " specifed.") } } return(invisible()) @@ -2000,10 +1961,10 @@ print.IdfObject <- function (x, comment = TRUE, auto_sep = TRUE, brief = FALSE, #' @export # $.IdfObject {{{ '$.IdfObject' <- function (x, name) { - if (name %in% ls(x)) return(NextMethod()) + if (name %chin% ls(x)) return(NextMethod()) - self <- ._get_self(x) - private <- ._get_private(x) + self <- get_self_env(x) + private <- get_priv_env(x) # In order to make sure `idfobj$nAmE` is not acceptable fld_nm <- private$idd_env()$field[J(private$m_class_id), on = "class_id", field_name] @@ -2015,7 +1976,7 @@ print.IdfObject <- function (x, comment = TRUE, auto_sep = TRUE, brief = FALSE, get_idfobj_value(private$idd_env(), private$idf_env(), private$m_object_id, which = fld_idx )[[1L]], - error_bad_field_name = function (e) NextMethod() + eplusr_error_invalid_field_name = function (e) NextMethod() ) } else { NextMethod() @@ -2028,17 +1989,17 @@ print.IdfObject <- function (x, comment = TRUE, auto_sep = TRUE, brief = FALSE, '[[.IdfObject' <- function(x, i) { if (length(i) != 1L) return(NextMethod()) - if (i %in% ls(x)) { + if (as.character(i) %chin% ls(x)) { NextMethod() } else { - self <- ._get_self(x) - private <- ._get_private(x) + self <- get_self_env(x) + private <- get_priv_env(x) # In order to make sure `idfobj$nAmE` is not acceptable - if (is_integer(i) || i %chin% private$idd_env()$field[J(private$m_class_id), on = "class_id", field_name]) { + if (checkmate::test_count(i, positive = TRUE) || i %chin% private$idd_env()$field[J(private$m_class_id), on = "class_id", field_name]) { tryCatch( get_idfobj_value(private$idd_env(), private$idf_env(), private$m_object_id, which = i)[[1L]], - error_bad_field_name = function (e) NextMethod() + eplusr_error_invalid_field_name = function (e) NextMethod() ) } else { NextMethod() @@ -2049,13 +2010,13 @@ print.IdfObject <- function (x, comment = TRUE, auto_sep = TRUE, brief = FALSE, #' @export # $<-.IdfObject {{{ +#' @importFrom checkmate assert_scalar `$<-.IdfObject` <- function (x, name, value) { - if (name %in% ls(x)) return(NextMethod()) - - self <- ._get_self(x) - private <- ._get_private(x) + # all field names start with a capital letter + if (!substr(name, 1, 1) %chin% LETTERS && name %chin% ls(x)) return(NextMethod()) - assert(is_scalar(value)) + self <- get_self_env(x) + private <- get_priv_env(x) # In order to make sure `idfobj$nAmE <- "a"` is not acceptable fld_nm <- private$idd_env()$field[J(private$m_class_id), on = "class_id", field_name] @@ -2063,8 +2024,10 @@ print.IdfObject <- function (x, comment = TRUE, auto_sep = TRUE, brief = FALSE, if (is.na(fld_idx)) fld_idx <- chmatch(name, underscore_name(fld_nm)) if (!is.na(fld_idx)) { + if (is.null(value)) value <- list(NULL) names(value) <- name - tryCatch(.subset2(x, "set")(c(value)), error_bad_field_name = function (e) NextMethod()) + tryCatch(do.call(.subset2(x, "set"), c(as.list(value), .default = FALSE, .empty = FALSE)), + eplusr_error_invalid_field_name = function (e) NextMethod()) # add bindings add_idfobj_field_bindings(x, fld_idx) @@ -2081,22 +2044,25 @@ print.IdfObject <- function (x, comment = TRUE, auto_sep = TRUE, brief = FALSE, '[[<-.IdfObject' <- function(x, i, value) { if (length(i) != 1) return(NextMethod()) - if (i %in% ls(x)) return(NextMethod()) + if (!substr(as.character(i), 1, 1) %chin% LETTERS && as.character(i) %chin% ls(x)) return(NextMethod()) - self <- ._get_self(x) - private <- ._get_private(x) + self <- get_self_env(x) + private <- get_priv_env(x) # In order to make sure only standard field name is not acceptable fld_nm <- private$idd_env()$field[J(private$m_class_id), on = "class_id", field_name] - if (is_integer(i)) { + if (checkmate::test_count(i, positive = TRUE)) { fld_idx <- i - i <- fld_nm[[i]] + nm <- paste0("..", i) } else { fld_idx <- chmatch(i, fld_nm) + nm <- i } if (!is.na(fld_idx)) { - names(value) <- i - tryCatch(.subset2(x, "set")(c(value)), error_bad_field_name = function (e) NextMethod()) + if (is.null(value)) value <- list(NULL) + names(value) <- nm + tryCatch(do.call(.subset2(x, "set"), c(as.list(value), .default = FALSE, .empty = FALSE)), + eplusr_error_invalid_field_name = function (e) NextMethod()) # add bindings add_idfobj_field_bindings(x, fld_idx) @@ -2113,10 +2079,10 @@ print.IdfObject <- function (x, comment = TRUE, auto_sep = TRUE, brief = FALSE, `==.IdfObject` <- function (e1, e2) { if (!is_idfobject(e2)) return(FALSE) identical( - ._get_private(._get_private(e1)$m_parent)$m_log$uuid, - ._get_private(._get_private(e2)$m_parent)$m_log$uuid + get_priv_env(get_priv_env(e1)$m_parent)$m_log$uuid, + get_priv_env(get_priv_env(e2)$m_parent)$m_log$uuid ) && - identical(._get_private(e1)$m_object_id, ._get_private(e2)$m_object_id) + identical(get_priv_env(e1)$m_object_id, get_priv_env(e2)$m_object_id) } # }}} diff --git a/R/impl-idd.R b/R/impl-idd.R index d4713aadd..fd1ee5ad2 100644 --- a/R/impl-idd.R +++ b/R/impl-idd.R @@ -55,7 +55,7 @@ get_idd_class <- function (idd_env, class = NULL, property = NULL, underscore = if (is.null(class)) { # very odd way to subset columns but is way faster that others # ref: https://github.com/Rdatatable/data.table/issues/3477 - if (is.null(property)) return(setDT(unclass(idd_env$class)[cols])) + if (is.null(property)) return(fast_subset(idd_env$class, cols)) if ("group_name" %chin% property) { property <- setdiff(property, "group_name") @@ -66,7 +66,7 @@ get_idd_class <- function (idd_env, class = NULL, property = NULL, underscore = # very odd way to subset columns but is way faster # ref: https://github.com/Rdatatable/data.table/issues/3477 - res <- setDT(unclass(idd_env$class)[unique(c(cols, property))]) + res <- fast_subset(idd_env$class, unique(c(cols, property))) if (add_group) add_joined_cols(idd_env$group, res, "group_id", "group_name") @@ -80,9 +80,7 @@ get_idd_class <- function (idd_env, class = NULL, property = NULL, underscore = add_joined_cols(idd_env$group, res, "group_id", "group_name") } - # very odd way to subset columns but is way faster - # ref: https://github.com/Rdatatable/data.table/issues/3477 - setDT(unclass(res)[c("rleid", unique(c(cols, property)))]) + fast_subset(res, c("rleid", unique(c(cols, property)))) } # }}} # get_idd_class_field_num {{{ @@ -151,6 +149,18 @@ get_idd_class_field_num <- function (dt_class, num = NULL) { dt_class } # }}} +# get_idd_class_unique {{{ +get_idd_class_unique <- function (idd_env) { + idd_env$class[J(TRUE), on = "unique_object", nomatch = NULL] +} +# }}} +# get_class_component_name {{{ +get_class_component_name <- function (class) { + nm <- stri_extract_first_regex(class, "^.+?(?=:)") + nm[is.na(nm)] <- class[is.na(nm)] + nm +} +# }}} # FIELD # get_idd_field {{{ @@ -159,16 +169,11 @@ get_idd_class_field_num <- function (dt_class, num = NULL) { #' @param idd_env An environment or list contains IDD tables including class, #' field, and reference. #' @param class An integer vector of valid class indexes or a character vector -#' of valid class names or a data.table that contains column `class_id` -#' and `rleid`. If a data.table that contains a column `object_id`, that -#' column will be preserved. +#' of valid class names. #' @param field An integer vector of valid field indexes or a character #' vector of valid field names (can be in in underscore style). `class` #' and `field` should have the same length. -#' @param property A character vector of column names in field table to return. If -#' `NULL`, all columns from IDD field table will be returned, plus column -#' `rleid`, `object_id` (if applicable) and `matched_rleid` (if -#' `complete` is `TRUE`). +#' @param property A character vector of column names in field table to return. #' @param underscore If `TRUE`, input class name and field names will be #' converted into underscore style name first and column `class_name_us` #' and `field_name_us` will be used for matching. @@ -215,7 +220,7 @@ get_idd_field_in_class <- function (idd_env, class, all = FALSE, underscore = TR # get_idd_field_from_which {{{ get_idd_field_from_which <- function (idd_env, class, field, underscore = TRUE, no_ext = FALSE, complete = FALSE, all = FALSE) { - assert_valid_type(field, "field") + assert_valid_type(field, "Field Index|Name") # class properties used for min required field num calculation col_prop <- c("num_fields", "min_fields", "last_required", "num_extensible", @@ -816,6 +821,9 @@ field_default_to_unit <- function (idd_env, dt_field, from, to) { } else { value_id <- NULL } + if (has_names(dt_field, "value_chr")) { + setnames(dt_field, c("value_chr", "value_num"), paste0(c("value_chr", "value_num"), "-backup")) + } set(dt_field, NULL, "value_id", seq_along(dt_field$field_id)) cols_add <- NULL @@ -829,6 +837,11 @@ field_default_to_unit <- function (idd_env, dt_field, from, to) { set(dt_field, NULL, "value_id", value_id) setnames(dt_field, c("value_chr", "value_num"), c("default_chr", "default_num")) + + if (has_names(dt_field, "value_chr-backup")) { + setnames(dt_field, paste0(c("value_chr", "value_num"), "-backup"), c("value_chr", "value_num")) + } + dt_field } # }}} @@ -1038,7 +1051,7 @@ get_input_class_data <- function (idd_env, class, num = NULL) { # TABLE # get_idd_table {{{ get_idd_table <- function (idd_env, class, all = FALSE) { - assert_valid_type(class, "class") + assert_valid_type(class, "Class Index|Name") fld <- get_idd_field(idd_env, class, all = all)[ , .SD, .SDcols = c("class_name", "field_index", "field_name") ] @@ -1052,7 +1065,7 @@ get_idd_table <- function (idd_env, class, all = FALSE) { # STRING # get_idd_string {{{ get_idd_string <- function (idd_env, class, leading = 4L, sep_at = 29L, sep_each = 0L, all = FALSE) { - assert_valid_type(class, "class") + assert_valid_type(class, "Class Index|Name") assert_count(sep_each) fld <- get_idd_field(idd_env, class, property = c("units", "ip_units"), all = all) diff --git a/R/impl-idf.R b/R/impl-idf.R index daefd008b..67de484a1 100644 --- a/R/impl-idf.R +++ b/R/impl-idf.R @@ -141,6 +141,7 @@ get_idf_object <- function (idd_env, idf_env, class = NULL, object = NULL, prope # }}} } + setcolorder(obj, c("rleid", "class_id", "class_name", "object_id", "object_name", "object_name_lower", "comment")) obj } # }}} @@ -205,6 +206,28 @@ get_idf_object_num <- function (idd_env, idf_env, class = NULL) { } # }}} # get_object_info {{{ +#' Format object information string +#' +#' @param dt_object A [data.table::data.table()] of object data +#' @param component A character vector specifying what information to be +#' formatted. Should be a subset of `"id"`, `"name"` and `"class"`. +#' Defaults are all of them. +#' @param by_class If `TRUE`, multiple objects in the same class will be +#' concatenated. Default: `FALSE`. +#' @param numbered If `TRUE`, a index number will be prepended. If `rleid` +#' column exists in `dt_object`, its values will be used as the index +#' numbers. +#' @param collapse A single string used to collapse the results into a single +#' string. Default: `NULL`. +#' @param prefix A character vector used to add at the beginning of object +#' information. Default: `NULL`. +#' @param name_prefix If `TRUE`, Default: `TRUE`. +#' +#' @return A character vector of the same length as the row number of input +#' `dt_object` if `collapse` is `NULL`. Otherwise a single string. +#' +#' @keywords internal +#' @export get_object_info <- function (dt_object, component = c("id", "name", "class"), by_class = FALSE, numbered = TRUE, collapse = NULL, prefix = NULL, name_prefix = TRUE) { @@ -537,6 +560,50 @@ make_idf_object_name <- function (idd_env, idf_env, dt_object, use_old = TRUE, setcolorder(dt, setdiff(names(dt), c("new_object_name", "new_object_name_lower"))) } # }}} +# get_idf_object_multi_scope {{{ +get_idf_object_multi_scope <- function (idd_env, idf_env, object = NULL, class = NULL, group = NULL) { + obj <- data.table() + + if (is.null(object) && is.null(class) && is.null(group)) { + return(setcolorder(get_idf_object(idd_env, idf_env), + c("rleid", "class_id", "class_name", "object_id", "object_name", "object_name_lower", "comment") + )) + } + + if (!is.null(object)) { + obj <- get_idf_object(idd_env, idf_env, object = object, ignore_case = TRUE) + } + if (!is.null(class)) { + obj <- rbindlist(list(obj, get_idf_object(idd_env, idf_env, class)), use.names = TRUE) + } + if (!is.null(group)) { + assert_valid_type(group, "Group Name", type = "name") + + add_class_property(idd_env, idf_env$object, "group_name") + + grp_in <- recognize_input(group, "group") + obj_grp <- join_from_input(idf_env$object, grp_in, "object_id") + + # clean + set(idf_env$object, NULL, "group_name", NULL) + + # add class name to make sure results have same columns as 'get_idf_object()' + set(obj_grp, NULL, "group_name", NULL) + add_class_property(idd_env, obj_grp, "class_name") + + obj <- rbindlist(list(obj, obj_grp), use.names = TRUE) + } + + obj <- unique(obj, by = "object_id") + + # reset rleid + add_rleid(obj) + + setcolorder(obj, c("rleid", "class_id", "class_name", "object_id", "object_name", "object_name_lower", "comment")) + + obj +} +# }}} # VALUE # get_idf_value {{{ @@ -587,6 +654,9 @@ get_idf_value <- function (idd_env, idf_env, class = NULL, object = NULL, field # if just want to get the value, no special treatment is required if (!(all || complete || align)) { add_joined_cols(idd_env$field, val, "field_id", c("field_index", "field_name", property)) + setcolorder(val, c("rleid", "class_id", "class_name", "object_id", + "object_name", "field_id", "field_index", "field_name", "value_id", + "value_chr", "value_num")) return(val) } @@ -682,7 +752,10 @@ get_idf_value <- function (idd_env, idf_env, class = NULL, object = NULL, field val <- idf_env$value[fld, on = c("object_id", "field_id"), nomatch = nom] } - val[is.na(value_id), value_id := -.I] + val[J(NA_integer_), on = "value_id", value_id := -.I] + setcolorder(val, c("rleid", "class_id", "class_name", "object_id", + "object_name", "field_id", "field_index", "field_name", "value_id", + "value_chr", "value_num")) val } @@ -784,7 +857,7 @@ expand_idf_dots_name <- function (idd_env, idf_env, ..., .keep_name = TRUE, .pro # see https://github.com/mllg/checkmate/issues/146 # For list, only NULL is treated as "missing" value - assert_list(l, c("character", "integerish"), any.missing = FALSE, all.missing = FALSE, .var.name = "Input") + assert_list(l, c("character", "integerish"), any.missing = FALSE, all.missing = FALSE, .var.name = "Input", min.len = 1L) qassertr(l, "V", "Input") is_nm <- vlapply(l, is.character, use.names = FALSE) @@ -842,6 +915,8 @@ expand_idf_dots_name <- function (idd_env, idf_env, ..., .keep_name = TRUE, .pro set(obj, NULL, "rleid", rleid(obj$input_rleid, obj$object_rleid)) set(obj, NULL, c("input_rleid", "object_rleid"), NULL) setcolorder(obj, "rleid") + if (!is.null(.property)) setcolorder(obj, setdiff(names(obj), .property)) + obj } # }}} # parse_dots_value {{{ @@ -853,7 +928,7 @@ parse_dots_value <- function (..., .scalar = TRUE, .pair = FALSE, l <- eval(substitute(alist(...))) rules <- if (.scalar) "V1" else "V" - assert_list(l, any.missing = FALSE, all.missing = FALSE, .var.name = "Input") + assert_list(l, any.missing = FALSE, all.missing = FALSE, .var.name = "Input", min.len = 1L) nm <- name <- names2(l) ll <- vector("list", length(l)) @@ -922,6 +997,15 @@ parse_dots_value <- function (..., .scalar = TRUE, .pair = FALSE, abort("Assertion on 'Input' failed: Must be named.", "dots_no_name") } val <- li + + # for '..ID = list()' + name <- nm[[i]] + if (stri_detect_regex(name, "^\\.\\.\\d+$")) { + id <- stri_sub(name, 3L) + storage.mode(id) <- "integer" + set(dt_in, i, "id", list(id)) + set(dt_in, i, "name", list(NA_character_)) + } # if `-`, `{`, `(` and other special function calls, len will be 2 } else { evaluated <- FALSE @@ -2012,7 +2096,7 @@ expand_idf_dots_literal <- function (idd_env, idf_env, ..., .default = TRUE, .ex l <- list(...) ver <- standardize_ver(get_idf_value(idd_env, idf_env, "Version")$value_chr) - assert_list(l, c("character", "data.frame"), .var.name = "Input") + assert_list(l, c("character", "data.frame"), .var.name = "Input", min.len = 1L) is_chr <- vlapply(l, is.character) @@ -2123,6 +2207,11 @@ expand_idf_dots_literal <- function (idd_env, idf_env, ..., .default = TRUE, .ex set(obj_chr, NULL, "object_id", obj_chr_match$object_id) add_joined_cols(obj_chr, val_chr, c("object_id" = "input_object_id"), "object_id") set(obj_chr, NULL, "input_object_id", NULL) + + # update value id + set(val_chr, NULL, "value_id", NA_integer_) + val_chr[idf_env$value, on = c("object_id", "field_id"), value_id := i.value_id] + val_chr[J(NA_integer_), on = "value_id", value_id := -.I] } # }}} @@ -2293,6 +2382,7 @@ expand_idf_dots_literal <- function (idd_env, idf_env, ..., .default = TRUE, .ex value_type = i.value_type, object_rleid = i.object_rleid ) ] + setnafill(val_dt, type = "locf", cols = c("rleid", "object_id", "object_rleid", "value_type")) # if value column is a character vector, need to reset values since # all of them are coerced regardless of field types val_dt[value_type == 1L & type_enum > IDDFIELD_TYPE$real, value_num := NA_real_] @@ -2348,6 +2438,8 @@ expand_idf_dots_literal <- function (idd_env, idf_env, ..., .default = TRUE, .ex #' @param pattern A single string of regular expression used to match field #' values #' +#' @param class A character vector specifying the target class names +#' #' @param pattern,ignore.case,perl,fixed,useBytes All of them are #' directly passed to [base::grepl][base::grep()] and #' [base::gsub][base::grep()] with the same default values. @@ -2377,7 +2469,7 @@ expand_idf_regex <- function (idd_env, idf_env, pattern, replacement = NULL, if (!nrow(val)) { obj <- get_idf_object(idd_env, idf_env, 1L)[0L] } else { - obj <- get_idf_object(idd_env, idf_env, object = val[, by = "rleid", object_id]$object_id) + obj <- get_idf_object(idd_env, idf_env, object = unique(val[, by = "rleid", object_id]$object_id)) } if (!is.null(replacement)) { @@ -2413,14 +2505,6 @@ assert_valid <- function (validity, action) { } # }}} -# get_class_component_name {{{ -get_class_component_name <- function (class) { - nm <- stri_extract_first_regex(class, "^.+?(?=:)") - nm[is.na(nm)] <- class[is.na(nm)] - nm -} -# }}} - # OBJECT MUNIPULATION # dup_idf_object {{{ #' Duplicate existing objects @@ -2430,11 +2514,14 @@ get_class_component_name <- function (class) { #' @param idf_env An environment or list contains IDF tables including object, #' value, and reference. #' @param dt_object A [data.table::data.table()] that contains object data. -#' Usually created using [expand_idf_dots_value()]. #' @param level Validate level. Default: `eplusr_option("validate_level")`. #' -#' @return The duplicated object data in a named list of 3 -#' [data.table::data.table()]s, i.e. `object`, `value` and `reference`. +#' @return The modified [Idf] data in a named list of 5 elements, i.e. `object`, +#' `value`, `reference`, `changed` and `updated`. First 3 elements are +#' [data.table::data.table()]s containing the actual updated [Idf] data while +#' `changed` and `updated` are integer vectors containing IDs of objects that +#' have been directly changed and indirectly updated due to references, +#' respectively. #' #' @keywords internal #' @export @@ -2468,7 +2555,7 @@ dup_idf_object <- function (idd_env, idf_env, dt_object, level = eplusr_option(" id_obj <- new_id(idf_env$object, "object_id", nrow(obj)) # logging - if (in_verbose() && any(auto <- is.na(dt_object$new_object_name))) { + if (in_verbose() && any(auto <- dt_object$has_name & is.na(dt_object$new_object_name))) { auto <- set(copy(obj), NULL, "object_id", id_obj)[auto] id <- get_object_info(auto, c("id", "class")) name <- get_object_info(auto, "name", prefix = " --> New ", numbered = FALSE) @@ -2478,15 +2565,18 @@ dup_idf_object <- function (idd_env, idf_env, dt_object, level = eplusr_option(" ) } + # assign new rleid + obj <- add_rleid(obj) + # extract value table val <- get_idf_value(idd_env, idf_env, object = obj$object_id, property = "is_name") - - # assign new object id and value id + # assign new id obj <- assign_new_id(idf_env, obj, "object") add_joined_cols(obj, val, "rleid", "object_id") # assign new object name - val[obj, on = c("object_id", is_name = "has_name"), value_chr := i.object_name] + val[obj, on = "object_id", object_name := i.object_name] + val[obj[J(TRUE), on = "has_name", nomatch = NULL], on = c("object_id", is_name = "has_name"), value_chr := i.object_name] # value reference # extract value reference @@ -2498,7 +2588,7 @@ dup_idf_object <- function (idd_env, idf_env, dt_object, level = eplusr_option(" val[obj, on = "object_id", new_object_id := i.new_object_id] set(val, NULL, "new_value_id", new_id(idf_env$value, "value_id", nrow(val))) # update ids in ref - ref[val, on = c("object_id", "value_id"), `:=`(object_id = i.new_object_id, value_id = i.new_value_id)] + if (nrow(ref)) ref[val, on = c("object_id", "value_id"), `:=`(object_id = i.new_object_id, value_id = i.new_value_id)] # remove original ids set(obj, NULL, "object_id", NULL) @@ -2515,29 +2605,23 @@ dup_idf_object <- function (idd_env, idf_env, dt_object, level = eplusr_option(" add_field_property(idd_env, idf_env$value, "type_enum") src <- get_value_reference_map(idd_env, src_val, idf_env$value, all = FALSE)[ !J(NA_integer_), on = "value_id"] - on.exit(set(idf_env$value, NULL, "type_enum", NULL), add = TRUE) + set(idf_env$value, NULL, "type_enum", NULL) ref <- rbindlist(list(ref, src)) } - set(obj, NULL, "has_name", NULL) - set(val, NULL, c("src_enum", "is_name"), NULL) - setcolorder(obj, c("rleid", "class_id", "class_name", "object_id", "object_name", "object_name_lower", "comment")) - setcolorder(val, c("rleid", "class_id", "class_name", "object_id", "object_name", "field_id", "field_index", "field_name", "value_id", "value_chr")) - - list(object = obj, value = val, reference = ref) + list(object = append_dt(idf_env$object, obj), + value = append_dt(idf_env$value, val), + reference = append_dt(idf_env$reference, ref), + changed = obj$object_id, + updated = integer() + ) } # }}} # add_idf_object {{{ #' Add new objects #' -#' @param idd_env An environment or list contains IDD tables including class, -#' field, and reference. -#' @param idf_env An environment or list contains IDF tables including object, -#' value, and reference. -#' @param dt_object A [data.table::data.table()] that contains object data. -#' Usually created using [expand_idf_dots_value()]. +#' @inherit dup_idf_object #' @param dt_value A [data.table::data.table()] that contains value data. -#' Usually created using [expand_idf_dots_value()]. #' @param default If `TRUE`, default values are used for those blank #' fields if possible. If `FALSE`, empty fields are kept blank. #' Default: `TRUE`. @@ -2546,9 +2630,6 @@ dup_idf_object <- function (idd_env, idf_env, dt_object, level = eplusr_option(" #' @param empty If `TRUE`, trailing empty fields are kept. Default: `FALSE`. #' @param level Validate level. Default: `eplusr_option("validate_level")`. #' -#' @return The newly added object data in a named list of 3 -#' [data.table::data.table()]s, i.e. `object`, `value` and `reference`. -#' #' @keywords internal #' @export add_idf_object <- function (idd_env, idf_env, dt_object, dt_value, @@ -2572,7 +2653,7 @@ add_idf_object <- function (idd_env, idf_env, dt_object, dt_value, ) } - if (nrow(invld <- idf_env$object[fast_subset(uni, c("rleid", "class_id", "class_name")), on = "class_id"])) { + if (nrow(invld <- idf_env$object[fast_subset(uni, c("rleid", "class_id", "class_name")), on = "class_id", nomatch = 0L])) { abort(paste0("Adding new object in existing unique-object class is prohibited. Invalid input:\n", get_object_info(invld[, object_id := -rleid], numbered = TRUE, collapse = "\n")), "add_unique" @@ -2609,7 +2690,10 @@ add_idf_object <- function (idd_env, idf_env, dt_object, dt_value, } # if all inputs are duplications if (!nrow(dt_object)) { - return(list(object = dt_object[0L], value = dt_value[0L], reference = idf_env$reference[0L])) + if (unique) verbose_info("After removing duplications, nothing to add.") + return(list( + object = idf_env$object, value = idf_env$value, reference = idf_env$reference, + changed = integer(), updated = integer())) } # validate {{{ @@ -2648,10 +2732,13 @@ add_idf_object <- function (idd_env, idf_env, dt_object, dt_value, # extract new reference k <- unique(c(i, j)) - ref <- .Call(data.table:::CsubsetDT, idf_env$reference, k, seq_along(idf_env$reference)) - - # remove from the original IDF reference table - idf_env$reference <- idf_env$reference[-k] + if (!length(k)) { + ref <- idf_env$reference[0L] + } else { + ref <- .Call(data.table:::CsubsetDT, idf_env$reference, k, seq_along(idf_env$reference)) + # remove from the original IDF reference table + idf_env$reference <- idf_env$reference[-k] + } # manually check new reference } else { # add necessary columns used for getting references @@ -2660,11 +2747,9 @@ add_idf_object <- function (idd_env, idf_env, dt_object, dt_value, 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) - on.exit(set(idf_env$value, NULL, c("src_enum", "class_id", "class_name"), NULL), add = TRUE) ref <- get_value_reference_map(idd_env, append_dt(idf_env$value, dt_value), dt_value) - - set(dt_value, NULL, "src_enum", NULL) + set(idf_env$value, NULL, c("src_enum", "class_id", "class_name"), NULL) } # here should only find if any values in the original IDF reference input @@ -2673,26 +2758,18 @@ add_idf_object <- function (idd_env, idf_env, dt_object, dt_value, ref <- unique(rbindlist(list(ref, src))) # }}} - list(object = dt_object, value = dt_value, reference = ref) + list(object = append_dt(idf_env$object, dt_object), + value = append_dt(idf_env$value, dt_value), + reference = append_dt(idf_env$reference, ref, "value_id"), + changed = dt_object$object_id, + updated = integer() + ) } # }}} # set_idf_object {{{ #' Modifying existing objects #' -#' @param idd_env An environment or list contains IDD tables including class, -#' field, and reference. -#' @param idf_env An environment or list contains IDF tables including object, -#' value, and reference. -#' @param dt_object A [data.table::data.table()] that contains object data. -#' Usually created using [expand_idf_dots_value()]. -#' @param dt_value A [data.table::data.table()] that contains value data. -#' Usually created using [expand_idf_dots_value()]. -#' @param empty If `FALSE`, not required empty fields will be removed. -#' Default: `FALSE`. -#' @param level Validate level. Default: `eplusr_option("validate_level")`. -#' -#' @return The modified object data in a named list of 3 -#' [data.table::data.table()]s, i.e. `object`, `value` and `reference`. +#' @inherit add_idf_object #' #' @keywords internal #' @export @@ -2723,7 +2800,12 @@ set_idf_object <- function (idd_env, idf_env, dt_object, dt_value, empty = FALSE dt_value[dt_object, on = c("rleid", "object_id"), object_name := i.object_name] # delete empty fields - if (!empty) dt_value <- remove_empty_fields(idd_env, idf_env, dt_value) + id_del <- integer() + if (!empty) { + id_all <- dt_value$value_id + dt_value <- remove_empty_fields(idd_env, idf_env, dt_value) + id_del <- setdiff(id_all, dt_value$value_id) + } # validate validity <- validate_on_level(idd_env, idf_env, dt_object, dt_value, level = chk) @@ -2746,10 +2828,10 @@ set_idf_object <- function (idd_env, idf_env, dt_object, dt_value, empty = FALSE 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) - on.exit(set(idf_env$value, NULL, c("src_enum", "class_id", "class_name"), NULL), add = TRUE) ref <- get_value_reference_map(idd_env, append_dt(idf_env$value, dt_value), dt_value) + set(idf_env$value, NULL, c("src_enum", "class_id", "class_name"), NULL) set(dt_value, NULL, "src_enum", NULL) } @@ -2759,18 +2841,29 @@ set_idf_object <- function (idd_env, idf_env, dt_object, dt_value, empty = FALSE ref <- unique(rbindlist(list(ref, src))) # }}} - list(object = dt_object, value = dt_value, reference = ref) + # update referenced values + add_joined_cols(dt_value, ref, c("src_value_id" = "value_id"), c("value_chr", "value_num")) + idf_env$value[ref, on = "value_id", `:=`(value_chr = i.value_chr, value_num = i.value_num)] + + if (length(id_del)) { + value <- append_dt(idf_env$value[!J(id_del), on = "value_id"], dt_value, "value_id") + } else { + value <- append_dt(idf_env$value, dt_value, "value_id") + } + + order_idf_data(list( + object = append_dt(idf_env$object, dt_object, "object_id"), + value = value, + reference = append_dt(idf_env$reference, ref, "value_id"), + changed = c(dt_object$object_id), + updated = setdiff(ref$object_id, dt_object$object_id) + )) } # }}} # del_idf_object {{{ #' Delete existing objects #' -#' @param idd_env An environment or list contains IDD tables including class, -#' field, and reference. -#' @param idf_env An environment or list contains IDF tables including object, -#' value, and reference. -#' @param dt_object A [data.table::data.table()] that contains object data. -#' Usually created using [expand_idf_dots_value()]. +#' @inherit add_idf_object #' @param ref_by If `TRUE`, objects whose fields refer to input objects #' will also be deleted. Default: `FALSE`. #' @param ref_to If `TRUE`, objects whose fields are referred by input @@ -2782,10 +2875,6 @@ set_idf_object <- function (idd_env, idf_env, dt_object, dt_value, empty = FALSE #' by another object. Default: `FALSE`. #' @param force If `TRUE`, objects are deleted even if they are #' referred by other objects. -#' @param level Validate level. Default: `eplusr_option("validate_level")`. -#' -#' @return The modified whole IDF data in a named list of 3 -#' [data.table::data.table()]s, i.e. `object`, `value` and `reference`. #' #' @keywords internal #' @export @@ -2814,6 +2903,13 @@ del_idf_object <- function (idd_env, idf_env, dt_object, ref_to = FALSE, ref_by "del_unique") } } + # stop if modifying same object multiple times + if (anyDuplicated(dt_object$object_id)) { + abort(paste0("Cannot delete same object multiple times. Invalid input:\n", + get_object_info(dt_object[duplicated(object_id)], collapse = "\n")), + "del_same" + ) + } # get objects to be deleted id_del <- dt_object$object_id @@ -2937,30 +3033,19 @@ del_idf_object <- function (idd_env, idf_env, dt_object, ref_to = FALSE, ref_by id_del <- if (NROW(rel$ref_to)) c(id_del, id_ref_by, id_ref_to) else c(id_del, id_ref_by) - # delete rows in object table - obj <- idf_env$object[!J(id_del), on = "object_id"] - val <- idf_env$value[!J(id_del), on = "object_id"] - ref <- idf_env$reference[J(id_del), on = "object_id", nomatch = 0L] - - # NOTE: should keep invalid reference - # [J(id_del), on = "src_object_id", `:=`(src_object_id = NA_integer_, src_value_id = NA_integer_) - - list(object = obj, value = val, reference = ref) + list(object = idf_env$object[!J(id_del), on = "object_id"], + value = idf_env$value[!J(id_del), on = "object_id"], + reference = idf_env$reference[!J(id_del), on = "object_id"][ + J(id_del), on = "src_object_id", + `:=`(src_object_id = NA_integer_, src_value_id = NA_integer_)], + changed = id_del, updated = integer() + ) } # }}} # purge_idf_object {{{ #' Purge not-used resource objects #' -#' @param idd_env An environment or list contains IDD tables including class, -#' field, and reference. -#' @param idf_env An environment or list contains IDF tables including object, -#' value, and reference. -#' @param dt_object A [data.table::data.table()] that contains object data. -#' Usually created using [expand_idf_dots_value()]. -#' @param level Validate level. Default: `eplusr_option("validate_level")`. -#' -#' @return The modified whole IDF data in a named list of 3 -#' [data.table::data.table()]s, i.e. `object`, `value` and `reference`. +#' @inherit add_idf_object #' #' @keywords internal #' @export @@ -2975,6 +3060,13 @@ purge_idf_object <- function (idd_env, idf_env, dt_object) { } } + if (!nrow(src)) { + verbose_info("None of specified object(s) can be purged. Skip.") + return(list( + object = idf_env$object, value = idf_env$value, reference = idf_env$reference, + changed = integer(), updated = integer())) + } + # get references ref <- get_idf_relation(idd_env, idf_env, src$object_id, depth = 0L, direction = "ref_by", class_ref = "both") @@ -3005,35 +3097,30 @@ purge_idf_object <- function (idd_env, idf_env, dt_object) { if (!length(id)) { verbose_info("None of specified object(s) can be purged. Skip.") - obj <- data.table() - val <- data.table() - ref <- data.table() + obj <- idf_env$object + val <- idf_env$value + ref <- idf_env$reference } else { verbose_info("Object(s) below have been purged:\n", get_object_info(add_rleid(dt_object[J(id), on = "object_id"]), collapse = "\n")) # delete rows in object table - obj <- idf_env$object[J(id), on = "object_id"] - val <- idf_env$value[J(id), on = "object_id"] - ref <- idf_env$reference[J(id), on = "object_id", nomatch = 0L] + obj <- idf_env$object[!J(id), on = "object_id"] + val <- idf_env$value[!J(id), on = "object_id"] + ref <- idf_env$reference[!J(id), on = "object_id"] } - list(object = obj, value = val, reference = ref) + list(object = obj, value = val, reference = ref, changed = id, updated = integer()) } # }}} # duplicated_idf_object {{{ #' Determine duplicate objects #' -#' @param idd_env An environment or list contains IDD tables including class, -#' field, and reference. -#' @param idf_env An environment or list contains IDF tables including object, -#' value, and reference. -#' @param dt_object A [data.table::data.table()] that contains object data. -#' Usually created using [expand_idf_dots_value()]. +#' @inherit add_idf_object #' #' @return A same [data.table::data.table()] as input `dt_object` (updated by -#' reference) with appended logical column `duplicated` indicating the object is -#' a duplicated one or not. +#' reference) with appended integer column `unique_object_id` indicating the +#' object is a duplicated one of that object. #' #' @keywords internal #' @export @@ -3064,8 +3151,7 @@ duplicated_idf_object <- function (idd_env, idf_env, dt_object) { } ))[, lapply(.SD, unlist), by = c("class_id", "object_id")] - set(dt_object, NULL, "duplicated", FALSE) - if (nrow(dup)) dt_object[J(dup$object_id_dup), on = "object_id", duplicated := TRUE] + dt_object[dup, on = c("object_id" = "object_id_dup"), unique_object_id := i.object_id] dt_object } @@ -3073,95 +3159,78 @@ duplicated_idf_object <- function (idd_env, idf_env, dt_object) { # unique_idf_object {{{ #' Remove duplicate objects #' -#' @param idd_env An environment or list contains IDD tables including class, -#' field, and reference. -#' @param idf_env An environment or list contains IDF tables including object, -#' value, and reference. -#' @param dt_object A [data.table::data.table()] that contains object data. -#' Usually created using [expand_idf_dots_value()]. -#' -#' @return The modified whole IDF data in a named list of 3 -#' [data.table::data.table()]s, i.e. `object`, `value` and `reference`. +#' @inherit add_idf_object #' #' @keywords internal #' @export unique_idf_object <- function (idd_env, idf_env, dt_object) { dup <- duplicated_idf_object(idd_env, idf_env, dt_object) - if (!any(dup$duplicated)) { + if (checkmate::allMissing(dup$unique_object_id)) { verbose_info("None duplicated objects found. Skip.") - return(list(object = data.table(), value = data.table(), reference = data.table())) + return(list( + object = idf_env$object, value = idf_env$value, reference = idf_env$reference, + changed = integer(), updated = integer())) } - obj <- dup[J(TRUE), on = "duplicated", .SDcols = -"duplicated"] - val <- get_idf_value(idd_env, idf_env, object = obj$object_id) + obj <- dup[!J(NA_integer_), on = "unique_object_id"] + + # remove reference rows of duplicated objects + ref <- idf_env$reference[!J(obj$object_id), on = "object_id"] # get referenced field index of object to be deleted - ref <- get_idf_relation(idd_env, idf_env, object_id = obj$object_id, direction = "ref_by", depth = 0L) - ref[val, on = c("src_object_id" = "object_id", "src_value_id" = "value_id"), field_index := i.field_index] - # update the referenced object id - ref[dup, on = c("src_object_id" = "object_id_dup"), src_object_id := i.object_id] - # update the reference value id - ref[val, on = c("src_object_id" = "object_id", "field_index"), `:=`( - src_value_id = i.value_id, src_value_chr = i.value_chr, - src_value_num = i.value_num - )] + src <- ref[J(obj$object_id), on = "src_object_id", nomatch = NULL] - # update referenced value - idf_env$value[ref, on = c("object_id", "value_id"), `:=`( - value_chr = i.src_value_chr, value_num = i.src_value_num - )] - # update reference dict - idf_env$reference[ref, on = c("object_id", "value_id"), `:=`( - src_object_id = i.src_object_id, src_value_id = i.src_value_id - )] + if (in_verbose()) { + setnames(obj, c("object_id", "object_name", "unique_object_id"), c("removed_object_id", "removed_object_name", "object_id")) + obj[dup, on = "object_id", `:=`(object_name = i.object_name)] + set(obj, NULL, "unique", get_object_info(obj, numbered = FALSE, prefix = "")) - if (eplusr::eplusr_option("verbose_info")) { - dup[obj, on = "object_id", `:=`(class_name = i.class_name, object_name = i.object_name)] - set(dup, NULL, "merged", get_object_info(dup, numbered = FALSE, prefix = "")) + setnames(obj, + c("removed_object_id", "removed_object_name", "object_id", "object_name"), + c("object_id", "object_name", "unique_object_id", "unique_object_name") + ) - setnames(dup, c("object_id", "object_id_dup"), c("merged_object_id", "object_id")) - dup[obj, on = "object_id", `:=`(object_name = i.object_name)] - dup[, by = c("class_id", "merged_object_id"), removed := get_object_info(.SD, c("id", "name"), numbered = TRUE)] + obj[, rleid := seq_len(.N), by = c("class_id", "unique_object_id")] + obj[, by = c("class_id", "unique_object_id"), + removed := get_object_info(.SD, c("id", "name"), numbered = TRUE) + ] - msg <- dup[, by = c("class_id", "merged_object_id"), list(list( + msg <- obj[, by = c("class_id", "unique_object_id"), list(list( sprintf("Duplications for %s have been removed:\n %s", - merged[[1L]], paste0(removed, collapse = "\n ") + unique[[1L]], paste0(removed, collapse = "\n ") ) ))]$V1 - - setnames(dup, c("merged_object_id", "object_id"), c("object_id", "object_id_dup")) - verbose_info(paste0(unlist(msg), collapse = "\n\n")) } - list(object = idf_env$object[!J(dup$object_id_dup), on = "object_id"], - value = idf_env$value[!J(dup$object_id_dup), on = "object_id"], - reference = idf_env$reference + src[idf_env$value, on = c("src_object_id" = "object_id", "src_value_id" = "value_id"), + `:=`(src_field_id = i.field_id)] + + # get unique object data + src[obj, on = c("src_object_id" = "object_id"), unique_object_id := i.unique_object_id] + src[idf_env$value, on = c("unique_object_id" = "object_id", "src_field_id" = "field_id"), + `:=`(src_value_id = i.value_id, src_value_chr = i.value_chr, src_value_num = i.value_num)] + + # update referenced value + idf_env$value[src, on = c("object_id", "value_id"), `:=`( + value_chr = i.src_value_chr, value_num = i.src_value_num + )] + # update reference dict + ref[src, on = c("object_id", "value_id"), `:=`( + src_object_id = i.unique_object_id, src_value_id = i.src_value_id + )] + + list(object = idf_env$object[!J(obj$object_id), on = "object_id"], + value = idf_env$value[!J(obj$object_id), on = "object_id"], + reference = ref, changed = obj$object_id, updated = setdiff(src$object_id, obj$object_id) ) } # }}} # rename_idf_object {{{ #' Rename existing objects #' -#' @param idd_env An environment or list contains IDD tables including class, -#' field, and reference. -#' @param idf_env An environment or list contains IDF tables including object, -#' value, and reference. -#' @param dt_object A [data.table::data.table()] that contains object data. -#' Usually created using [expand_idf_dots_name()]. -#' @param level Validate level. Default: `eplusr_option("validate_level")`. -#' -#' @return The modified object data in a named list of 3 -#' [data.table::data.table()]s, i.e. `object`, `value`, `reference`. -#' -#' @note -#' * The `reference` table in the returned list only contains the reference-by -#' map, indicating which values have been updated in the main `value` table in -#' `idf_env`. -#' * The `value` table in input `idf_env` could be modified if input objects are -#' referenced by other objects. The `reference` table in the returned list -#' tells the id actual values modified +#' @inherit add_idf_object #' #' @keywords internal #' @export @@ -3193,7 +3262,8 @@ rename_idf_object <- function (idd_env, idf_env, dt_object, level = eplusr_optio setnames(obj, c("new_object_name", "new_object_name_lower"), c("object_name", "object_name_lower")) # extract value table - val <- get_idf_value(idd_env, idf_env, object = obj$object_id, property = "is_name") + val <- get_idf_value(idd_env, idf_env, object = obj$object_id, property = "is_name")[ + J(TRUE), on = "is_name", nomatch = NULL] # assign new object name set(obj, NULL, "has_name", TRUE) @@ -3205,8 +3275,9 @@ rename_idf_object <- function (idd_env, idf_env, dt_object, level = eplusr_optio # For instance, `1: Zone Name` in `AirflowNetwork:MultiZone:Zone`. It # references to values from `Zone` names and also can be referenced by # `3: Zone Name` in `AirflowNetwork:IntraZone:Node`. - # In this case, it is also needed to check if new names are valid. - ref_to <- idf_env$reference[J(val$value_id[val$is_name], IDDFIELD_SOURCE$field), on = c("value_id", "src_enum"), nomatch = 0L] + # In this case, if these fields are names, it is also needed to check if new + # names are valid. + ref_to <- idf_env$reference[J(val$value_id, IDDFIELD_SOURCE$field), on = c("value_id", "src_enum"), nomatch = 0L] if (nrow(ref_to) && chk$reference) { validity <- validate_on_level(idd_env, idf_env, obj, val, level = chk) assert_valid(validity, "rename") @@ -3215,7 +3286,7 @@ rename_idf_object <- function (idd_env, idf_env, dt_object, level = eplusr_optio # value reference # extract value reference and update other objects using its name # only consider value reference - ref_by <- idf_env$reference[J(val$value_id[val$is_name], IDDFIELD_SOURCE$field), on = c("src_value_id", "src_enum"), nomatch = 0L] + ref_by <- idf_env$reference[J(val$value_id, IDDFIELD_SOURCE$field), on = c("src_value_id", "src_enum"), nomatch = 0L] # update values in main table if (nrow(ref_by)) { @@ -3224,16 +3295,28 @@ rename_idf_object <- function (idd_env, idf_env, dt_object, level = eplusr_optio set(ref_by, NULL, "src_value_chr", NULL) } - set(obj, NULL, "has_name", NULL) - set(val, NULL, "is_name", NULL) - setcolorder(obj, c("rleid", "class_id", "class_name", "object_id", "object_name", "object_name_lower", "comment")) - setcolorder(val, c("rleid", "class_id", "class_name", "object_id", "object_name", "field_id", "field_index", "field_name", "value_id", "value_chr")) - - list(object = obj, value = val, reference = ref_by) + list(object = idf_env$object[obj, on = "object_id", `:=`(object_name = i.object_name, object_name_lower = i.object_name_lower)], + value = idf_env$value[val, on = "value_id", `:=`(value_chr = i.value_chr, value_num = i.value_num)], + reference = idf_env$reference, + changed = obj$object_id, + updated = setdiff(ref_by$object_id, obj$object_id) + ) } # }}} # remove_empty_fields {{{ +#' Remove trailing empty object fields +#' +#' @param idd_env An environment or list contains IDD tables including class, +#' field, and reference. +#' @param idf_env An environment or list contains IDF tables including object, +#' value, and reference. +#' @param dt_value A [data.table::data.table()] that contains value data. +#' +#' @return A [data.table::data.table()] +#' +#' @keywords internal +#' @export remove_empty_fields <- function (idd_env, idf_env, dt_value) { if (!has_names(dt_value, "required_field")) { add_field_property(idd_env, dt_value, "required_field") @@ -3302,6 +3385,20 @@ remove_empty_fields <- function (idd_env, idf_env, dt_value) { } # }}} # remove_duplicated_objects {{{ +#' Remove duplicated objects in inputs +#' +#' @param idd_env An environment or list contains IDD tables including class, +#' field, and reference. +#' @param idf_env An environment or list contains IDF tables including object, +#' value, and reference. +#' @param dt_object A [data.table::data.table()] that contains object data. +#' @param dt_value A [data.table::data.table()] that contains value data. +#' +#' @return The modified input data in a named list of 2 +#' [data.table::data.table()]s, i.e. `object` and `value`. +#' +#' @keywords internal +#' @export remove_duplicated_objects <- function (idd_env, idf_env, dt_object, dt_value) { # extract all object values in the same class # in order to distinguish input from original IDF, set id of objects @@ -3314,14 +3411,16 @@ remove_duplicated_objects <- function (idd_env, idf_env, dt_object, dt_value) { list(class_id, object_id = -object_id, field_index, value_chr), nomatch = 0L] set(idf_env$value, NULL, c("class_id", "field_index"), NULL) - # if there are no objects in the same class - if (!nrow(val_idf)) return(list(object = dt_object, value = dt_value)) - # get all input value val_in <- dt_value[, list(class_id, object_id, field_index, value_chr)] # compare in case-insensitive way - val_d <- rbindlist(list(val_idf, val_in), fill = TRUE) + if (!nrow(val_idf)) { + # if there are no objects in the same class, only consider input + val_d <- val_in + } else { + val_d <- rbindlist(list(val_idf, val_in), fill = TRUE) + } set(val_d, NULL, "value_chr", stri_trans_tolower(val_d$value_chr)) # dcast to compare @@ -3548,107 +3647,6 @@ add_idf_relation_format_cols <- function (idd_env, idf_env, ref) { ref } # }}} -# # update_value_reference {{{ -# update_value_reference <- function (idd_env, idf_env, object, value) { -# # If field reference has been handled and updated during validation, only -# # check sources -# if (level_checks()$reference) { -# set(object, NULL, "rleid", -object$rleid) - -# # update object id as new object id during validation -# idf_env$reference[object, on = c("object_id" = "rleid"), object_id := i.object_id] -# idf_env$reference[object, on = c("src_object_id" = "rleid"), src_object_id := i.object_id] - -# # if have new sources -# if (any(value$src_enum > IDDFIELD_SOURCE$none)) { -# idf_env <- update_referenced_value(idd_env, idf_env, value) -# idf_env$value <- add_field_property(idd_env, idf_env$value, "type_enum") -# val <- value -# new_ref <- get_value_reference_map(idd_env, -# value[!J(idf_env$value$value_id), on = "value_id"], -# idf_env$value[!J(val$value_id), on = "value_id"], all = FALSE -# ) -# set(idf_env$value, NULL, "type_enum", NULL) -# if (nrow(new_ref)) { -# ref <- rbindlist(list(idf_env$reference, new_ref)) -# } else { -# ref <- idf_env$reference -# } -# } else { -# ref <- idf_env$reference -# } -# } else { -# idf_env$value <- add_field_property(idd_env, idf_env$value, c("src_enum", "type_enum")) -# if (any(value$type_enum == IDDFIELD_TYPE$object_list)) { -# new_ref <- TRUE -# val_ref <- append_dt(idf_env$value, value, "value_id") -# } else { -# new_ref <- FALSE -# val_ref <- idf_env$value -# } - -# # add class name -# set(idf_env$value, NULL, "class_id", idf_env$object[J(idf_env$value$object_id), on = "object_id", class_id]) -# idf_env$value <- add_class_name(idd_env, idf_env$value) -# if (any(value$src_enum > IDDFIELD_SOURCE$none)) { -# idf_env <- update_referenced_value(idd_env, idf_env, value) - -# new_src <- TRUE -# val_src <- append_dt(idf_env$value, value, "value_id") -# } else { -# new_src <- FALSE -# val_src <- idf_env$value -# } - -# if (!new_ref && !new_src) { -# ref <- idf_env$reference -# } else { -# ref <- get_value_reference_map(idd_env, val_src, val_ref) -# } -# set(idf_env$value, NULL, c("class_id", "class_name", "src_enum", "type_enum"), NULL) -# } - -# ref -# } -# # }}} -# # update_referenced_value {{{ -# update_referenced_value <- function (idd_env, idf_env, value) { -# ref <- find_value_reference(idd_env, idf_env, value[src_enum > IDDFIELD_SOURCE$none, value_id]) - -# if (!nrow(ref)) return(idf_env) - -# # get actual source value -# ref[value, on = c("src_value_id" = "value_id"), `:=`( -# value_chr = i.value_chr, value_num = i.value_num, class_name = i.class_name -# )] -# ref[J(IDDFIELD_SOURCE$class), on = "src_enum", `:=`(value_chr = class_name, value_num = NA_real_)] - -# # update value -# idf_env$value[ref, on = "value_id", `:=`(value_chr = i.value_chr, value_num = i.value_num)] - -# idf_env -# } -# # }}} -# # find_value_reference {{{ -# find_value_reference <- function (idd_env, idf_env, value_id = NULL, only_top = TRUE) { -# id <- value_id - -# if (!length(id)) return(idf_env$reference[0L]) - -# cur_ref <- idf_env$reference[J(id), on = "src_value_id", nomatch = 0L] - -# ref <- cur_ref[0L] -# while(nrow(cur_ref) > 0L) { -# ref <- rbindlist(list(ref, cur_ref)) -# next_ref <- idf_env$reference[J(unique(cur_ref$value_id)), on = "src_value_id", nomatch = 0L] -# # make sure always use the top level value id -# if (only_top) next_ref[cur_ref, on = c("src_value_id" = "value_id"), src_value_id := i.value_id] -# cur_ref <- next_ref -# } - -# ref -# } -# # }}} # NODES # get_idf_node_relation {{{ @@ -3664,8 +3662,8 @@ get_idf_node_relation <- function (idd_env, idf_env, object_id = NULL, value_id object = NULL, class = NULL, group = NULL, name = FALSE, keep_all = FALSE, depth = 0L) { assert( - check_integerish(object_id, any.missing = FALSE), - check_integerish(value_id, any.missing = FALSE) + check_integerish(object_id, any.missing = FALSE, null.ok = TRUE), + check_integerish(value_id, any.missing = FALSE, null.ok = TRUE) ) assert_count(depth, null.ok = TRUE) if (is.null(depth)) depth <- Inf @@ -3682,8 +3680,8 @@ get_idf_node_relation <- function (idd_env, idf_env, object_id = NULL, value_id if (is.null(value_id)) { # if no object id is given if (is.null(object_id)) { - # use all objects in current IDF - id <- idf_env$object$object_id + # node search needs a start point + abort("A start point is needed for searching for node relation. Either 'object_id' or 'value_id' should not be NULL.") } else { # use specified object IDs id <- object_id @@ -3745,10 +3743,13 @@ get_idf_node_relation <- function (idd_env, idf_env, object_id = NULL, value_id if (!is.null(object)) { obj_id <- unique(c(obj_id, get_idf_object(idd_env, idf_env, object = object)$object_id)) } - if (depth == 0L && length(obj_id)) { + if (!is.null(obj_id)) { cur_nodes <- cur_nodes[J(obj_id), on = col_ref, nomatch = 0L] } + # no matched objects found for specified classes or groups + if (!is.null(obj_id) && !length(obj_id)) all_nodes <- all_nodes[0L] + # store classes or objects needed to be removed later del <- list() @@ -3893,7 +3894,7 @@ read_idfeditor_copy <- function (idd_env, idf_env, version = NULL, in_ip = FALSE get_idf_table <- function (idd_env, idf_env, class = NULL, object = NULL, string_value = TRUE, unit = FALSE, wide = FALSE, align = FALSE, all = FALSE, group_ext = c("none", "group", "index"), - force = FALSE) { + force = FALSE, init = FALSE) { group_ext <- match.arg(group_ext) cols <- c("object_id", "object_name", "class_name", @@ -3901,10 +3902,21 @@ get_idf_table <- function (idd_env, idf_env, class = NULL, object = NULL, "units", "ip_units", "type_enum", "extensible_group", "value_chr", "value_num") - val <- get_idf_value(idd_env, idf_env, class = class, object = object, - property = c("units", "ip_units", "type_enum", "extensible_group"), - align = align, complete = TRUE, all = all, ignore_case = TRUE)[ - , .SD, .SDcols = c("rleid", cols)] + if (init) { + if (!is.null(object)) warn("'object' is ignored when 'init' is set to 'TRUE'.") + + val <- init_idf_value(idd_env, idf_env, class, complete = TRUE, all = all, id = TRUE, + property = c("units", "ip_units", "type_enum", "extensible_group") + ) + + # assign new object id + set(val, NULL, "object_id", val$rleid + max(idf_env$object$object_id)) + } else { + val <- get_idf_value(idd_env, idf_env, class = class, object = object, + property = c("units", "ip_units", "type_enum", "extensible_group"), + align = align, complete = TRUE, all = all, ignore_case = TRUE)[ + , .SD, .SDcols = c("rleid", cols)] + } if (wide && length(cls <- unique(val$class_name)) != 1L && !force) { if (length(cls) <= 5L) { @@ -4151,12 +4163,12 @@ save_idf <- function (idd_env, idf_env, dt_order = NULL, path, in_ip = FALSE, format <- match.arg(format) assert_string(path) - if (!has_ext(path, "idf")) abort("'path' should have the extension of 'idf'") + if (!has_ext(path, "idf")) abort("'path' should have the extension of 'idf'", "idf_save_ext") if (file.exists(path)) { new_file <- FALSE if (!overwrite) { - abort("Target IDF file already exists. Please set 'overwrite' to TRUE if you want to replace it.") + abort("Target IDF file already exists. Please set 'overwrite' to TRUE if you want to replace it.", "idf_save_exist") } else { verbose_info("Replace the existing IDF located at ", normalizePath(path), ".") } @@ -4218,8 +4230,8 @@ resolve_idf_external_link <- function (idd_env, idf_env, old, new, copy = TRUE) m <- paste0(" ", unlist(format_objects(val, c("class", "object", "value"), brief = FALSE)$out), collapse = "\n") - warn("warning_broken_file_link", - paste0("Broken external file link found in IDF:\n\n", m) + warn(paste0("Broken external file link found in IDF:\n\n", m), + "warning_broken_file_link" ) } @@ -4266,27 +4278,39 @@ resolve_idf_external_link <- function (idd_env, idf_env, old, new, copy = TRUE) # MISC # assign_new_id {{{ -assign_new_id <- function (dt_idf, dt, type = c("object", "value"), keep = FALSE) { +assign_new_id <- function (idf_env, dt, type = c("object", "value"), keep = FALSE) { type <- match.arg(type) col <- paste0(type, "_id") if (!keep) { - set(dt, NULL, col, new_id(dt_idf[[type]], col, nrow(dt))) + set(dt, NULL, col, new_id(idf_env[[type]], col, nrow(dt))) } else { - dt[is.na(get(col)), `:=`(value_id = new_id(dt_idf[[type]], col, .N))] + dt[is.na(get(col)), `:=`(value_id = new_id(idf_env[[type]], col, .N))] } } # }}} # assign_idf_value_default {{{ +#' Assign default field values +#' +#' @param idd_env An environment or list contains IDD tables including class, +#' field, and reference. +#' @param idf_env An environment or list contains IDF tables including object, +#' value, and reference. +#' @param dt_value A [data.table::data.table()] that contains object value data. +#' +#' @return The updated version of [data.table::data.table()]. +#' +#' @keywords internal +#' @export assign_idf_value_default <- function (idd_env, idf_env, dt_value) { - if (in_ip_mode()) { - dt_value <- field_default_to_unit(idd_env, dt_value, "si", "ip") - } - cols_add <- NULL if (!has_names(dt_value, "default_chr")) cols_add <- "default_chr" if (!has_names(dt_value, "default_num")) cols_add <- c(cols_add, "default_num") if (!is.null(cols_add)) add_field_property(idd_env, dt_value, cols_add) + if (in_ip_mode()) { + dt_value <- field_default_to_unit(idd_env, dt_value, "si", "ip") + } + if (has_names(dt_value, "defaulted")) { dt_value[J(TRUE), on = "defaulted", `:=`(value_chr = default_chr, value_num = default_num)] } else { @@ -4298,25 +4322,12 @@ assign_idf_value_default <- function (idd_env, idf_env, dt_value) { dt_value } # }}} -# merge_idf_data {{{ -merge_idf_data <- function (idf_env, lst, by_object = FALSE) { - assert_names(names(lst), c("object", "value", "reference")) - - idf_env$object <- append_dt(idf_env$object, lst$object, "object_id") +# order_idf_data {{{ +order_idf_data <- function (lst) { + setorderv(lst$object, "object_id") + setorderv(lst$value, c("object_id", "field_id")) - if (nrow(lst$value)) { - if (by_object) { - idf_env$value <- append_dt(idf_env$value, lst$value, "object_id") - } else { - idf_env$value <- append_dt(idf_env$value, lst$value, "value_id") - } - } - idf_env$reference <- lst$reference - - setorderv(idf_env$object, c("object_id")) - setorderv(idf_env$value, c("object_id", "field_id")) - - idf_env + lst } # }}} # add_idf_format_cols {{{ diff --git a/R/impl-idfobj.R b/R/impl-idfobj.R index c1684bfae..98f71d04c 100644 --- a/R/impl-idfobj.R +++ b/R/impl-idfobj.R @@ -7,40 +7,6 @@ NULL # IDF OBJECT -# set_idfobj_comment {{{ -set_idfobj_comment <- function (idd_env, idf_env, object_id, comment, append = TRUE, width = 0L) { - obj <- get_idf_object(idd_env, idf_env, object = object_id) - - if (is.null(comment)) { - set(obj, NULL, "comment", list(list(NULL))) - } else { - comment <- as.character(comment) - assert(is_count(width, TRUE)) - - cmt <- unlist(strsplit(comment, "\n", fixed = TRUE), use.names = FALSE) - - if (width != 0L) { - cmt <- strwrap(cmt, width = width) - } - - if (is.null(append)) { - # reset - set(obj, NULL, "comment", list(list(cmt))) - } else { - assert(is_flag(append), msg = "`append` should be NULL or a single logical value.") - if (append) { - # add new - set(obj, NULL, "comment", list(list(c(obj$comment[[1L]], cmt)))) - } else { - set(obj, NULL, "comment", list(list(c(cmt, obj$comment[[1L]])))) - } - - } - } - - obj -} -# }}} # get_idfobj_value {{{ get_idfobj_value <- function (idd_env, idf_env, object, which = NULL, all = FALSE, simplify = FALSE, unit = FALSE, underscore = FALSE) { @@ -53,9 +19,10 @@ get_idfobj_value <- function (idd_env, idf_env, object, which = NULL, all = FALS get_value_list(val, unit) } # }}} -# get_value_list: return a list of field values with correct types {{{ +# get_value_list {{{ +#' @importFrom checkmate assert_names get_value_list <- function (dt_value, unit = FALSE) { - assert(has_name(dt_value, c("value_chr", "value_num", "type_enum"))) + assert_names(names(dt_value), must.include = c("value_chr", "value_num", "type_enum")) res <- as.list(dt_value[["value_chr"]]) num <- dt_value$type_enum <= IDDFIELD_TYPE$real & @@ -68,12 +35,11 @@ get_value_list <- function (dt_value, unit = FALSE) { res[num & !is_double] <- as.integer(val[num & !is_double]) if (any(unlist(res[exists & num & !is_double]) != val[exists & num & !is_double])) { - warn("warning_value_int_trunc", - paste0("Truncated error introduced when converting value of field ", + warn(paste0("Truncated error introduced when converting value of field ", collapse(dt_value[["field_name"]][res[num & !is_double] != val[num & !is_double]]), " to integer. This often indicates that integer fields have ", - "decimal numbers. Please see `$validate()` for details." - ) + "decimal numbers. Please see '$validate()' for details." + ), "warning_value_int_trunc" ) } @@ -103,59 +69,11 @@ get_value_list <- function (dt_value, unit = FALSE) { res } # }}} -# set_idfobj_value {{{ -set_idfobj_value <- function (idd_env, idf_env, object, ..., .default = TRUE, .empty = FALSE) { - nm <- if (is_count(object)) paste0("..", object) else object - - input <- list(...) - - # if single input - if (length(input) == 1L) { - # if input is an atomic - if (is.atomic(input[[1L]])) { - # for `<-.IdfObject` - if (length(input[[1L]]) == 1L && is_named(input[[1L]])) { - input <- list(as.list(input[[1L]])) - # for `$set(field = value)` - } else { - input <- list(input) - } - # for `$set(list(field1 = value1, field2 = value2))` - } else { - # check for .comment - if (has_name(input[[1L]], ".comment")) { - abort("error_idfobj_dotcomment", - paste0( - "Using `.comment` to set object comments is prohibited in ", - "`IdfObject` class. Please use `$comment()` method instead." - ) - ) - } - } - # for `$set(field1 = value1, field2 = value2)` - } else { - # check for .comment - if (has_name(input, ".comment")) { - abort("error_idfobj_dotcomment", - paste0( - "Using `.comment` to set object comments is prohibited in ", - "`IdfObject` class. Please use `$comment()` method instead." - ) - ) - } - input <- list(input) - } - - setattr(input, "names", nm) - - set_idf_object(idd_env, idf_env, input, .default = .default, .empty = .empty) -} -# }}} # get_idfobj_possible {{{ -get_idfobj_possible <- function (idd_env, idf_env, object, field, +#' @importFrom checkmate assert_subset +get_idfobj_possible <- function (idd_env, idf_env, object, field = NULL, type = c("auto", "default", "choice", "range", "source")) { - all_type <- c("auto", "default", "choice", "range", "source") - assert(no_na(chmatch(type, all_type)), msg = paste0("`type` should be one or some of ", collapse(all_type))) + assert_subset(type, c("auto", "default", "choice", "range", "source"), FALSE) prop <- c("units", "ip_units", "type_enum") if ("auto" %chin% type) prop <- c(prop, "autosizable", "autocalculatable") @@ -235,8 +153,7 @@ get_idfobj_relation <- function (idd_env, idf_env, object_id = NULL, value_id = object = NULL, class = NULL, group = NULL, keep_all = FALSE, depth = 0L, class_ref = c("both", "none", "all")) { all_dir <- c("ref_to", "ref_by", "node", "all") - direction <- all_dir[sort(chmatch(direction, all_dir))] - assert(no_na(direction), msg = paste0("`direction` should be one or some of ", collapse(all_dir))) + checkmate::assert_subset(direction, all_dir, FALSE) rel <- list(ref_to = NULL, ref_by = NULL, node = NULL) @@ -268,10 +185,9 @@ get_idfobj_relation <- function (idd_env, idf_env, object_id = NULL, value_id = rel } # }}} - # get_idfobj_table {{{ get_idfobj_table <- function (idd_env, idf_env, object_id, all = FALSE, - unit = TRUE, wide = FALSE, string_value = TRUE, group_ext = 0L) { + unit = TRUE, wide = FALSE, string_value = TRUE, group_ext = "none") { get_idf_table(idd_env, idf_env, NULL, object_id, all = all, unit = unit, wide = wide, string_value = string_value, group_ext = group_ext ) @@ -299,16 +215,39 @@ get_idfobj_string <- function (idd_env, idf_env, object_id, comment = TRUE, lead c(cmt, cls, fld) } # }}} +# set_idfobj_comment {{{ +#' @importFrom checkmate assert_count test_flag +set_idfobj_comment <- function (idd_env, idf_env, object_id, comment, append = TRUE, width = 0L) { + obj <- get_idf_object(idd_env, idf_env, object = object_id) -# helper -# merge_idfobj_data {{{ -merge_idfobj_data <- function (idf_env, dt, type = c("object", "value", "reference")) { - type <- match.arg(type) - if (type != "reference") { - idf_env[[type]] <- append_dt(idf_env[[type]], dt, paste0(type, "_id")) + if (is.null(comment)) { + set(obj, NULL, "comment", list(list(NULL))) } else { - idf_env[[type]] <- dt + comment <- as.character(comment) + assert_count(width) + + cmt <- unlist(strsplit(comment, "\n", fixed = TRUE), use.names = FALSE) + + if (width != 0L) { + cmt <- strwrap(cmt, width = width) + } + + if (is.null(append)) { + # reset + set(obj, NULL, "comment", list(list(cmt))) + } else if (test_flag(append)){ + if (append) { + # add new + set(obj, NULL, "comment", list(list(c(obj$comment[[1L]], cmt)))) + } else { + set(obj, NULL, "comment", list(list(c(cmt, obj$comment[[1L]])))) + } + + } else { + abort("'append' should be NULL or a single logical value.") + } } - idf_env + + obj } # }}} diff --git a/R/impl.R b/R/impl.R index f37475f75..7690d1fab 100644 --- a/R/impl.R +++ b/R/impl.R @@ -161,6 +161,13 @@ verbose_info <- function (...) { if (eplusr_option("verbose_info")) message(...) } # }}} +# fast_subset {{{ +# very odd way to subset columns but is way faster +# ref: https://github.com/Rdatatable/data.table/issues/3477 +fast_subset <- function (dt, cols) { + setDT(unclass(dt)[cols]) +} +# }}} # abort_bad_key {{{ abort_bad_key <- function (key, value) { @@ -177,7 +184,7 @@ abort_bad_field <- function (key, dt, ...) { name = errormsg_field_name(dt) ) - abort(paste0(h, mes, ...), class = paste0("invalid_field_", key)) + abort(paste0(h, mes, ...), class = paste0("invalid_field_", key), data = dt) } # }}} # errormsg_info {{{ @@ -235,10 +242,12 @@ add_rleid <- function (dt, prefix = NULL) { append_dt <- function (dt, new_dt, base_col = NULL) { assert_names(names(new_dt), must.include = names(dt)) + if (!nrow(new_dt)) return(dt) + if (is.null(base_col)) { - rbindlist(list(dt, new_dt[, .SD, .SDcols = names(dt)])) + rbindlist(list(dt, fast_subset(new_dt, names(dt)))) } else { - rbindlist(list(dt[!new_dt, on = base_col], new_dt[, .SD, .SDcols = names(dt)])) + rbindlist(list(dt[!new_dt, on = base_col], fast_subset(new_dt, names(dt)))) } } # }}} @@ -249,7 +258,7 @@ unique_id <- function () { # }}} # assert_valid_type {{{ -assert_valid_type <- function (x, name = NULL, len = NULL, null.ok = FALSE, lower = -Inf, type = c("both", "id", "name")) { +assert_valid_type <- function (x, name = NULL, len = NULL, null.ok = FALSE, lower = 1L, type = c("both", "id", "name")) { if (is.null(name)) name <- checkmate::vname(x) type <- match.arg(type) diff --git a/R/parse.R b/R/parse.R index b933a42d8..0a92ae128 100644 --- a/R/parse.R +++ b/R/parse.R @@ -223,7 +223,7 @@ parse_idf_file <- function (path, idd = NULL, ref = TRUE) { # value reference map if (ref) { - dt_reference <- get_value_reference_map(idd_env$reference, dt_value, dt_value) + dt_reference <- get_value_reference_map(idd_env, dt_value, dt_value) } else { dt_reference <- data.table( object_id = integer(0L), value_id = integer(0L), @@ -237,6 +237,10 @@ parse_idf_file <- function (path, idd = NULL, ref = TRUE) { c("value_id", "value_chr", "value_num", "object_id", "field_id")), NULL ) + # column order + setcolorder(dt_object, c("object_id", "object_name", "object_name_lower", "comment", "class_id")) + setcolorder(dt_value, c("value_id", "value_chr", "value_num", "object_id", "field_id")) + list(version = idd_ver, options = options, object = dt_object, value = dt_value, reference = dt_reference ) @@ -293,9 +297,12 @@ get_idf_ver <- function (idf_dt) { if (!nrow(ver_line)) { NULL } else if (nrow(ver_line) == 1L) { - standardize_ver(ver_line$version, complete = FALSE) + ver <- standardize_ver(ver_line$version, complete = FALSE) + if (is.na(ver)) parse_error("idf", "Invalid IDF version found", ver_line, subtype = "ver") + attr(ver, "line") <- ver_line$line + ver } else { - parse_error("idf", "Multiple versions found", ver_line) + parse_error("idf", "Multiple IDF versions found", ver_line, subtype = "ver") } } # }}} @@ -1089,7 +1096,7 @@ mark_idf_lines <- function (dt, type_enum) { # if there are still known lines, throw an error if (nrow(dt[type == type_enum$unknown]) > 0L) { - parse_error("idf", "Invalid line found", dt[type == type_enum$unknown]) + parse_error("idf", "Invalid line found", dt[type == type_enum$unknown], subtype = "line") } dt @@ -1158,7 +1165,7 @@ sep_object_table <- function (dt, type_enum, version, idd) { # check incomplete object incomp_obj <- dt[is.na(object_id) & type >= type_enum$value] if (nrow(incomp_obj)) { - parse_error("idf", "Incomplete object", dt[is.na(object_id)], 1L) + parse_error("idf", "Incomplete object", dt[is.na(object_id)], 1L, subtype = "object") } # extract class names @@ -1190,14 +1197,14 @@ sep_object_table <- function (dt, type_enum, version, idd) { # if multiple version found, stop if (length(id_ver) > 1L) { - parse_error("idf", "Multiple IDF Version found", dt[object_id %in% id_ver], length(id_ver)) + parse_error("idf", "Multiple IDF versions found", dt[object_id %in% id_ver], length(id_ver), subtype = "ver") } # }}} # check invalid class name invld_obj <- dt[is.na(class_id) & !is.na(class_name_lower)] if (nrow(invld_obj)) { - parse_error("idf", "Invalid class name", invld_obj) + parse_error("idf", "Invalid class name", invld_obj, subtype = "class") } # fill class id and class name @@ -1238,7 +1245,12 @@ sep_object_table <- function (dt, type_enum, version, idd) { # get_value_table {{{ get_value_table <- function (dt, idd) { # count value number per line - set(dt, NULL, "value_count", stri_count_charclass(dt$body, "[,;]")) + set(dt, NULL, "value_count", stri_count_fixed(dt$body, ",") + stri_endswith_fixed(dt$body, ";")) + + # in case there are multiple semicolon in one line + if (any(stri_count_fixed(dt$body, ";") > 1L)) { + parse_error("idf", "Invalid line found", dt[stri_count_fixed(body, ";") > 1L], subtype = "line") + } setindexv(dt, "value_count") @@ -1293,7 +1305,7 @@ get_value_table <- function (dt, idd) { ) # issue parse error if invalid field number found - if (inherits(fld, "error_bad_field_index")) { + if (inherits(fld, "eplusr_error_invalid_field_index")) { # get invalid class id and field number invld <- set(fld$data, NULL, "field_index", NULL) # find which object has invalid field number @@ -1301,7 +1313,7 @@ get_value_table <- function (dt, idd) { # modify message msg <- gsub(" *#\\d+\\|", "-->", gsub("index", "number", fld$message)) - parse_error("idf", "Invalid field number", dt[J(obj), on = "object_id"], post = msg) + parse_error("idf", "Invalid field number", dt[J(obj), on = "object_id"], post = msg, subtype = "field") } # bind columns @@ -1341,7 +1353,7 @@ update_object_name <- function (dt_object, dt_value) { return(dt_object) } } - dt_object[dt_nm, on = "object_id", `:=`(object_name = dt_nm$object_name, object_name_lower = dt_nm$object_name_lower)] + dt_object[dt_nm, on = "object_id", `:=`(object_name = i.object_name, object_name_lower = i.object_name_lower)] dt_object } # }}} @@ -1384,14 +1396,44 @@ convert_value_unit <- function (idd_env, dt_value, from, to, type = "value") { } # }}} -# get_value_sources {{{ -get_value_sources <- function (dt_value, lower = FALSE) { - dt_val <- dt_value[!is.na(value_chr), list(object_id, field_id, value_id, value_chr, src_enum, class_name)] +# get_value_reference_map {{{ +get_value_reference_map <- function (idd_env, src, value, all = TRUE) { + empty <- data.table( + object_id = integer(0L), value_id = integer(0L), + src_object_id = integer(0L), src_value_id = integer(0L), + src_enum = integer(0L) + ) + + # get all values in lower case that are references {{{ + if (!has_names(value, "type_enum")) { + add_field_property(idd_env, value, "type_enum") + on.exit(set(value, NULL, "type_enum", NULL), add = TRUE) + } + val_ref <- value[!is.na(value_chr) & type_enum == IDDFIELD_TYPE$object_list, + list(object_id, value_id, value_chr = stri_trans_tolower(value_chr), field_id)] + if (!nrow(val_ref)) return(empty) + # }}} - setindexv(dt_val, "src_enum") + # get field reference map in current IDF + val_ref_map <- idd_env$reference[val_ref, on = "field_id", allow.cartesian = TRUE] + + # get all values in lower case that are sources {{{ + if (!has_names(src, "class_name")) { + add_class_name(idd_env, src) + on.exit(set(src, NULL, "class_name", NULL), add = TRUE) + } + if (!has_names(src, "src_enum")) { + add_field_property(idd_env, src, "src_enum") + on.exit(set(src, NULL, "src_enum", NULL), add = TRUE) + } + val_src <- src[!J(NA_character_), on = "value_chr", .SD, + .SDcols = c("object_id", "field_id", "value_id", "value_chr", "src_enum", "class_name") + ] + + setindexv(val_src, "src_enum") # a) reference class names - cls_src <- dt_val[J(IDDFIELD_SOURCE$class), on = "src_enum", nomatch = 0L, + cls_src <- val_src[J(IDDFIELD_SOURCE$class), on = "src_enum", nomatch = 0L, list( src_object_id = object_id, src_field_id = field_id, @@ -1402,7 +1444,7 @@ get_value_sources <- function (dt_value, lower = FALSE) { ] # b) reference field values - fld_src <- dt_val[J(IDDFIELD_SOURCE$field), on = "src_enum", nomatch = 0L, + fld_src <- val_src[J(IDDFIELD_SOURCE$field), on = "src_enum", nomatch = 0L, list( src_object_id = object_id, src_field_id = field_id, @@ -1414,7 +1456,7 @@ get_value_sources <- function (dt_value, lower = FALSE) { # c) reference both class names and field values ## seperate source enum here - mix_src <- dt_val[J(IDDFIELD_SOURCE$mixed), on = "src_enum", nomatch = 0L, + mix_src <- val_src[J(IDDFIELD_SOURCE$mixed), on = "src_enum", nomatch = 0L, { list( src_object_id = c(object_id, object_id), @@ -1428,42 +1470,8 @@ get_value_sources <- function (dt_value, lower = FALSE) { # combine val_src <- rbindlist(list(cls_src, fld_src, mix_src)) - - if (lower) set(val_src, NULL, "src_value_chr", stri_trans_tolower(val_src$src_value_chr)) - - val_src -} -# }}} - -# get_value_references {{{ -get_value_references <- function (dt_value, lower = FALSE) { - val_ref <- dt_value[ - !is.na(value_chr) & type_enum == IDDFIELD_TYPE$object_list, - list(object_id, value_id, value_chr, field_id)] - - if (lower) set(val_ref, NULL, "value_chr", stri_trans_tolower(val_ref$value_chr)) - - val_ref -} -# }}} - -# get_value_reference_map {{{ -get_value_reference_map <- function (map, src, value, all = TRUE) { - empty <- data.table( - object_id = integer(0L), value_id = integer(0L), - src_object_id = integer(0L), src_value_id = integer(0L), - src_enum = integer(0L) - ) - - # get all values in lower case that are references - val_ref <- get_value_references(value, lower = TRUE) - if (!nrow(val_ref)) return(empty) - - # get field reference map in current IDF - val_ref_map <- map[val_ref, on = "field_id", allow.cartesian = TRUE] - - # get all values in lower case that are sources - val_src <- get_value_sources(src[J(unique(val_ref_map$src_field_id)), on = "field_id", nomatch = 0L], lower = TRUE) + set(val_src, NULL, "src_value_chr", stri_trans_tolower(val_src$src_value_chr)) + # }}} # match ref <- val_ref_map[val_src, on = c(value_chr = "src_value_chr", "src_enum", "src_field_id"), @@ -1477,16 +1485,16 @@ get_value_reference_map <- function (map, src, value, all = TRUE) { # parse_issue {{{ parse_warn <- function (type = c("idf", "idd", "err", "epw"), title, data = NULL, - num = NULL, prefix = NULL, post = NULL) { - parse_issue(type, title, data, num, prefix, post, stop = FALSE) + num = NULL, prefix = NULL, post = NULL, subtype = NULL) { + parse_issue(type, title, data, num, prefix, post, stop = FALSE, subtype = subtype) } parse_error <- function (type = c("idf", "idd", "err", "epw"), title, data = NULL, - num = NULL, prefix = NULL, post = NULL) { - parse_issue(type, title, data, num, prefix, post, stop = TRUE) + num = NULL, prefix = NULL, post = NULL, subtype = NULL) { + parse_issue(type, title, data, num, prefix, post, stop = TRUE, subtype = subtype) } parse_issue <- function (type = c("idf", "idd", "err", "epw"), title, data = NULL, num = NULL, prefix = NULL, post = NULL, - stop = TRUE) { + stop = TRUE, subtype = NULL) { start_rule <- cli::rule(line = 2L) @@ -1541,10 +1549,13 @@ parse_issue <- function (type = c("idf", "idd", "err", "epw"), key <- if(stop) "ERROR" else "WARNING" all_mes <- paste0(paste0(toupper(type)," PARSING ", key, ".\n"), all_mes) + type <- paste0("parse_", type) + subtype <- if (!is.null(subtype)) paste0(type, "_", subtype) + if (stop) { - abort(all_mes, paste0("parse_", type)) + abort(all_mes, c(subtype, type), data = data) } else { - warn(all_mes, paste0("parse_", type)) + warn(all_mes, c(subtype, type), data = data) } } # }}} @@ -1553,7 +1564,7 @@ parse_issue <- function (type = c("idf", "idd", "err", "epw"), insert_version <- function (x, ver) { if (is.character(x)) { paste0(x, "Version, ", standardize_ver(ver)[, 1L:2L], ";") - } else if (inherits(x, "data.table") && has_names(x, c("line", "string"))) { + } else if (inherits(x, "data.table") && all(has_names(x, c("line", "string")))) { n <- if (!nrow(x)) 0L else max(x$line) append_dt(x, data.table(line = n + 1L, string = paste0("Version, ", standardize_ver(ver)[, 1L:2L], ";"))) } else { diff --git a/_pkgdown.yml b/_pkgdown.yml index ba2198bd5..71c5840a2 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -42,6 +42,7 @@ reference: - avail_idd - is_avail_idd - as.character.IddObject + - format.Idd - format.IddObject - title: IDF desc: Read, modify and run an EnergyPlus Input Data File (IDF) diff --git a/man/Idf.Rd b/man/Idf.Rd index 5e9854b62..d7118be0b 100644 --- a/man/Idf.Rd +++ b/man/Idf.Rd @@ -730,6 +730,9 @@ idf$to_table(class = "BuildingSurface:Detailed", group_ext = "index", wide = TRU idf$to_table(class = "BuildingSurface:Detailed", group_ext = "index", wide = TRUE, string_value = FALSE, unit = TRUE ) + +# create table for new object input +idf$to_table(class = "BuildingSurface:Detailed", init = TRUE) } @@ -1542,7 +1545,7 @@ idf$is_valid_name(c("simple one zone (wireframe dxf)", "zone one", "a")) \subsection{Method \code{object()}}{ Extract an \link{IdfObject} object using object ID or name. \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Idf$object(which)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{Idf$object(which, class = NULL)}\if{html}{\out{
}} } \subsection{Arguments}{ @@ -1550,6 +1553,10 @@ Extract an \link{IdfObject} object using object ID or name. \describe{ \item{\code{which}}{A single integer specifying the object ID or a single string specifying the object name.} + +\item{\code{class}}{A character vector that contains valid class names for +current \code{Idf} object used to locate objects. If \code{NULL}, all +classes in current \code{Idf} object are used. Default: \code{NULL}.} } \if{html}{\out{}} } @@ -2588,7 +2595,8 @@ A \code{\link[data.table:data.table]{data.table::data.table()}} of 4 columns: \item \code{class}: Character. Names of classes that input objects belong to \item \code{id}: Integer. Input object IDs \item \code{name}: Character. Input object names -\item \code{duplicated}: Logical. Whether this object is a duplication or not +\item \code{duplicate}: Integer. The IDs of objects that input objects +duplicate. If input object is not a duplication, \code{NA} is returned } } \subsection{Examples}{ @@ -3565,7 +3573,8 @@ Format \code{Idf} as a data.frame align = FALSE, all = FALSE, group_ext = c("none", "group", "index"), - force = FALSE + force = FALSE, + init = FALSE )}\if{html}{\out{}} } @@ -3624,6 +3633,11 @@ multiple classes in input. This can result in a data.table with lots of columns. But may be useful when you know that target classes have the exact same fields, e.g. \code{Ceiling:Adiabatic} and \code{Floor:Adiabatic}. Default: \code{FALSE}.} + +\item{\code{init}}{If \code{TRUE}, a table for new object input will be returned +with all values filled with defaults. In this case, \code{object} +input will be ignored. The \code{id} column will be filled with +possible new object IDs. Default: \code{FALSE}.} } \if{html}{\out{}} } @@ -3708,6 +3722,9 @@ idf$to_table(class = "BuildingSurface:Detailed", group_ext = "index", wide = TRU idf$to_table(class = "BuildingSurface:Detailed", group_ext = "index", wide = TRUE, string_value = FALSE, unit = TRUE ) + +# create table for new object input +idf$to_table(class = "BuildingSurface:Detailed", init = TRUE) } } diff --git a/man/IdfObject.Rd b/man/IdfObject.Rd index 28144bd8c..842829340 100644 --- a/man/IdfObject.Rd +++ b/man/IdfObject.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/idf_object.R +% Please edit documentation in R/idfobj.R \docType{class} \name{IdfObject} \alias{IdfObject} diff --git a/man/add_idf_object.Rd b/man/add_idf_object.Rd index d711bfecd..7a10a0ead 100644 --- a/man/add_idf_object.Rd +++ b/man/add_idf_object.Rd @@ -22,11 +22,9 @@ field, and reference.} \item{idf_env}{An environment or list contains IDF tables including object, value, and reference.} -\item{dt_object}{A \code{\link[data.table:data.table]{data.table::data.table()}} that contains object data. -Usually created using \code{\link[=expand_idf_dots_value]{expand_idf_dots_value()}}.} +\item{dt_object}{A \code{\link[data.table:data.table]{data.table::data.table()}} that contains object data.} -\item{dt_value}{A \code{\link[data.table:data.table]{data.table::data.table()}} that contains value data. -Usually created using \code{\link[=expand_idf_dots_value]{expand_idf_dots_value()}}.} +\item{dt_value}{A \code{\link[data.table:data.table]{data.table::data.table()}} that contains value data.} \item{default}{If \code{TRUE}, default values are used for those blank fields if possible. If \code{FALSE}, empty fields are kept blank. @@ -40,8 +38,12 @@ duplications in input are removed. Default: \code{FALSE}.} \item{level}{Validate level. Default: \code{eplusr_option("validate_level")}.} } \value{ -The newly added object data in a named list of 3 -\code{\link[data.table:data.table]{data.table::data.table()}}s, i.e. \code{object}, \code{value} and \code{reference}. +The modified \link{Idf} data in a named list of 5 elements, i.e. \code{object}, +\code{value}, \code{reference}, \code{changed} and \code{updated}. First 3 elements are +\code{\link[data.table:data.table]{data.table::data.table()}}s containing the actual updated \link{Idf} data while +\code{changed} and \code{updated} are integer vectors containing IDs of objects that +have been directly changed and indirectly updated due to references, +respectively. } \description{ Add new objects diff --git a/man/as.character.IdfObject.Rd b/man/as.character.IdfObject.Rd index 88bb97384..8ff943f28 100644 --- a/man/as.character.IdfObject.Rd +++ b/man/as.character.IdfObject.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/idf_object.R +% Please edit documentation in R/idfobj.R \name{as.character.IdfObject} \alias{as.character.IdfObject} \title{Coerce an IdfObject into a Character Vector} @@ -9,17 +9,6 @@ \arguments{ \item{x}{An \link{IddObject} object.} -\item{comment}{A character vector to be used as comments of returned string -format object. If \code{NULL}, no comments are inserted. Default: \code{NULL}.} - -\item{leading}{Leading spaces added to each field. Default: \code{4}.} - -\item{sep_at}{The character width to separate value string and field string. -Default: \code{29} which is the same as IDF Editor.} - -\item{all}{If \code{TRUE}, all fields in current class are returned, otherwise -only minimum fields are returned.} - \item{...}{Further arguments passed to or from other methods.} } \value{ diff --git a/man/assign_idf_value_default.Rd b/man/assign_idf_value_default.Rd new file mode 100644 index 000000000..806d08d89 --- /dev/null +++ b/man/assign_idf_value_default.Rd @@ -0,0 +1,24 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/impl-idf.R +\name{assign_idf_value_default} +\alias{assign_idf_value_default} +\title{Assign default field values} +\usage{ +assign_idf_value_default(idd_env, idf_env, dt_value) +} +\arguments{ +\item{idd_env}{An environment or list contains IDD tables including class, +field, and reference.} + +\item{idf_env}{An environment or list contains IDF tables including object, +value, and reference.} + +\item{dt_value}{A \code{\link[data.table:data.table]{data.table::data.table()}} that contains object value data.} +} +\value{ +The updated version of \code{\link[data.table:data.table]{data.table::data.table()}}. +} +\description{ +Assign default field values +} +\keyword{internal} diff --git a/man/del_idf_object.Rd b/man/del_idf_object.Rd index 660362ba5..b09932b89 100644 --- a/man/del_idf_object.Rd +++ b/man/del_idf_object.Rd @@ -22,8 +22,7 @@ field, and reference.} \item{idf_env}{An environment or list contains IDF tables including object, value, and reference.} -\item{dt_object}{A \code{\link[data.table:data.table]{data.table::data.table()}} that contains object data. -Usually created using \code{\link[=expand_idf_dots_value]{expand_idf_dots_value()}}.} +\item{dt_object}{A \code{\link[data.table:data.table]{data.table::data.table()}} that contains object data.} \item{ref_to}{If \code{TRUE}, objects whose fields are referred by input objects will also be deleted. Default: \code{FALSE}.} @@ -43,8 +42,12 @@ referred by other objects.} \item{level}{Validate level. Default: \code{eplusr_option("validate_level")}.} } \value{ -The modified whole IDF data in a named list of 3 -\code{\link[data.table:data.table]{data.table::data.table()}}s, i.e. \code{object}, \code{value} and \code{reference}. +The modified \link{Idf} data in a named list of 5 elements, i.e. \code{object}, +\code{value}, \code{reference}, \code{changed} and \code{updated}. First 3 elements are +\code{\link[data.table:data.table]{data.table::data.table()}}s containing the actual updated \link{Idf} data while +\code{changed} and \code{updated} are integer vectors containing IDs of objects that +have been directly changed and indirectly updated due to references, +respectively. } \description{ Delete existing objects diff --git a/man/dt_to_load.Rd b/man/dt_to_load.Rd index d626b9091..352e99b69 100644 --- a/man/dt_to_load.Rd +++ b/man/dt_to_load.Rd @@ -8,15 +8,15 @@ dt_to_load(dt, string_value = TRUE) } \arguments{ \item{dt}{A data.table created using \code{Idf$to_table()} and -\code{IdfObject$to_table()}. \code{dt} should at least contain column \code{id} (indicator -used to distinguish object definitions), \code{class} (class names). If a \code{name} -column exists, it will be preserved.} +\code{IdfObject$to_table()}. \code{dt} should at least contain column \code{id} +(indicator used to distinguish object definitions), \code{class} (class +names). If a \code{name} column exists, it will be preserved.} \item{string_value}{If \code{TRUE}, all value will be coerced into character and -the \code{value} column of returned \link[data.table:data.table]{datat.table} will -be character type. If \code{FALSE}, the original value will be preserved and the -\code{value} column of returned \link[data.table:data.table]{data.table} will be -list type.} +the \code{value} column of returned \link[data.table:data.table]{datat.table} +will be character type. If \code{FALSE}, the original value will be +preserved and the \code{value} column of returned +\link[data.table:data.table]{data.table} will be list type.} } \value{ A \link[data.table:data.table]{data.table} with 5 or 6 columns: @@ -47,4 +47,5 @@ dt <- idf$to_table(class = "Material", wide = TRUE) dt_to_load(dt) } + } diff --git a/man/dup_idf_object.Rd b/man/dup_idf_object.Rd index 1f77c842a..25fdab8eb 100644 --- a/man/dup_idf_object.Rd +++ b/man/dup_idf_object.Rd @@ -18,14 +18,17 @@ field, and reference.} \item{idf_env}{An environment or list contains IDF tables including object, value, and reference.} -\item{dt_object}{A \code{\link[data.table:data.table]{data.table::data.table()}} that contains object data. -Usually created using \code{\link[=expand_idf_dots_value]{expand_idf_dots_value()}}.} +\item{dt_object}{A \code{\link[data.table:data.table]{data.table::data.table()}} that contains object data.} \item{level}{Validate level. Default: \code{eplusr_option("validate_level")}.} } \value{ -The duplicated object data in a named list of 3 -\code{\link[data.table:data.table]{data.table::data.table()}}s, i.e. \code{object}, \code{value} and \code{reference}. +The modified \link{Idf} data in a named list of 5 elements, i.e. \code{object}, +\code{value}, \code{reference}, \code{changed} and \code{updated}. First 3 elements are +\code{\link[data.table:data.table]{data.table::data.table()}}s containing the actual updated \link{Idf} data while +\code{changed} and \code{updated} are integer vectors containing IDs of objects that +have been directly changed and indirectly updated due to references, +respectively. } \description{ Duplicate existing objects diff --git a/man/duplicated_idf_object.Rd b/man/duplicated_idf_object.Rd index 4cb3e7969..91b735c2d 100644 --- a/man/duplicated_idf_object.Rd +++ b/man/duplicated_idf_object.Rd @@ -13,13 +13,12 @@ field, and reference.} \item{idf_env}{An environment or list contains IDF tables including object, value, and reference.} -\item{dt_object}{A \code{\link[data.table:data.table]{data.table::data.table()}} that contains object data. -Usually created using \code{\link[=expand_idf_dots_value]{expand_idf_dots_value()}}.} +\item{dt_object}{A \code{\link[data.table:data.table]{data.table::data.table()}} that contains object data.} } \value{ A same \code{\link[data.table:data.table]{data.table::data.table()}} as input \code{dt_object} (updated by -reference) with appended logical column \code{duplicated} indicating the object is -a duplicated one or not. +reference) with appended integer column \code{unique_object_id} indicating the +object is a duplicated one of that object. } \description{ Determine duplicate objects diff --git a/man/expand_idf_regex.Rd b/man/expand_idf_regex.Rd index 30d8e2dff..8c3e620af 100644 --- a/man/expand_idf_regex.Rd +++ b/man/expand_idf_regex.Rd @@ -26,6 +26,8 @@ value, and reference.} \item{pattern}{A single string of regular expression used to match field values} +\item{class}{A character vector specifying the target class names} + \item{pattern, ignore.case, perl, fixed, useBytes}{All of them are directly passed to \link[base:grep]{base::grepl} and \link[base:grep]{base::gsub} with the same default values.} diff --git a/man/format.IddObject.Rd b/man/format.IddObject.Rd index 8b6c32277..f1279d621 100644 --- a/man/format.IddObject.Rd +++ b/man/format.IddObject.Rd @@ -4,11 +4,13 @@ \alias{format.IddObject} \title{Format an IddObject} \usage{ -\method{format}{IddObject}(x, ...) +\method{format}{IddObject}(x, ver = TRUE, ...) } \arguments{ \item{x}{An \link{IddObject} object.} +\item{ver}{If \code{TRUE}, a suffix of version string is added. Default: \code{TRUE}.} + \item{...}{Further arguments passed to or from other methods.} } \value{ diff --git a/man/format.IdfObject.Rd b/man/format.IdfObject.Rd index 211538031..0c8e5e63a 100644 --- a/man/format.IdfObject.Rd +++ b/man/format.IdfObject.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/idf_object.R +% Please edit documentation in R/idfobj.R \name{format.IdfObject} \alias{format.IdfObject} \title{Format an IdfObject} diff --git a/man/get_idd_field.Rd b/man/get_idd_field.Rd index b05910043..3f70e2648 100644 --- a/man/get_idd_field.Rd +++ b/man/get_idd_field.Rd @@ -20,18 +20,13 @@ get_idd_field( field, and reference.} \item{class}{An integer vector of valid class indexes or a character vector -of valid class names or a data.table that contains column \code{class_id} -and \code{rleid}. If a data.table that contains a column \code{object_id}, that -column will be preserved.} +of valid class names.} \item{field}{An integer vector of valid field indexes or a character vector of valid field names (can be in in underscore style). \code{class} and \code{field} should have the same length.} -\item{property}{A character vector of column names in field table to return. If -\code{NULL}, all columns from IDD field table will be returned, plus column -\code{rleid}, \code{object_id} (if applicable) and \code{matched_rleid} (if -\code{complete} is \code{TRUE}).} +\item{property}{A character vector of column names in field table to return.} \item{underscore}{If \code{TRUE}, input class name and field names will be converted into underscore style name first and column \code{class_name_us} diff --git a/man/get_idf_node_relation.Rd b/man/get_idf_node_relation.Rd new file mode 100644 index 000000000..055d9bc91 --- /dev/null +++ b/man/get_idf_node_relation.Rd @@ -0,0 +1,60 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/impl-idf.R +\name{get_idf_node_relation} +\alias{get_idf_node_relation} +\title{Extract node relations} +\usage{ +get_idf_node_relation( + idd_env, + idf_env, + object_id = NULL, + value_id = NULL, + object = NULL, + class = NULL, + group = NULL, + name = FALSE, + keep_all = FALSE, + depth = 0L +) +} +\arguments{ +\item{idd_env}{An environment or list contains IDD tables including class, +field, and reference.} + +\item{idf_env}{An environment or list contains IDF tables including object, +value, and reference.} + +\item{object_id}{An integer vector of valid object IDs. If \code{NULL}, all object +IDs in current IDF will be used.} + +\item{value_id}{An integer vector of valid value IDs. If \code{NULL}, all value +IDs in current IDF will be used.} + +\item{object}{An integer vector of valid object IDs or a character vector +of valid object names to specify the targeting relation objects. +Default: \code{NULL}.} + +\item{class}{An integer vector of valid class indexes or a character vector +of valid class names to specify the targeting relation classes. +Default: \code{NULL}.} + +\item{group}{A character vector of valid group names to specify the targeting +relation groups. Default: \code{NULL}.} + +\item{name}{If \code{TRUE}, all class, object, field value ID and name columns +will be added and a \code{IdfRelationTo} or \code{IdfRelationBy} object is +returned with customized printing method. Default: \code{FALSE}.} + +\item{keep_all}{If \code{TRUE}, all input ID are kept. Otherwise, only input IDs +that have relations are kept. Default: \code{FALSE}.} + +\item{depth}{Recursive reference relation depth. \code{NULL} means infinite. +Default: \code{0L}.} +} +\value{ +A data.table. +} +\description{ +Extract node relations +} +\keyword{internal} diff --git a/man/get_object_info.Rd b/man/get_object_info.Rd new file mode 100644 index 000000000..0db53d77d --- /dev/null +++ b/man/get_object_info.Rd @@ -0,0 +1,46 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/impl-idf.R +\name{get_object_info} +\alias{get_object_info} +\title{Format object information string} +\usage{ +get_object_info( + dt_object, + component = c("id", "name", "class"), + by_class = FALSE, + numbered = TRUE, + collapse = NULL, + prefix = NULL, + name_prefix = TRUE +) +} +\arguments{ +\item{dt_object}{A \code{\link[data.table:data.table]{data.table::data.table()}} of object data} + +\item{component}{A character vector specifying what information to be +formatted. Should be a subset of \code{"id"}, \code{"name"} and \code{"class"}. +Defaults are all of them.} + +\item{by_class}{If \code{TRUE}, multiple objects in the same class will be +concatenated. Default: \code{FALSE}.} + +\item{numbered}{If \code{TRUE}, a index number will be prepended. If \code{rleid} +column exists in \code{dt_object}, its values will be used as the index +numbers.} + +\item{collapse}{A single string used to collapse the results into a single +string. Default: \code{NULL}.} + +\item{prefix}{A character vector used to add at the beginning of object +information. Default: \code{NULL}.} + +\item{name_prefix}{If \code{TRUE}, Default: \code{TRUE}.} +} +\value{ +A character vector of the same length as the row number of input +\code{dt_object} if \code{collapse} is \code{NULL}. Otherwise a single string. +} +\description{ +Format object information string +} +\keyword{internal} diff --git a/man/idf_object.Rd b/man/idf_object.Rd index 352a5e0b2..31a957752 100644 --- a/man/idf_object.Rd +++ b/man/idf_object.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/idf_object.R +% Please edit documentation in R/idfobj.R \name{idf_object} \alias{idf_object} \title{Create an \code{IdfObject} object.} diff --git a/man/make_idf_object_name.Rd b/man/make_idf_object_name.Rd index 36c5df3c2..ab288b5cb 100644 --- a/man/make_idf_object_name.Rd +++ b/man/make_idf_object_name.Rd @@ -12,7 +12,7 @@ make_idf_object_name( prefix_col = NULL, prefix_sep = " ", keep_na = TRUE, - inclu_ori = FALSE + include_ori = FALSE ) } \arguments{ @@ -38,7 +38,7 @@ prefix columns. Default: \code{NULL}.} \item{keep_na}{If \code{TRUE}, new object names will be \code{NA} if the original object names in column \code{object_name} are \code{NA}s. Default: \code{TRUE}.} -\item{inclu_ori}{If \code{TRUE}, make sure new object names are not the same as +\item{include_ori}{If \code{TRUE}, make sure new object names are not the same as the original object names in the \code{object_name} column. Default: \code{FALSE}.} } \value{ diff --git a/man/purge_idf_object.Rd b/man/purge_idf_object.Rd index 7c35f8841..ea6f49440 100644 --- a/man/purge_idf_object.Rd +++ b/man/purge_idf_object.Rd @@ -13,14 +13,15 @@ field, and reference.} \item{idf_env}{An environment or list contains IDF tables including object, value, and reference.} -\item{dt_object}{A \code{\link[data.table:data.table]{data.table::data.table()}} that contains object data. -Usually created using \code{\link[=expand_idf_dots_value]{expand_idf_dots_value()}}.} - -\item{level}{Validate level. Default: \code{eplusr_option("validate_level")}.} +\item{dt_object}{A \code{\link[data.table:data.table]{data.table::data.table()}} that contains object data.} } \value{ -The modified whole IDF data in a named list of 3 -\code{\link[data.table:data.table]{data.table::data.table()}}s, i.e. \code{object}, \code{value} and \code{reference}. +The modified \link{Idf} data in a named list of 5 elements, i.e. \code{object}, +\code{value}, \code{reference}, \code{changed} and \code{updated}. First 3 elements are +\code{\link[data.table:data.table]{data.table::data.table()}}s containing the actual updated \link{Idf} data while +\code{changed} and \code{updated} are integer vectors containing IDs of objects that +have been directly changed and indirectly updated due to references, +respectively. } \description{ Purge not-used resource objects diff --git a/man/remove_duplicated_objects.Rd b/man/remove_duplicated_objects.Rd new file mode 100644 index 000000000..2253f2501 --- /dev/null +++ b/man/remove_duplicated_objects.Rd @@ -0,0 +1,27 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/impl-idf.R +\name{remove_duplicated_objects} +\alias{remove_duplicated_objects} +\title{Remove duplicated objects in inputs} +\usage{ +remove_duplicated_objects(idd_env, idf_env, dt_object, dt_value) +} +\arguments{ +\item{idd_env}{An environment or list contains IDD tables including class, +field, and reference.} + +\item{idf_env}{An environment or list contains IDF tables including object, +value, and reference.} + +\item{dt_object}{A \code{\link[data.table:data.table]{data.table::data.table()}} that contains object data.} + +\item{dt_value}{A \code{\link[data.table:data.table]{data.table::data.table()}} that contains value data.} +} +\value{ +The modified input data in a named list of 2 +\code{\link[data.table:data.table]{data.table::data.table()}}s, i.e. \code{object} and \code{value}. +} +\description{ +Remove duplicated objects in inputs +} +\keyword{internal} diff --git a/man/remove_empty_fields.Rd b/man/remove_empty_fields.Rd new file mode 100644 index 000000000..29d0c3894 --- /dev/null +++ b/man/remove_empty_fields.Rd @@ -0,0 +1,24 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/impl-idf.R +\name{remove_empty_fields} +\alias{remove_empty_fields} +\title{Remove trailing empty object fields} +\usage{ +remove_empty_fields(idd_env, idf_env, dt_value) +} +\arguments{ +\item{idd_env}{An environment or list contains IDD tables including class, +field, and reference.} + +\item{idf_env}{An environment or list contains IDF tables including object, +value, and reference.} + +\item{dt_value}{A \code{\link[data.table:data.table]{data.table::data.table()}} that contains value data.} +} +\value{ +A \code{\link[data.table:data.table]{data.table::data.table()}} +} +\description{ +Remove trailing empty object fields +} +\keyword{internal} diff --git a/man/rename_idf_object.Rd b/man/rename_idf_object.Rd index 4da636993..29b43a7b0 100644 --- a/man/rename_idf_object.Rd +++ b/man/rename_idf_object.Rd @@ -18,26 +18,19 @@ field, and reference.} \item{idf_env}{An environment or list contains IDF tables including object, value, and reference.} -\item{dt_object}{A \code{\link[data.table:data.table]{data.table::data.table()}} that contains object data. -Usually created using \code{\link[=expand_idf_dots_name]{expand_idf_dots_name()}}.} +\item{dt_object}{A \code{\link[data.table:data.table]{data.table::data.table()}} that contains object data.} \item{level}{Validate level. Default: \code{eplusr_option("validate_level")}.} } \value{ -The modified object data in a named list of 3 -\code{\link[data.table:data.table]{data.table::data.table()}}s, i.e. \code{object}, \code{value}, \code{reference}. +The modified \link{Idf} data in a named list of 5 elements, i.e. \code{object}, +\code{value}, \code{reference}, \code{changed} and \code{updated}. First 3 elements are +\code{\link[data.table:data.table]{data.table::data.table()}}s containing the actual updated \link{Idf} data while +\code{changed} and \code{updated} are integer vectors containing IDs of objects that +have been directly changed and indirectly updated due to references, +respectively. } \description{ Rename existing objects } -\note{ -\itemize{ -\item The \code{reference} table in the returned list only contains the reference-by -map, indicating which values have been updated in the main \code{value} table in -\code{idf_env}. -\item The \code{value} table in input \code{idf_env} could be modified if input objects are -referenced by other objects. The \code{reference} table in the returned list -tells the id actual values modified -} -} \keyword{internal} diff --git a/man/set_idf_object.Rd b/man/set_idf_object.Rd index d8bf23d0d..7cb9c2944 100644 --- a/man/set_idf_object.Rd +++ b/man/set_idf_object.Rd @@ -20,20 +20,21 @@ field, and reference.} \item{idf_env}{An environment or list contains IDF tables including object, value, and reference.} -\item{dt_object}{A \code{\link[data.table:data.table]{data.table::data.table()}} that contains object data. -Usually created using \code{\link[=expand_idf_dots_value]{expand_idf_dots_value()}}.} +\item{dt_object}{A \code{\link[data.table:data.table]{data.table::data.table()}} that contains object data.} -\item{dt_value}{A \code{\link[data.table:data.table]{data.table::data.table()}} that contains value data. -Usually created using \code{\link[=expand_idf_dots_value]{expand_idf_dots_value()}}.} +\item{dt_value}{A \code{\link[data.table:data.table]{data.table::data.table()}} that contains value data.} -\item{empty}{If \code{FALSE}, not required empty fields will be removed. -Default: \code{FALSE}.} +\item{empty}{If \code{TRUE}, trailing empty fields are kept. Default: \code{FALSE}.} \item{level}{Validate level. Default: \code{eplusr_option("validate_level")}.} } \value{ -The modified object data in a named list of 3 -\code{\link[data.table:data.table]{data.table::data.table()}}s, i.e. \code{object}, \code{value} and \code{reference}. +The modified \link{Idf} data in a named list of 5 elements, i.e. \code{object}, +\code{value}, \code{reference}, \code{changed} and \code{updated}. First 3 elements are +\code{\link[data.table:data.table]{data.table::data.table()}}s containing the actual updated \link{Idf} data while +\code{changed} and \code{updated} are integer vectors containing IDs of objects that +have been directly changed and indirectly updated due to references, +respectively. } \description{ Modifying existing objects diff --git a/man/unique_idf_object.Rd b/man/unique_idf_object.Rd index 6f92c7d60..1cc183c57 100644 --- a/man/unique_idf_object.Rd +++ b/man/unique_idf_object.Rd @@ -13,12 +13,15 @@ field, and reference.} \item{idf_env}{An environment or list contains IDF tables including object, value, and reference.} -\item{dt_object}{A \code{\link[data.table:data.table]{data.table::data.table()}} that contains object data. -Usually created using \code{\link[=expand_idf_dots_value]{expand_idf_dots_value()}}.} +\item{dt_object}{A \code{\link[data.table:data.table]{data.table::data.table()}} that contains object data.} } \value{ -The modified whole IDF data in a named list of 3 -\code{\link[data.table:data.table]{data.table::data.table()}}s, i.e. \code{object}, \code{value} and \code{reference}. +The modified \link{Idf} data in a named list of 5 elements, i.e. \code{object}, +\code{value}, \code{reference}, \code{changed} and \code{updated}. First 3 elements are +\code{\link[data.table:data.table]{data.table::data.table()}}s containing the actual updated \link{Idf} data while +\code{changed} and \code{updated} are integer vectors containing IDs of objects that +have been directly changed and indirectly updated due to references, +respectively. } \description{ Remove duplicate objects diff --git a/tests/testthat/test_idd.R b/tests/testthat/test-idd.R similarity index 100% rename from tests/testthat/test_idd.R rename to tests/testthat/test-idd.R diff --git a/tests/testthat/test_iddobj.R b/tests/testthat/test-iddobj.R similarity index 100% rename from tests/testthat/test_iddobj.R rename to tests/testthat/test-iddobj.R diff --git a/tests/testthat/test_idf.R b/tests/testthat/test-idf.R similarity index 55% rename from tests/testthat/test_idf.R rename to tests/testthat/test-idf.R index 56bea3035..39539855d 100644 --- a/tests/testthat/test_idf.R +++ b/tests/testthat/test-idf.R @@ -1,20 +1,50 @@ -context("Idf") +context("Idf class") -# Idf class{{{ -test_that("Idf class", { - eplusr_option(verbose_info = FALSE) - if (!is_avail_eplus(8.8)) install_eplus(8.8) +eplusr_option(verbose_info = FALSE) +if (!is_avail_eplus(8.8)) install_eplus(8.8) +# NEW {{{ +test_that("$new()", { # can create new Idf object from string - expect_silent(idf <- read_idf(text("idf", 8.8))) + expect_is(idf <- read_idf(text("idf", 8.8)), "Idf") + + priv <- get_priv_env(idf) + + expect_null(priv$m_path) + expect_is(priv$m_version, "numeric_version") + expect_is(priv$m_idd, "Idd") + expect_is(priv$m_idf_env, "environment") + expect_is(priv$m_log, "environment") + + expect_is(priv$m_log$uuid, "character") + expect_false(priv$m_log$unsaved) + expect_false(priv$m_log$view_in_ip) + expect_equal(priv$m_log$save_format, "sorted") +}) +# }}} + +# VERSION {{{ +test_that("$version()", { + expect_is(idf <- read_idf(text("idf", 8.8)), "Idf") - # Basic {{{ - # can get version expect_equal(idf$version(), as.numeric_version("8.8.0")) +}) +# }}} - # can get path +# PATH {{{ +test_that("$path()", { + expect_is(idf <- read_idf(text("idf", 8.8)), "Idf") expect_equal(idf$path(), NULL) + expect_is(idf <- read_idf(example()), "Idf") + expect_equal(basename(idf$path()), "1ZoneUncontrolled.idf") +}) +# }}} + +# GROUP_NAME {{{ +test_that("$group_name()", { + expect_is(idf <- read_idf(text("idf", 8.8)), "Idf") + # can get group names in Idf expect_equal(idf$group_name(), c("Simulation Parameters", "Surface Construction Elements", "Thermal Zones and Surfaces")) @@ -30,6 +60,12 @@ test_that("Idf class", { # can get group names in Idd expect_equal(idf$group_name(all = TRUE), use_idd(8.8)$group_name()) +}) +# }}} + +# CLASS_NAME {{{ +test_that("$class_name()", { + expect_is(idf <- read_idf(text("idf", 8.8)), "Idf") # can get class names in Idf expect_equal(idf$class_name(sorted = FALSE), @@ -42,6 +78,26 @@ test_that("Idf class", { # can get class names in Idd expect_equal(idf$class_name(all = TRUE), use_idd(8.8)$class_name()) + # can get class names by group + expect_equal(length(idf$class_name(all = TRUE, by_group = TRUE)), 58) + + # can get class names by group + expect_equal(idf$class_name(by_group = TRUE), + list(`Simulation Parameters` = "Version", + `Surface Construction Elements` = c("Material", "Construction"), + `Thermal Zones and Surfaces` = "BuildingSurface:Detailed") + ) + + # by_group only works when sorted is TRUE + expect_equal(idf$class_name(sorted = FALSE, by_group = TRUE), + c("Material", "Construction", "BuildingSurface:Detailed", "Material", "Version")) +}) +# }}} + +# OBJECT_ID {{{ +test_that("$object_id()", { + expect_is(idf <- read_idf(text("idf", 8.8)), "Idf") + # can get all object ids expect_equal(idf$object_id(), list(Version = 5L, Material = c(1L, 4L), Construction = 2L, @@ -51,6 +107,12 @@ test_that("Idf class", { # can get all object ids of a single class expect_equal(idf$object_id("Version"), list(Version = 5L)) expect_equal(idf$object_id("Version", simplify = TRUE), 5L) +}) +# }}} + +# OBJECT_NAME {{{ +test_that("$object_name()", { + expect_is(idf <- read_idf(text("idf", 8.8)), "Idf") # can get object names expect_equal(idf$object_name(), list(Version = NA_character_, Material = c("WD01", "WD02"), @@ -60,128 +122,286 @@ test_that("Idf class", { list(Material = c("WD01", "WD02"), Construction = "WALL-1")) expect_equal(idf$object_name(c("Material", "Construction"), simplify = TRUE), c("WD01", "WD02", "WALL-1")) +}) +# }}} + +# OBJECT_NUM {{{ +test_that("$object_num()", { + expect_is(idf <- read_idf(text("idf", 8.8)), "Idf") # can get object num expect_equal(idf$object_num(), 5L) expect_equal(idf$object_num(c("Version", "Construction")), c(1L, 1L)) expect_equal(idf$object_num(1), 1L) +}) +# }}} - expect_is(idf$object_relation(2), "IdfRelation") - # }}} +# IS_VALID_GROUP {{{ +test_that("$is_valid_group()", { + expect_is(idf <- read_idf(text("idf", 8.8)), "Idf") - # ASSERTION {{{ # can check invalid group name expect_true(idf$is_valid_group("Simulation Parameters")) expect_false(idf$is_valid_group("Simulation_Parameters")) +}) +# }}} + +# IS_VALID_CLASS {{{ +test_that("$is_valid_class()", { + expect_is(idf <- read_idf(text("idf", 8.8)), "Idf") # can check invalid class name expect_true(idf$is_valid_class("Version")) expect_false(idf$is_valid_class("version")) +}) +# }}} + +# IS_VALID_ID {{{ +test_that("$is_valid_id()", { + expect_is(idf <- read_idf(text("idf", 8.8)), "Idf") # can check invalid object ID expect_true(idf$is_valid_id(1L)) expect_false(idf$is_valid_id(6L)) expect_equal(idf$is_valid_id(1L:4L), rep(TRUE, times = 4L)) expect_error(idf$is_valid_id("1")) +}) +# }}} + +# IS_VALID_NAME {{{ +test_that("$is_valid_name()", { + expect_is(idf <- read_idf(text("idf", 8.8)), "Idf") # can check invalid object name expect_true(idf$is_valid_name("WD01")) expect_true(idf$is_valid_name("wd01")) - expect_false(idf$is_valid_name(NA_character_)) + expect_error(idf$is_valid_name(NA_character_)) expect_equal(idf$is_valid_name(c("wd01", "WALL-1")), c(TRUE, TRUE)) +}) +# }}} + +# IS_UNSAVED {{{ +test_that("$is_unsaved()", { + expect_is(idf <- read_idf(text("idf", 8.8)), "Idf") # can check if model has been changed since read expect_false(idf$is_unsaved()) - # }}} +}) +# }}} + +# DEFINITION {{{ +test_that("$definition()", { + expect_is(idf <- read_idf(text("idf", 8.8)), "Idf") - # OBJECT {{{ # can get Idd expect_is(idf$definition(), "Idd") # can get IddObject expect_is(idf$definition("Version"), "IddObject") +}) +# }}} + +# OBJECT {{{ +test_that("$object()", { + expect_is(idf <- read_idf(text("idf", 8.8)), "Idf") # can get IdfObject expect_is(idf$object(1), "IdfObject") - expect_error(idf$object(1:2), class = "error_not_scalar") + + # can stop if multiple inputs + expect_error(idf$object(1:2), "Assertion") +}) +# }}} + +# OBJECT_UNIQUE {{{ +test_that("$object_unique()", { + expect_is(idf <- read_idf(text("idf", 8.8)), "Idf") + + # can stop if not a unique-class name + expect_error(idf$object_unique("Material")) + + # can stop if multiple objects in unique class found + expect_silent( + idf <- with_option( + list(validate_level = "none", verbose_info = FALSE), + { + idf <- empty_idf(8.8) + idf$add(Building = list(), Building = list()) + idf + } + ) + ) + expect_error(idf$object_unique("Building"), class = "eplusr_error") +}) +# }}} + +# OBJECTS {{{ +test_that("$objects()", { + expect_is(idf <- read_idf(text("idf", 8.8)), "Idf") + expect_equal(names(idf$objects("WD01")), "WD01") - expect_equal(names(idf$objects("WALL-1")), "WALL-1") + + # can ignore cases + expect_equal(names(idf$objects("wall-1")), "WALL-1") + expect_is(idf$objects(1:2), "list") - expect_error(idf$objects("a"), class = "error_object_name_lower") - expect_error(idf$objects(1:6), class = "error_object_id") + expect_error(idf$objects("a"), class = "eplusr_error_invalid_object_name") + expect_error(idf$objects(1:6), class = "eplusr_error_invalid_object_id") +}) +# }}} + +# OBJECTS_IN_CLASS {{{ +test_that("$objects_in_class()", { + expect_is(idf <- read_idf(text("idf", 8.8)), "Idf") # can get all objects in a class - expect_error(idf$objects_in_class("version"), class = "error_class_name") + expect_error(idf$objects_in_class("version"), class = "eplusr_error_invalid_class_name") + expect_is(idf$objects_in_class("Version"), "list") +}) +# }}} - # can get all objects in relation - expect_is(idf$objects_in_relation(2), "list") - expect_equal(names(idf$objects_in_relation(2)), c("WALL-1", "WD01")) - expect_is(idf$objects_in_relation("WALL-1", "ref_by"), "list") - expect_equal(names(idf$objects_in_relation("WALL-1", "ref_by")), c("WALL-1", "WALL-1PF")) +# OBJECTS_IN_GROUP {{{ +test_that("$objects_in_group()", { + expect_is(idf <- read_idf(text("idf", 8.8)), "Idf") - # can get objects using "[" and "$" - expect_is(idf$Version, "IdfObject") - expect_equal(names(idf$Material), c("WD01", "WD02")) - expect_equal(names(idf[["Material"]]), c("WD01", "WD02")) + # can get all objects in a group + expect_error(idf$objects_in_group("Schedules"), class = "eplusr_error_invalid_group_name") + expect_is(idf$objects_in_group("Simulation Parameters"), "list") +}) +# }}} - # can search object - expect_silent(nm <- names(idf$search_object("W"))) - expect_equal(nm, c("WD01", "WALL-1", "WALL-1PF", "WD02")) - expect_equal(names(idf$search_object("W")), c("WD01", "WALL-1", "WALL-1PF", "WD02")) - expect_equal(idf$search_object("ma;ldk"), NULL) +# OBJECT_RELATION {{{ +test_that("$object_relation()", { + expect_is(idf <- read_idf(text("idf", 8.8)), "Idf") + expect_is(idf$object_relation(2), "IdfRelation") - # }}} + idf_1 <- read_idf(file.path(eplus_config(8.8)$dir, "ExampleFiles/5Zone_Transformer.idf")) + + # default only include both objects that are both referenced by their field + # value and class names + ref <- idf_1$object_relation(idf_1$Branch[[1]]$id(), direction = "ref_to") + expect_equal(nrow(ref$ref_to), 8L) + expect_equal(unique(ref$ref_to$src_object_name), + c("OA Sys 1", "Main Cooling Coil 1", "Main Heating Coil 1", "Supply Fan 1") + ) + + # can exclude all class-name-reference + ref <- idf_1$object_relation(idf_1$Branch[[1]]$id(), direction = "ref_to", class_ref = "none") + expect_equal(nrow(ref$ref_to), 4L) + expect_equal(unique(ref$ref_to$src_object_name), + c("OA Sys 1", "Main Cooling Coil 1", "Main Heating Coil 1", "Supply Fan 1") + ) + + # can include all possible objects that are class-name-referenced + ref <- idf_1$object_relation(idf_1$Branch[[1]]$id(), direction = "ref_to", class_ref = "all") + expect_equal(nrow(ref$ref_to), 15L) + expect_equal(unique(ref$ref_to$src_object_name), + c( + "OA Sys 1", + "OA Cooling Coil 1", + "Main Cooling Coil 1", + "SPACE1-1 Zone Coil", + "SPACE2-1 Zone Coil", + "SPACE3-1 Zone Coil", + "SPACE4-1 Zone Coil", + "SPACE5-1 Zone Coil", + "OA Heating Coil 1", + "Main Heating Coil 1", + "Supply Fan 1" + ) + ) +}) +# }}} + +# OBJECTS_IN_RELATION {{{ +test_that("$objects_in_relation()", { + expect_is(idf <- read_idf(text("idf", 8.8)), "Idf") + + expect_is(obj <- idf$objects_in_relation(2), "list") + expect_equal(length(obj), 2L) + expect_equal(names(obj), c("WALL-1", "WD01")) + + expect_message(with_option(list(verbose_info = TRUE), obj <- idf$objects_in_relation(1)), "does not refer to") + expect_message(with_option(list(verbose_info = TRUE), obj <- idf$objects_in_relation(1, class = "Material")), "does not refer to") + expect_equal(length(obj), 1L) + expect_equal(names(obj), "WD01") + + expect_is(obj <- idf$objects_in_relation("WALL-1", "ref_by"), "list") + expect_equal(names(obj), c("WALL-1", "WALL-1PF")) +}) +# }}} + +# SEARCH_OBJECT {{{ +test_that("$search_object()", { + expect_is(idf <- read_idf(text("idf", 8.8)), "Idf") + + expect_error(idf$search_object("W", class = rep("Version", 2))) + + expect_is(obj <- idf$search_object("W"), "list") + expect_equal(names(obj), c("WD01", "WALL-1", "WALL-1PF", "WD02")) + + expect_equal(names(idf$search_object("W", class = "Material")), c("WD01", "WD02")) + + expect_equal(idf$search_object("AAA"), NULL) +}) +# }}} + +# DUP {{{ +test_that("$dup()", { + expect_is(idf <- read_idf(text("idf", 8.8)), "Idf") - # DUPLICATE {{{ # can duplicate objects and assign new names expect_equal(names(idf$dup("WD01-DUP" = "WD01")), "WD01-DUP") expect_equal(idf$object(6)$name(), "WD01-DUP") expect_equal(idf$object("WD01-DUP")$value(2:5), idf$object("WD01")$value(2:5)) - expect_equal(idf$dup("WD01")[[1L]]$name(), "WD01_1") - expect_error(idf$dup("WD01" = "WD01-DUP"), class = "error_validity") - expect_equal(names(idf$dup(rep("WD01", times = 10L))), - paste0("WD01_", 2:11)) - # }}} + expect_equal(idf$dup("WD01")[[1L]]$name(), "WD01 1") + expect_error(idf$dup("WD01" = "WD01-DUP"), class = "eplusr_error_conflict_name") + expect_equal(names(idf$dup(rep("WD01", times = 10L))), paste0("WD01 ", 2:11)) +}) +# }}} + +# ADD {{{ +test_that("$add()", { + expect_is(idf <- read_idf(text("idf", 8.8)), "Idf") - # ADD {{{ # invalid value input format - expect_error(idf$add("Material" = list(name = "mat"), "Construction"), class = "error_dot_invalid_format") - expect_error(idf$add("Material" = character(0)), class = "error_dot_invalid_format") - expect_error(idf$add("Material" = list()), class = "error_validity") - expect_error(idf$add(Material = list(list())), class = "error_dot_invalid_format") - expect_error(idf$add("Material" = list(list(name = "mat"))), class = "error_dot_invalid_format") - expect_error(idf$add(list("Material" = list(), Construction = NULL)), class = "error_dot_invalid_format") - expect_error(idf$add("Material" = character(), "Construction" = list()), class = "error_dot_invalid_format") - expect_error(idf$add("Material" = list(list(1))), class = "error_dot_invalid_format") + expect_error(idf$add("Material" = list(name = "mat"), "Construction")) + expect_error(idf$add("Material" = character(0))) + expect_error(idf$add("Material" = list())) + expect_error(idf$add(Material = list(list()))) + expect_error(idf$add("Material" = list(list(name = "mat")))) + expect_error(idf$add(list("Material" = list(), Construction = NULL))) + expect_error(idf$add("Material" = character(), "Construction" = list())) + expect_error(idf$add("Material" = list(list(1)))) # invalid comment input format - expect_error(idf$add("Material" = list(.comment = "a")), class = "error_validity") - expect_error(idf$add("Material" = list(.comment = character(0))), class = "error_validity") + expect_error(idf$add("Material" = list(.comment = "a"))) + expect_error(idf$add("Material" = list(.comment = character(0)))) # mixed named and unnamed - expect_error(idf$add("Material" = list(name = "rough", "rough")), class = "error_validity") + expect_error(idf$add("Material" = list(name = "rough", "rough"))) # duplicated field names - expect_error(idf$add("Material" = list(name = "a", name = "a")), class = "error_dot_dup_field_name") + expect_error(idf$add("Material" = list(name = "a", name = "a"))) # adding existing unique - expect_error(idf$add("Version" = list(8)), class = "error_add_version") + expect_error(idf$add("Version" = list(8))) expect_silent(idf_full <- read_idf(example())) - expect_error(idf_full$add("Building" = list()), class = "error_add_unique") + expect_error(idf_full$add("Building" = list())) # adding empty object - expect_silent(idf$add("Building" = list())) + expect_is(idf$add("Building" = list())[[1L]], "IdfObject") # invalid field number - expect_error(idf$add("Output:Variable" = list("a", "b", "c", "d", "e")), class = "error_bad_field_index") + expect_error(idf$add("Output:Variable" = list("a", "b", "c", "d", "e")), class = "eplusr_error_invalid_field_index") # invalid field names # (a) non-extensible classes - expect_error(idf$add("Material" = list(wrong = "Rough")), class = "error_bad_field_name") + expect_error(idf$add("Material" = list(wrong = "Rough")), class = "eplusr_error_invalid_field_name") # (b) extensible classes - expect_error(idf$add("Schedule:Week:Compact" = list(DayType_List_6 = "day6")), class = "error_validity") - expect_error(idf$add("SurfaceProperty:HeatTransferAlgorithm:SurfaceList" = list(Name = "algo", Wrong = "Rough")), class = "error_bad_field_name") - expect_error(idf$add("SurfaceProperty:HeatTransferAlgorithm:SurfaceList" = list(Name = "algo", Surface_Name_8 = "Rough")), class = "error_bad_field_name") - expect_error(idf$add("Schedule:Week:Compact" = list(DayType_List_7 = "day7", Schedule_Day_Name_6 = "sch6")), class = "error_validity") - expect_error(idf$add("SurfaceProperty:HeatTransferAlgorithm:SurfaceList" = list(Surface_Name_8 = "surf8", Surface_Name_20 = "surf20")), class = "error_bad_field_name") - expect_error(idf$add("Schedule:Week:Compact" = list(DayType_List_8 = "day8", Schedule_Day_Name_8 = "sch8")), class = "error_validity") + expect_error(idf$add("Schedule:Week:Compact" = list(DayType_List_6 = "day6")), class = "eplusr_error_validity_check") + expect_error(idf$add("SurfaceProperty:HeatTransferAlgorithm:SurfaceList" = list(Name = "algo", Wrong = "Rough")), class = "eplusr_error_invalid_field_name") + expect_error(idf$add("SurfaceProperty:HeatTransferAlgorithm:SurfaceList" = list(Name = "algo", Surface_Name_8 = "Rough")), class = "eplusr_error_invalid_field_name") + expect_error(idf$add("Schedule:Week:Compact" = list(DayType_List_7 = "day7", Schedule_Day_Name_6 = "sch6")), class = "eplusr_error_validity_check") + expect_error(idf$add("SurfaceProperty:HeatTransferAlgorithm:SurfaceList" = list(Surface_Name_8 = "surf8", Surface_Name_20 = "surf20")), class = "eplusr_error_invalid_field_name") + expect_error(idf$add("Schedule:Week:Compact" = list(DayType_List_8 = "day8", Schedule_Day_Name_8 = "sch8")), class = "eplusr_error_validity_check") expect_equal(use_idd(8.8)$SurfaceProperty_HeatTransferAlgorithm_SurfaceList$num_fields(), 8L) expect_equal(use_idd(8.8)$Schedule_Week_Compact$num_fields(), 17L) @@ -226,102 +446,96 @@ test_that("Idf class", { ) # can stop adding objects if trying to add a object with same name - expect_error(idf$add(RunPeriod = list("rp_test_1", 1, 1, 2, 1)), class = "error_validity") - # }}} + expect_error(idf$add(RunPeriod = list("rp_test_1", 1, 1, 2, 1)), class = "eplusr_error_validity_check") +}) +# }}} + +# SET {{{ +test_that("$set()", { + expect_is(idf <- read_idf(example()), "Idf") - # SET {{{ # set new values and comments - # name conflict - expect_error( - idf$set("rp_test_1" = list(name = "rp_test_3", begin_day_of_month = 2, - .comment = c(format(Sys.Date()), "begin day has been changed.")) - ), - class = "error_validity" - ) - expect_silent( - idf$set("rp_test_1" = list(name = "rp_test_4", begin_day_of_month = 2, + expect_is(class = "list", + idf$set(..8 = list(name = "rp_test", begin_day_of_month = 2, + use_weather_file_rain_indicators = "no", .comment = c("begin day has been changed.")) ) ) - expect_equal(idf$RunPeriod$rp_test_4$Begin_Day_of_Month, 2L) - expect_equal(idf$RunPeriod$rp_test_4$comment(), "begin day has been changed.") - # can delete fields - expect_silent( - idf$set(rp_test_4 = list( + expect_equal(idf$RunPeriod$rp_test$Begin_Day_of_Month, 2L) + expect_equal(idf$RunPeriod$rp_test$Use_Weather_File_Rain_Indicators, "no") + expect_equal(idf$RunPeriod$rp_test$comment(), "begin day has been changed.") + + # can set default values + expect_is(class = "list", + idf$set(rp_test = list( use_weather_file_rain_indicators = NULL, use_weather_file_snow_indicators = NULL )) ) - expect_equal(idf$RunPeriod$rp_test_4$Use_Weather_File_Rain_Indicators, "Yes") - expect_equal(idf$RunPeriod$rp_test_4$Use_Weather_File_Snow_Indicators, "Yes") - expect_error( - idf$set(rp_test_4 = list( - Number_of_Times_Runperiod_to_be_Repeated = NULL, - Number_of_Times_Runperiod_to_be_Repeated = NULL, - Increment_Day_of_Week_on_repeat = NULL - )) - ) - expect_silent( - idf$set(rp_test_4 = list( + expect_equal(length(idf$RunPeriod$rp_test$value()), 11) + expect_equal(idf$RunPeriod$rp_test$Use_Weather_File_Rain_Indicators, "Yes") + + # can remove trailing empty fields + expect_is(class = "list", + idf$set(rp_test = list( Number_of_Times_Runperiod_to_be_Repeated = NULL, Increment_Day_of_Week_on_repeat = NULL ), .default = FALSE) ) - expect_equal(length(idf$RunPeriod$rp_test_4$value()), 11) - expect_silent( - idf$set(rp_test_4 = list(start_year = NULL), .default = FALSE, .empty = TRUE) + expect_equal(length(idf$RunPeriod$rp_test$value()), 11) + + # can keep trailing empty fields + expect_is(class = "list", + idf$set(rp_test = list(start_year = NULL), .default = FALSE, .empty = TRUE) ) - expect_equal(length(idf$RunPeriod$rp_test_4$value()), 14) - expect_silent( - idf$set(rp_test_4 = list(start_year = NULL), .default = FALSE, .empty = FALSE) + expect_equal(length(idf$RunPeriod$rp_test$value()), 14) + + # can set all values in a class + expect_is(class = "list", + idf$set( + RunPeriod := list(start_year = NULL), + Material_NoMass := list(roughness = "Rough") + ) ) - expect_equal(length(idf$RunPeriod$rp_test_4$value()), 11) - # }}} + expect_equal(idf$Material_NoMass$R13LAYER$Roughness, "Rough") + expect_equal(idf$Material_NoMass$R31LAYER$Roughness, "Rough") - # INSERT {{{ - expect_error(idf$insert(list()), class = "error_wrong_type") - expect_silent(idf$insert(idf_full$Material_NoMass$R13LAYER)) - expect_equal(idf$object_name("Material:NoMass", simplify = TRUE), "R13LAYER") - expect_equal(idf_full$Material_NoMass$R13LAYER$value(simplify = TRUE), - c("R13LAYER", "Rough", "2.290965", "0.9", "0.75", "0.75") + # can set multiple objects + expect_is(class = "list", + idf$set(c(12, 13) := list(roughness = c("VeryRough", "Smooth"))) ) - # can skip Version object - expect_silent(idf$insert(idf_full$Version)) - expect_error(idf$insert(idf$Material_NoMass$R13LAYER, .unique = FALSE), class = "error_validity") - expect_null(idf$insert(idf$Material_NoMass$R13LAYER)) - expect_null(idf$insert(idf$Material_NoMass$R13LAYER, idf$Material_NoMass$R13LAYER)) + expect_equal(idf$Material_NoMass$R13LAYER$Roughness, "VeryRough") + expect_equal(idf$Material_NoMass$R31LAYER$Roughness, "Smooth") +}) +# }}} - idf1 <- empty_idf(8.8) - idf2 <- empty_idf(8.8) - idf1$add(ScheduleTypeLimits = list("Fraction", 0, 1, "continuous")) - idf2$add(ScheduleTypeLimits = list("Fraction", 0, 1, "Continuous")) - expect_silent(idf1$insert(idf2$ScheduleTypeLimits$Fraction)) - expect_equal(idf1$object_id()$ScheduleTypeLimits, 2L) - # can directly insert an Idf - expect_silent(idf1$insert(idf2)) - expect_equal(idf1$object_id(), list(Version = 1L, ScheduleTypeLimits = 2L)) - # }}} +# DEL {{{ +test_that("$del()", { + expect_is(idf <- read_idf(text("idf", 8.8)), "Idf") - # DELETE {{{ - expect_error(idf$del(5L), class = "error_del_version") - expect_error(idf$del(c(1, 2, 1)), class = "error_del_multi_time") - expect_error(idf$del(idf$Building$id()), class = "error_del_required") - expect_silent(idf_full <- read_idf(example())) - expect_error(idf_full$del(idf_full$Material_NoMass[[1]]$id()), class = "error_del_referenced") - expect_equal(eplusr_option(validate_level = "none"), list(validate_level = "none")) - expect_silent(idf_full$del(12, .ref_by = TRUE)) - expect_equal(idf_full$is_valid_id(c(12, 15)), c(FALSE, TRUE)) - expect_silent(idf_full <- read_idf(example())) - expect_silent(idf_full$del(12, .ref_by = TRUE, .force = TRUE)) - expect_equal(idf_full$is_valid_id(c(12, 15)), c(FALSE, FALSE)) - expect_equal(eplusr_option(validate_level = "final"), list(validate_level = "final")) - # }}} + expect_error(idf$del(5L), class = "eplusr_error_del_version") + expect_error(idf$del(c(1, 2, 1)), class = "eplusr_error_del_same") - # PURGE {{{ - idf <- read_idf(text("idf", 8.8)) - expect_error(idf$purge(), class = "error_empty_purge_input") - expect_error(idf$purge(1000), class = "error_object_id") - expect_error(idf$purge(class = "AirLoopHVAC"), class = "error_class_name") - expect_error(idf$purge(group = "Schedules"), class = "error_group_name") + expect_is(idf <- read_idf(example()), "Idf") + expect_error(idf$del(idf$Material_NoMass[[1]]$id()), class = "eplusr_error_del_referenced") + expect_error(idf$del(idf$Building$id()), class = "eplusr_error_del_required") + + expect_is(without_checking(idf$del(12, .ref_by = TRUE)), "Idf") + expect_equal(idf$is_valid_id(c(12, 15)), c(FALSE, TRUE)) + expect_false(idf$object("R13WALL")$is_valid()) + + expect_is(idf <- read_idf(example()), "Idf") + expect_is(idf$del(12, .ref_by = TRUE, .force = TRUE), "Idf") + expect_equal(idf$is_valid_id(c(12, 15)), c(FALSE, FALSE)) +}) +# }}} + +# PURGE {{{ +test_that("$purge()", { + expect_is(idf <- read_idf(text("idf", 8.8)), "Idf") + + expect_error(idf$purge(1000), class = "eplusr_error_invalid_object_id") + expect_error(idf$purge(class = "AirLoopHVAC"), class = "eplusr_error_invalid_class_name") + expect_error(idf$purge(group = "Schedules"), class = "eplusr_error_invalid_group_name") # can skip non-resource object expect_true(idf$purge(5)$is_valid_id(5)) @@ -350,91 +564,218 @@ test_that("Idf class", { # can purge using various specifications idf <- read_idf(text("idf", 8.8)) expect_equal(idf$purge(1:5, c("Material", "Construction"), idf$group_name())$is_valid_id(1:5), c(rep(FALSE, 4), TRUE)) - # }}} - - # UNIQUE {{{ - idf_1 <- read_idf(file.path(eplus_config(8.8)$dir, "ExampleFiles/5Zone_Transformer.idf")) - idf_1$unique(1, group = "Schedules") - expect_false(all(idf_1$is_valid_id(c(35, 38, 42)))) - id <- idf_1$object_id(c("Material", "Output:Meter:MeterFileOnly")) - expect_silent(idf_1$unique(class = c("Material", "Output:Meter:MeterFileOnly"))) - expect_equal(idf_1$object_id(c("Material", "Output:Meter:MeterFileOnly")), id) - # }}} +}) +# }}} - # DUPLICATED {{{ +# DUPLICATED {{{ +test_that("$duplicated()", { idf_1 <- read_idf(file.path(eplus_config(8.8)$dir, "ExampleFiles/5Zone_Transformer.idf")) expect_silent(dup <- idf_1$duplicated()) expect_equal(nrow(dup), 322) - expect_equal(names(dup), c("class", "id", "name", "duplicated")) + expect_equal(names(dup), c("class", "id", "name", "duplicate")) expect_equal(dup$class, idf_1$class_name(sorted = FALSE)) expect_equal(dup$id, 1:322) expect_equal(dup$name, idf_1$object_name(simplify = TRUE)) - expect_equal(dup[duplicated == TRUE, id], c(35L, 38L, 42L, 77L, 78L, 152L, 154L, 156L, 158L)) - expect_equal(idf_1$duplicated(class = "Schedule:Compact")[duplicated == TRUE, id], c(35L, 38L, 42L)) - expect_equal(idf_1$duplicated(group = "Schedules")[duplicated == TRUE, id], c(35L, 38L, 42L)) - # }}} + expect_equal(dup[!is.na(duplicate), id], c(35L, 38L, 42L, 77L, 78L, 152L, 154L, 156L, 158L)) + expect_equal(idf_1$duplicated(class = "Schedule:Compact")[!is.na(duplicate), id], c(35L, 38L, 42L)) + expect_equal(idf_1$duplicated(group = "Schedules")[!is.na(duplicate), id], c(35L, 38L, 42L)) +}) +# }}} + +# UNIQUE {{{ +test_that("$unique()", { + idf_1 <- read_idf(file.path(eplus_config(8.8)$dir, "ExampleFiles/5Zone_Transformer.idf")) + expect_is(idf_1$unique(1, group = "Schedules"), "Idf") + expect_false(all(idf_1$is_valid_id(c(35, 38, 42)))) - # RENAME {{{ + id <- idf_1$object_id(c("Material", "Output:Meter:MeterFileOnly")) + expect_is(idf_1$unique(class = c("Material", "Output:Meter:MeterFileOnly")), "Idf") + expect_equal(idf_1$object_id(c("Material", "Output:Meter:MeterFileOnly")), id) +}) +# }}} + +# RENAME {{{ +test_that("$rename()", { idf <- read_idf(example()) - idf$rename(test = "C5 - 4 IN HW CONCRETE") + expect_is(idf$rename(test = "C5 - 4 IN HW CONCRETE"), "list") expect_equal(idf$object_name("Material"), list(Material = "test")) expect_equal(idf$Construction$FLOOR$Outside_Layer, "test") - expect_silent(idf$rename(test = "test")) - # }}} +}) +# }}} + +# INSERT {{{ +test_that("$insert()", { + expect_is(idf <- read_idf(text("idf", 8.8)), "Idf") + expect_is(idf_full <- read_idf(example()), "Idf") + + expect_error(idf$insert(list()), class = "eplusr_error_dots_format") + + expect_is(idf$insert(idf_full$Material_NoMass$R13LAYER), "list") + expect_equal(idf$object_name("Material:NoMass", simplify = TRUE), "R13LAYER") + expect_equal(idf_full$Material_NoMass$R13LAYER$value(simplify = TRUE), + c("R13LAYER", "Rough", "2.290965", "0.9", "0.75", "0.75") + ) + + # can skip Version object + expect_message(with_option(list(verbose_info = TRUE), idf$insert(idf_full$Version)), "skipped") + + # can remove same object + expect_error(idf$insert(idf$Material_NoMass$R13LAYER, .unique = FALSE), class = "eplusr_error_validity_check") + expect_null(idf$insert(idf$Material_NoMass$R13LAYER)) + expect_null(idf$insert(idf$Material_NoMass$R13LAYER, idf$Material_NoMass$R13LAYER)) - # SEARCH AND REPLACE {{{ + idf1 <- empty_idf(8.8) + idf2 <- empty_idf(8.8) + expect_is(idf1$add(ScheduleTypeLimits = list("Fraction", 0, 1, "continuous")), "list") + expect_is(idf2$add(ScheduleTypeLimits = list("Fraction", 0, 1, "Continuous")), "list") + expect_null(idf1$insert(idf2$ScheduleTypeLimits$Fraction)) + expect_equal(idf1$object_id()$ScheduleTypeLimits, 2L) + # can directly insert an Idf + expect_null(idf1$insert(idf2)) + expect_equal(idf1$object_id(), list(Version = 1L, ScheduleTypeLimits = 2L)) +}) +# }}} + +# SEARCH_VALUE {{{ +test_that("$search_value()", { # can create new Idf object from string - expect_silent(idf <- read_idf(text("idf", 8.8))) + expect_is(idf <- read_idf(text("idf", 8.8)), "Idf") + expect_null(idf$search_value("AAA")) expect_equal( vapply(idf$search_value("WALL"), function (x) x$id(), integer(1)), c(`WALL-1` = 2L, `WALL-1PF` = 3L) ) +}) +# }}} + +# REPLACE_VALUE {{{ +test_that("$replace_value()", { + expect_is(idf <- read_idf(text("idf", 8.8)), "Idf") + expect_equal( vapply(idf$replace_value("WALL-1", "WALL-2"), function (x) x$id(), integer(1)), c(`WALL-2` = 2L, `WALL-2PF` = 3L) ) - # }}} +}) +# }}} - # RELATION {{{ - idf_1 <- read_idf(file.path(eplus_config(8.8)$dir, "ExampleFiles/5Zone_Transformer.idf")) +# PASTE {{{ +test_that("$paste()", { + idf <- read_idf(example()) + if (!is_windows()) expect_error(idf$paste()) - # default only include both objects that are both referenced by their field - # value and class names - ref <- idf_1$object_relation(idf_1$Branch[[1]]$id(), direction = "ref_to") - expect_equal(nrow(ref$ref_to), 8L) - expect_equal(unique(ref$ref_to$src_object_name), - c("OA Sys 1", "Main Cooling Coil 1", "Main Heating Coil 1", "Supply Fan 1") + skip_if_not(is_windows()) + text <- "IDF,BuildingSurface:Detailed,Surface,Wall,R13WALL,ZONE ONE,Outdoors,,SunExposed,WindExposed,0.5000000,4,0,0,4.572000,0,0,0,15.24000,0,0,15.24000,0,4.572000,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,;" + writeClipboard(text) + expect_is(idf$paste()[[1L]], "IdfObject") + writeClipboard(text) + expect_null(idf$paste()) +}) +# }}} + +# LOAD {{{ +test_that("$load()", { + expect_is(idf <- read_idf(text("idf", 8.8)), "Idf") + + # can error if trying to add Version + expect_error(idf$load("Version,8.7;\n")) + + expect_is(idf$load("SimulationControl,no;\n"), "list") + expect_is(idf$SimulationControl, "IdfObject") + + expect_is(class = "list", + idf$load( + c("! some comments;", + "Material,", + " mat, !- Name", + " MediumSmooth, !- Roughness", + " 0.667; !- Thickness {m}", + "Construction, const, mat;" + ) + ) + ) + expect_is(idf$Material$mat, "IdfObject") + + expect_is(class = "list", + { + dt <- idf$to_table(class = rep("Material:NoMass", 2), init = TRUE)[ + ,by = "id", value := c("mat", "Smooth", "0.5") + ][index == 1L, value := paste(value, 1:2, sep = "_")] + obj <- idf$load(dt) + } ) + expect_equal(idf$Material_NoMass$mat_1$Roughness, "Smooth") + expect_equal(idf$Material_NoMass$mat_2$Roughness, "Smooth") +}) +# }}} - # can exclude all class-name-reference - ref <- idf_1$object_relation(idf_1$Branch[[1]]$id(), direction = "ref_to", class_ref = "none") - expect_equal(nrow(ref$ref_to), 4L) - expect_equal(unique(ref$ref_to$src_object_name), - c("OA Sys 1", "Main Cooling Coil 1", "Main Heating Coil 1", "Supply Fan 1") +# UPDATE {{{ +test_that("$update()", { + expect_is(idf <- read_idf(example()), "Idf") + + # can stop if trying to update non-named objects using string + expect_error(idf$update("SimulationControl, no;\n")) + + expect_is(idf$update("Material:NoMass, R13LAYER, Smooth;\n"), "list") + expect_equal(idf$Material_NoMass$R13LAYER$Roughness, "Smooth") + + expect_is(class = "list", + { + idf$update(idf$to_table("r13layer")[2][, value := "Rough"]) + } ) + expect_equal(idf$Material_NoMass$R13LAYER$Roughness, "Rough") +}) +# }}} - # can include all possible objects that are class-name-referenced - ref <- idf_1$object_relation(idf_1$Branch[[1]]$id(), direction = "ref_to", class_ref = "all") - expect_equal(nrow(ref$ref_to), 15L) - expect_equal(unique(ref$ref_to$src_object_name), - c( - "OA Sys 1", - "OA Cooling Coil 1", - "Main Cooling Coil 1", - "SPACE1-1 Zone Coil", - "SPACE2-1 Zone Coil", - "SPACE3-1 Zone Coil", - "SPACE4-1 Zone Coil", - "SPACE5-1 Zone Coil", - "OA Heating Coil 1", - "Main Heating Coil 1", - "Supply Fan 1" +# VALIDATE {{{ +test_that("$validate()", { + expect_is(idf <- read_idf(text("idf", 8.8)), "Idf") + + expect_is(val <- idf$validate(), "IdfValidity") + expect_equal(val$missing_object, c("Building", "GlobalGeometryRules")) + expect_equal(nrow(val$duplicate_object), 0) + expect_equal(nrow(val$conflict_name), 0) + expect_equal(nrow(val$incomplete_extensible), 0) + expect_equal(nrow(val$missing_value), 0) + expect_equal(nrow(val$invalid_autosize), 0) + expect_equal(nrow(val$invalid_autocalculate), 0) + expect_equal(nrow(val$invalid_character), 0) + expect_equal(nrow(val$invalid_numeric), 0) + expect_equal(nrow(val$invalid_integer), 0) + expect_equal(nrow(val$invalid_choice), 0) + expect_equal(nrow(val$invalid_range), 0) + expect_equal(nrow(val$invalid_reference), 4) + expect_equal(val$invalid_reference, + data.table(object_id = c(2L, 2L, 2L, 3L), + object_name = c("WALL-1", "WALL-1", "WALL-1", "WALL-1PF"), + class_id = c(90L, 90L, 90L, 103L), + class_name = c("Construction", "Construction", "Construction", "BuildingSurface:Detailed"), + field_id = c(11008L, 11009L, 11010L, 11625L), + field_index = c(3L, 4L, 5L, 4L), + field_name = c("Layer 2", "Layer 3", "Layer 4", "Zone Name"), + units = c(NA_character_, NA_character_, NA_character_, NA_character_), + ip_units = c(NA_character_, NA_character_, NA_character_, NA_character_), + type_enum = c(5L, 5L, 5L, 5L), + value_id = c(12L, 13L, 14L, 18L), + value_chr = c("PW03", "IN02", "GP01", "PLENUM-1"), + value_num = c(NA_real_, NA_real_, NA_real_, NA_real_) ) ) - # }}} +}) +# }}} - # STRING {{{ +# IS_VALID {{{ +test_that("$is_valid()", { + expect_is(idf <- read_idf(text("idf", 8.8)), "Idf") + + expect_false(idf$is_valid()) +}) +# }}} + +# TO_STRING {{{ +test_that("$to_string()", { # can get idf in string format idf_string <- c( "!-Generator eplusr", @@ -453,13 +794,15 @@ test_that("Idf class", { ) expect_silent(idf_1 <- read_idf(paste0(idf_string, collapse = "\n"))) expect_equal(idf_1$to_string(format = "new_top"), idf_string) - # }}} +}) +# }}} - # TABLE {{{ +# TO_TABLE {{{ +test_that("$to_table()", { # can get idf in table format - expect_silent(idf <- read_idf(text("idf", 8.8))) - expect_silent(idf$to_table()) - expect_silent(idf$to_string()) + expect_is(idf <- read_idf(text("idf", 8.8)), "Idf") + expect_is(idf$to_table(), "data.table") + expect_is(idf$to_string(), "character") expect_equal( idf$to_table(2, unit = TRUE, string_value = TRUE), data.table(id = 2L, name = "WALL-1", class = "Construction", index = 1:5, @@ -674,20 +1017,69 @@ test_that("Idf class", { "Vertex Z-coordinate" = list(set_units(c(3., 2.4, 2.4, 3., NA_real_), "m")) ) ) - # }}} +}) +# }}} - # VALIDATE {{{ - expect_is(idf$validate(), "IdfValidity") - expect_false(idf$is_valid()) - # }}} +# SAVE {{{ +test_that("$save()", { + expect_is(idf <- read_idf(text("idf", 8.8)), "Idf") + expect_error(idf$save(), "not created from local", "eplusr_error") - # SAVE {{{ unlink(file.path(tempdir(), "test_save.idf"), force = TRUE) expect_silent(idf$save(file.path(tempdir(), "test_save.idf"))) expect_error(idf$save(file.path(tempdir(), "test_save.idf"))) - # }}} + expect_is(idf$save(overwrite = TRUE), "character") +}) +# }}} + +# RUN {{{ +test_that("$run()", { + expect_error(read_idf(text("idf", 8.8))$save(), class = "eplusr_error") + expect_is(idf <- read_idf(example()), "Idf") + expect_is(job <- idf$run(NULL, tempdir(), echo = FALSE), "EplusJob") + + expect_silent(idf$set(..12 = list(roughness = "smooth"))) + expect_error(idf$run()) + expect_error({idf$save(tempfile(fileext = ".idf"));idf$run(echo = FALSE)}) +}) +# }}} + +# LAST_JOB {{{ +test_that("$last_job()", { + expect_is(idf <- read_idf(example()), "Idf") + expect_null(idf$last_job()) + expect_is({idf$run(NULL, tempdir(), echo = FALSE); idf$last_job()}, "EplusJob") +}) +# }}} + +# VIEW {{{ +test_that("$view()", { + expect_is(x <- empty_idf(8.8)$view(), "Idf") +}) +# }}} + +# SAVE_VIEW {{{ +test_that("$save_view()", { + expect_is(idf <- read_idf(example()), "Idf") + expect_error(idf$save_view()) +}) +# }}} + +# CLONE {{{ +test_that("$clone()", { + idf1 <- read_idf(example()) + idf2 <- idf1$clone() + idf1$set(c(idf1$Zone[[1]]$name()) := list(name = "zone")) + expect_equal(idf1$Zone[[1]]$Name, "zone") + expect_equal(idf2$Zone[[1]]$Name, "ZONE ONE") +}) +# }}} + +# PRINT {{{ +test_that("$print()", { + expect_is(idf <- read_idf(text("idf", 8.8)), "Idf") + expect_output(idf$print()) - # PRINT {{{ # only test on UTF-8 supported platform skip_if_not(cli::is_utf8_output()) idf <- read_idf(example()) @@ -699,15 +1091,138 @@ test_that("Idf class", { expect_output(idf$print("object", order = FALSE)) expect_output(idf$print("field")) expect_output(idf$print("field", order = FALSE)) - # }}} +}) +# }}} - # ACTIVE BINDINGS {{{ - .options$autocomplete <- TRUE - idf <- read_idf(example()) +# ADD_OUTPUT {{{ +test_that("idf_add_output_*", { + expect_true(idf_add_output_sqlite(example())) + + expect_is(idf <- read_idf(example()), "Idf") + expect_true(idf_add_output_sqlite(idf)) + expect_is(idf$set(`Output:SQLite` := list("Simple")), "list") + expect_true(idf_add_output_sqlite(idf)) + + idf1 <- idf$clone() + idf$set(c(idf$Zone[[1]]$name()) := list(name = "zone")) + expect_equal(idf$Zone[[1]]$Name, "zone") + expect_equal(idf1$Zone[[1]]$Name, "ZONE ONE") + + expect_false(idf_add_output_vardict(example())) + + expect_is(idf <- read_idf(example()), "Idf") + expect_silent(without_checking(idf$Output_VariableDictionary[[1L]]$Key_Field <- "wrong")) + expect_true(idf_add_output_vardict(idf)) + expect_null(idf$Output_VariableDictionary <- NULL) + expect_true(idf_add_output_vardict(idf)) +}) +# }}} + +# ACTIVE BINDING {{{ +test_that("add_idd_class_bindings", { + expect_is(with_option(list(autocomplete = FALSE), idf <- read_idf(example())), "Idf") + expect_false("Version" %in% ls(idf)) + + expect_is(with_option(list(autocomplete = TRUE), idf <- read_idf(example())), "Idf") + expect_true(all(idf$class_name() %in% ls(idf))) + + expect_null(without_checking(idf$Timestep <- NULL)) + expect_output(print(idf)) + expect_false("Timestep" %in% ls(idf)) +}) +# }}} + +# EMPTY IDF {{{ +test_that("empty_idf()", { + expect_is(idf <- empty_idf(8.8), "Idf") +}) +# }}} + +# S3 FORMATTING {{{ +test_that("format.Idf, as.character.Idf and etc", { + expect_is(idf <- read_idf(text("idf", 8.8)), "Idf") + + expect_output(print(idf)) + + expect_output(str(idf)) + + expect_equal(format(idf, comment = FALSE, header = FALSE), + paste0(idf$to_string(comment = FALSE, header = FALSE), collapse = "\n") + ) + + expect_equal(as.character(idf, comment = FALSE, header = FALSE), + idf$to_string(comment = FALSE, header = FALSE) + ) +}) +# }}} + +# S3 EQUALITY {{{ +test_that("==.Idf and !=.Idf", { + expect_is(idf_1 <- read_idf(text("idf", 8.8)), "Idf") + expect_is(idf_2 <- read_idf(text("idf", 8.8)), "Idf") + + # can check equality + expect_false(idf_1 == TRUE) + expect_true(idf_1 == idf_1) + expect_false(idf_1 == idf_2) + expect_false(idf_1 != idf_1) + expect_true(idf_1 != idf_2) +}) +# }}} + +# S3 SUBSET {{{ +test_that("[[.Idf and $.Idf", { + expect_is(idf <- read_idf(text("idf", 8.8)), "Idf") + + expect_is(idf$Version, "IdfObject") + + expect_equal(names(idf[["Material"]]), c("WD01", "WD02")) + expect_equal(names(idf$Material), c("WD01", "WD02")) + + expect_null(idf$Wrong) + expect_null(idf[["Wrong"]]) + expect_error(idf[[1:2]]) + expect_null(idf$Timestep) + expect_null(idf[["Timestep"]]) +}) +# }}} + +# S3 ASSIGN {{{ +test_that("[[<-.Idf and $<-.Idf", { + expect_is(idf <- read_idf(text("idf", 8.8)), "Idf") + expect_error(idf$version() <- NULL) + expect_error(idf$VERSION <- NULL) + expect_error(idf[[1:2]] <- NULL) + expect_error(idf[["VERSION"]] <- NULL) + + expect_is(idf_1 <- read_idf(file.path(eplus_config(8.8)$dir, "ExampleFiles/5Zone_Transformer.idf")), "Idf") + expect_is(idf_2 <- read_idf(idf_1$path()), "Idf") + expect_silent(without_checking(idf_1$BuildingSurface_Detailed <- idf_2$BuildingSurface_Detailed)) + expect_silent(without_checking(idf_1[["BuildingSurface:Detailed"]] <- idf_2[["BuildingSurface:Detailed"]])) + + expect_null(without_checking(idf_1$BuildingSurface_Detailed <- NULL)) + expect_silent(without_checking(idf_1$BuildingSurface_Detailed <- idf_2$BuildingSurface_Detailed)) + expect_silent(without_checking(idf_1[["BuildingSurface:Detailed"]] <- NULL)) + expect_silent(without_checking(idf_1[["BuildingSurface:Detailed"]] <- idf_2[["BuildingSurface:Detailed"]])) + + expect_is(with_option(list(autocomplete = TRUE), idf <- read_idf(example())), "Idf") + + expect_error(idf$SimulationControl <- idf$Timestep) + expect_error(idf$SimulationControl <- "Timestep, 6;\n") + expect_error(idf$SimulationControl <- FALSE) # UNIQUE-OBJECT CLASS {{{ expect_true("SimulationControl" %in% names(idf)) + expect_silent(idf$Material_NoMass$R13LAYER$Thermal_Absorptance <- 0.5) + expect_equal(idf$Material_NoMass$R13LAYER$Thermal_Absorptance, 0.5) + expect_silent(idf$Material_NoMass$R13LAYER[["Thermal Absorptance"]] <- 0.6) + expect_equal(idf$Material_NoMass$R13LAYER[["Thermal Absorptance"]], 0.6) + expect_silent(idf$SimulationControl$Do_Zone_Sizing_Calculation <- "Yes") + expect_equal(idf$SimulationControl$Do_Zone_Sizing_Calculation, "Yes") + expect_silent(idf$SimulationControl[["Do Zone Sizing Calculation"]] <- "No") + expect_equal(idf$SimulationControl[["Do Zone Sizing Calculation"]], "No") + # get data.frame input tbl <- idf$SimulationControl$to_table() # get string input @@ -715,13 +1230,15 @@ test_that("Idf class", { tbl[5, value := "No"] # can replace unique-object class - expect_silent(idf$SimulationControl <- tbl) + expect_is(idf$SimulationControl <- idf$SimulationControl, "IdfObject") + expect_is(idf$SimulationControl <- tbl, "data.table") expect_equal(idf$SimulationControl$to_table()$value[[5]], "No") - expect_silent(idf$SimulationControl <- str) + expect_is(idf$SimulationControl <- str, "character") expect_equal(idf$SimulationControl$to_table()$value[[5]], "Yes") # can remove unique-object class - expect_silent(idf$SimulationControl <- NULL) + expect_error(idf$SimulationControl <- NULL) + expect_null(without_checking(idf$SimulationControl <- NULL)) expect_false(idf$is_valid_class("SimulationControl")) expect_null(idf$SimulationControl) expect_false({capture.output(print(idf)); "SimulationControl" %in% names(idf)}) @@ -729,7 +1246,6 @@ test_that("Idf class", { # can insert unique-object class expect_silent(idf$SimulationControl <- tbl) expect_true(idf$is_valid_class("SimulationControl")) - expect_silent(idf$SimulationControl <- NULL) expect_silent(idf$SimulationControl <- str) expect_true("SimulationControl" %in% names(idf)) # }}} @@ -750,7 +1266,7 @@ test_that("Idf class", { expect_equal(idf$to_table(class = "Material")$value[[3]], "0.1014984") # can remove class - expect_error(idf$Material <- NULL, class = "error_del_referenced") + expect_error(idf$Material <- NULL, class = "eplusr_error_del_referenced") eplusr_option(validate_level = {chk <- level_checks("final"); chk$reference <- FALSE; chk}) expect_silent(idf$Material <- NULL) expect_false(idf$is_valid_class("Material")) @@ -766,18 +1282,6 @@ test_that("Idf class", { # TODO: dynamically modify active bindings # expect_true("Material" %in% names(idf)) eplusr_option(validate_level = "final") - # }}} - # }}} - - # S3{{{ - idf <- read_idf(text("idf", 8.8)) - expect_equal(names(idf$Material), c("WD01", "WD02")) - expect_null(idf$Wrong) - expect_silent(idf$Material$WD01$set(thickness = 0.02)) - expect_silent(idf$Material$WD01$Thickness <- 0.01) - expect_silent(idf$add(SimulationControl = list())) - expect_silent(idf$SimulationControl$set(Do_Zone_Sizing_Calculation = "no")) - expect_silent(idf$SimulationControl$Do_Zone_Sizing_Calculation <- "No") # can directly insert objects from other idf idf_1 <- read_idf(file.path(eplus_config(8.8)$dir, "ExampleFiles/5Zone_Transformer.idf")) @@ -786,52 +1290,6 @@ test_that("Idf class", { idf_2 <- read_idf(idf_1$path()) expect_silent(without_checking(idf_1$BuildingSurface_Detailed <- idf_2$BuildingSurface_Detailed)) - # can check equality - expect_true(idf_1 == idf_1) - expect_false(idf_1 == idf_2) - expect_false(idf_1 != idf_1) - expect_true(idf_1 != idf_2) - # }}} - - # CLONE {{{ - idf1 <- read_idf(example()) - idf2 <- idf1$clone() - idf1$Zone[[1]]$set(name = "zone") - expect_equal(idf1$Zone[[1]]$Name, "zone") - expect_equal(idf2$Zone[[1]]$Name, "ZONE ONE") # }}} - - # $last_job() {{{ - tmp <- read_idf(file.path(eplus_config(8.8)$dir, "ExampleFiles/5Zone_Transformer.idf")) - expect_null(tmp$last_job()) - expect_is({tmp$run(NULL, tempdir()); tmp$last_job()}, "EplusJob") - # }}} - - # OBJECT_UNIQUE {{{ - # can stop if multiple objects in unique class found - expect_silent( - idf <- with_option( - list(validate_level = "none", verbose_info = FALSE), - { - idf <- empty_idf(8.8) - idf$add(Building = list(), Building = list()) - idf - } - ) - ) - expect_error(idf$object_unique("Building"), class = "error_idf_dup_unique_class") - # }}} -}) -# }}} - -# PASTE {{{ -test_that("$paste() method in Idf class", { - skip_if_not(is_windows()) - idf <- read_idf(example()) - text <- "IDF,BuildingSurface:Detailed,Surface,Wall,R13WALL,ZONE ONE,Outdoors,,SunExposed,WindExposed,0.5000000,4,0,0,4.572000,0,0,0,15.24000,0,0,15.24000,0,4.572000,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,;" - writeClipboard(text) - expect_is(idf$paste()[[1L]], "IdfObject") - writeClipboard(text) - expect_null(idf$paste()) }) # }}} diff --git a/tests/testthat/test-idfobj.R b/tests/testthat/test-idfobj.R index 35fcf9020..14c90f4ce 100644 --- a/tests/testthat/test-idfobj.R +++ b/tests/testthat/test-idfobj.R @@ -1,32 +1,87 @@ context("IdfObject") -# IdfObject class{{{ -test_that("IdfObject class", { - idf <- read_idf(text("idf", 8.8), use_idd(8.8, "auto")) - ver <- idf$Version - mat <- idf$Material$WD01 - surf <- idf$BuildingSurface_Detailed[["WALL-1PF"]] - con <- idf$Construction[["WALL-1"]] +# NEW {{{ +test_that("$new()", { + expect_is(idf <- read_idf(text("idf", 8.8)), "Idf") + + expect_error(IdfObject$new(1)) + expect_error(IdfObject$new(1, class = "Material", parent = idf)) + + expect_is(mat <- IdfObject$new(1, parent = idf), "IdfObject") + expect_equal(get_priv_env(mat)$m_object_id, 1L) + expect_equal(get_priv_env(mat)$m_class_id, 55L) + + expect_is(mat <- IdfObject$new(1, 55, parent = idf), "IdfObject") + expect_equal(get_priv_env(mat)$m_object_id, 1L) + expect_equal(get_priv_env(mat)$m_class_id, 55L) +}) +# }}} + +# VERSION {{{ +test_that("$version()", { + expect_is(idf <- read_idf(text("idf", 8.8)), "Idf") + expect_is(obj <- IdfObject$new(5, parent = idf), "IdfObject") + expect_equal(obj$version(), numeric_version("8.8.0")) +}) +# }}} + +# PARENT {{{ +test_that("$parent()", { + expect_is(idf <- read_idf(text("idf", 8.8)), "Idf") + expect_is(obj <- IdfObject$new(5, parent = idf), "IdfObject") + expect_is(obj$parent(), "Idf") +}) +# }}} + +# ID {{{ +test_that("$id()", { + expect_is(idf <- read_idf(text("idf", 8.8)), "Idf") + expect_is(obj <- IdfObject$new(1, parent = idf), "IdfObject") + expect_equal(obj$id(), 1L) +}) +# }}} - # Basic {{{ - # get parent Idf - expect_is(ver$parent(), "Idf") +# NAME {{{ +test_that("$name()", { + expect_is(idf <- read_idf(text("idf", 8.8)), "Idf") + expect_is(obj <- IdfObject$new(1, parent = idf), "IdfObject") + expect_equal(obj$name(), "WD01") +}) +# }}} - # get group name - expect_equal(con$group_name(), "Surface Construction Elements") +# GROUP_NAME {{{ +test_that("$group_name()", { + expect_is(idf <- read_idf(text("idf", 8.8)), "Idf") + expect_is(obj <- IdfObject$new(2, parent = idf), "IdfObject") + expect_equal(obj$group_name(), "Surface Construction Elements") +}) +# }}} - # get class name - expect_equal(con$class_name(), "Construction") +# CLASS_NAME {{{ +test_that("$class_name()", { + expect_is(idf <- read_idf(text("idf", 8.8)), "Idf") + expect_is(obj <- IdfObject$new(2, parent = idf), "IdfObject") + expect_equal(obj$class_name(), "Construction") +}) +# }}} - # get object ID - expect_equal(mat$id(), 1L) - # }}} +# DEFINITION {{{ +test_that("$definition()", { + expect_is(idf <- read_idf(text("idf", 8.8)), "Idf") + expect_is(obj <- IdfObject$new(1, parent = idf), "IdfObject") + expect_is(obj$definition(), "IddObject") +}) +# }}} + +# COMMENT {{{ +test_that("$comment()", { + expect_is(idf <- read_idf(text("idf", 8.8)), "Idf") + expect_is(mat <- IdfObject$new(1, parent = idf), "IdfObject") - # Comment {{{ expect_equal(mat$comment(), " this is a test comment for WD01") # can handle invalid input types of comment - expect_error(mat$comment(comment = list("a")), class = "error_not_is.atomic") + expect_error(mat$comment(comment = list("a"))) # can delete comments expect_equal(mat$comment(comment = NULL)$comment(), NULL) @@ -38,25 +93,27 @@ test_that("IdfObject class", { expect_equal(mat$comment(comment = c("b"))$comment(), c("a", "b")) # can prepend comments - expect_equal(mat$comment(comment = c("c"), append = FALSE)$comment(), - c("c", "a", "b")) + expect_equal(mat$comment(comment = c("c"), append = FALSE)$comment(), c("c", "a", "b")) # can reset comments expect_equal(mat$comment(comment = c("d"), append = NULL)$comment(), "d") # can detect invalid `append` value - expect_error(mat$comment(comment = c("b"), append = 1:2), - class = "error_not_flag") + expect_error(mat$comment(comment = c("b"), append = 1:2), class = "eplusr_error") # can wrap comment at specified `width` - expect_equal(mat$comment(comment = c("a", "bb ccc"), append = NULL, width = 1L)$comment(), - c("a", "bb", "ccc")) + expect_equal(mat$comment(comment = c("a", "bb ccc"), append = NULL, width = 1L)$comment(), c("a", "bb", "ccc")) # can detect invalid `width` value expect_error(mat$comment(comment = c("a"), append = NULL, width = "a")) - # }}} +}) +# }}} + +# VALUE {{{ +test_that("$value()", { + expect_is(idf <- read_idf(text("idf", 8.8)), "Idf") + expect_is(mat <- IdfObject$new(1, parent = idf), "IdfObject") - # Get Values {{{ # can handle cases when both `index` and `name` are NULL expect_equivalent(mat$value(), tolerance = 1e-5, list(Name = "WD01", @@ -89,8 +146,8 @@ test_that("IdfObject class", { ) # can detect invaid `index` values - expect_error(mat$value("1"), class = "error_bad_field_name") - expect_error(mat$value(c(1, 10:11)), class = "error_bad_field_index") + expect_error(mat$value("1"), class = "eplusr_error_invalid_field_name") + expect_error(mat$value(c(1, 10:11)), class = "eplusr_error_invalid_field_index") # can return subset of values in a object using `index` expect_equivalent(mat$value(c(3, 1, 5)), tolerance = 1e-5, @@ -106,41 +163,43 @@ test_that("IdfObject class", { expect_equal(mat$Roughness, "MediumSmooth") # can detect invalid `name` values - expect_error(mat$value(c("Thickness", "Wrong", "Name")), class = "error_bad_field_name") - # }}} + expect_error(mat$value(c("Thickness", "Wrong", "Name")), class = "eplusr_error_invalid_field_name") +}) +# }}} + +# SET {{{ +test_that("$set()", { + expect_is(idf <- read_idf(text("idf", 8.8), use_idd(8.8, "auto")), "Idf") + expect_is(ver <- IdfObject$new(5, parent = idf), "IdfObject") + expect_is(mat <- IdfObject$new(1, parent = idf), "IdfObject") + expect_is(surf <- IdfObject$new(3, parent = idf), "IdfObject") + expect_is(con <- IdfObject$new(2, parent = idf), "IdfObject") - # Set Values {{{ # can stop when trying to directly modify `Version` object - expect_error(ver$set(8.8), class = "error_set_version") + expect_error(ver$set(8.8), class = "eplusr_error_set_version") # can stop when no values are given - expect_error(con$set(), class = "error_dot_empty") + expect_error(con$set(), class = "eplusr_error_validity_check") - expect_error(con$set(name = "named", "unnamed"), - class = "error_validity") + expect_error(con$set(name = "named", "unnamed"), class = "eplusr_error_validity_check") # can stop when duplicated names are given - expect_error(con$set(name = "first", name = "second"), - class = "error_dot_dup_field_name") + expect_error(con$set(name = "first", name = "second")) # can stop when invalid names are given for a non-extensible class - expect_error(mat$set(wrong = "something"), - class = "error_bad_field_name") + expect_error(mat$set(wrong = "something"), class = "eplusr_error_invalid_field_name") # can stop when invalid names are given for an extensible class - expect_error(con$set(name = "first", wrong = "second"), - class = "error_bad_field_name") + expect_error(con$set(name = "first", wrong = "second"), class = "eplusr_error_invalid_field_name") # can stop when valid names are given, but total field values are not accepatable for an extensible class idf$add(Zone = list("PLENUM-1")) - expect_error(surf$set(vertex_5_x_coordinate = 1, vertex_5_y_coordinate = 2), - class = "error_validity" - ) + expect_error(surf$set(vertex_5_x_coordinate = 1, vertex_5_y_coordinate = 2), class = "eplusr_error_validity_check") # can stop when total field values are acceptable but invalid names are given for an extensible class expect_error( surf$set(vertex_5_x_coordinate = 1, vertex_5_y_coordinate = 2, vertex_5_z_wrong = 3), - class = "error_bad_field_name" + class = "eplusr_error_invalid_field_name" ) # can add new values for extensible fields @@ -153,7 +212,7 @@ test_that("IdfObject class", { expect_equal(con$value("Outside Layer")[[1]], "NewMaterialName") # can stop when there are invalid references in the input - expect_error(con$set(layer_2 = "missing"), class = "error_validity") + expect_error(con$set(layer_2 = "missing"), class = "eplusr_error_validity_check") # works using `[[<-.IdfObject` expect_silent(mat$Name <- "NewMaterial") @@ -162,18 +221,23 @@ test_that("IdfObject class", { expect_equal(mat$name(), "NewMaterialName1") expect_silent(mat[[1]] <- "NewMaterialName") expect_equal(mat$name(), "NewMaterialName") - # }}} +}) +# }}} + +# VALUE_POSSIBLE {{{ +test_that("$value_possible()", { + expect_is(idf <- read_idf(text("idf", 8.8), use_idd(8.8, "auto")), "Idf") + expect_is(con <- IdfObject$new(2, parent = idf), "IdfObject") - # Possible {{{ expect_equivalent(con$value_possible(), data.table(class_id = 90L, class_name = "Construction", object_id = 2L, object_name = "WALL-1", field_id = 11006:11010, field_index = 1:5, field_name = c("Name", "Outside Layer", paste("Layer", 2:4)), - value_id = 10:14, value_chr = c("WALL-1", "NewMaterialName", "PW03", "IN02", "GP01"), + value_id = 10:14, value_chr = c("WALL-1", "WD01", "PW03", "IN02", "GP01"), value_num = rep(NA_real_, 5), auto = NA_character_, default = rep(list(NA_character_), 5), choice = list(), range = rep(list(ranger(NA_real_, FALSE, NA_real_, FALSE)), 5), - source = c(list(NULL), rep(list(c("NewMaterialName", "WD02")), 4)) + source = c(list(NULL), rep(list(c("WD01", "WD02")), 4)) ) ) expect_equivalent(con$value_possible(6), @@ -182,12 +246,50 @@ test_that("IdfObject class", { field_name = "Layer 5", value_id = -1L, value_chr = NA_character_, value_num = NA_real_, auto = NA_character_, default = list(NA_character_), choice = list(), range = list(ranger(NA_real_, FALSE, NA_real_, FALSE)), - source = list(c("NewMaterialName", "WD02")) + source = list(c("WD01", "WD02")) + ) + ) +}) +# }}} + +# VALIDATE {{{ +test_that("$validate()", { + expect_is(idf <- read_idf(text("idf", 8.8), use_idd(8.8, "auto")), "Idf") + expect_is(con <- IdfObject$new(2, parent = idf), "IdfObject") + + expect_equal(con$validate()$invalid_reference, + data.table(object_id = 2L, object_name = "WALL-1", class_id = 90L, + class_name = "Construction", field_id = 11008:11010, + field_index = 3:5, field_name = paste("Layer", 2:4), + units = rep(NA_character_, 3L), ip_units = rep(NA_character_, 3L), + type_enum = 5L, value_id = 12:14, + value_chr = c("PW03", "IN02", "GP01"), + value_num = rep(NA_real_, 3L) ) ) - # }}} +}) +# }}} + +# IS_VALID {{{ +test_that("$is_valid()", { + expect_is(idf <- read_idf(text("idf", 8.8), use_idd(8.8, "auto")), "Idf") + expect_is(ver <- IdfObject$new(5, parent = idf), "IdfObject") + expect_is(mat <- IdfObject$new(1, parent = idf), "IdfObject") + expect_is(surf <- IdfObject$new(3, parent = idf), "IdfObject") + expect_is(con <- IdfObject$new(2, parent = idf), "IdfObject") + + expect_true(ver$is_valid()) + expect_true(mat$is_valid()) + expect_false(con$is_valid()) + expect_false(surf$is_valid()) +}) +# }}} + +# VALUE_RELATION {{{ +test_that("$value_relation()", { + expect_is(idf <- read_idf(text("idf", 8.8), use_idd(8.8, "auto")), "Idf") + expect_is(con <- IdfObject$new(2, parent = idf), "IdfObject") - # Relation {{{ expect_equivalent(con$value_relation(1), list( ref_to = data.table( @@ -262,10 +364,31 @@ test_that("IdfObject class", { ) ) ) +}) +# }}} - expect_equal(names(con$ref_to_object()), "NewMaterialName") +# REF {{{ +test_that("$ref_to_object()", { + expect_is(idf <- read_idf(text("idf", 8.8), use_idd(8.8, "auto")), "Idf") + expect_is(con <- IdfObject$new(2, parent = idf), "IdfObject") + expect_is(ver <- IdfObject$new(5, parent = idf), "IdfObject") + + expect_message(with_option(list(verbose_info = TRUE), ver$ref_to_object()), "does not refer") + expect_message(with_option(list(verbose_info = TRUE), ver$ref_to_object(class = "Material")), "does not refer") + expect_equal(names(con$ref_to_object()), "WD01") + + expect_message(with_option(list(verbose_info = TRUE), ver$ref_by_object()), "is not referred") + expect_message(with_option(list(verbose_info = TRUE), ver$ref_by_object(class = "Material")), "is not referred") expect_equal(names(con$ref_by_object()), "WALL-1PF") + expect_message(with_option(list(verbose_info = TRUE), ver$ref_to_node()), "has no node") + expect_message(with_option(list(verbose_info = TRUE), ver$ref_to_node(class = "Material")), "has no node") + + if (!is_avail_eplus(8.8)) install_eplus(8.8) + idf <- read_idf(file.path(eplus_config(8.8)$dir, "ExampleFiles/5Zone_Transformer.idf")) + expect_is(loop <- IdfObject$new(278, parent = idf), "IdfObject") + expect_equal(length(loop$ref_to_node()), 9) + expect_equal(con$has_ref(), c(TRUE, TRUE, FALSE, FALSE, FALSE)) expect_true(con$has_ref(1)) expect_equal(con$has_ref_to(), c(FALSE, TRUE, FALSE, FALSE, FALSE)) @@ -274,51 +397,41 @@ test_that("IdfObject class", { expect_equal(con$has_ref_by(), c(TRUE, rep(FALSE, 4))) expect_true(con$has_ref_by(1)) expect_false(con$has_ref_by(2)) - # }}} + expect_false(con$has_ref_node(2)) +}) +# }}} - # Validate {{{ - expect_equal(con$validate()$invalid_reference, - data.table(object_id = 2L, object_name = "WALL-1", class_id = 90L, - class_name = "Construction", field_id = 11008:11010, - field_index = 3:5, field_name = paste("Layer", 2:4), - units = rep(NA_character_, 3L), ip_units = rep(NA_character_, 3L), - type_enum = 5L, value_id = 12:14, - value_chr = c("PW03", "IN02", "GP01"), - value_num = rep(NA_real_, 3L) - ) - ) - expect_true(ver$is_valid()) - expect_true(mat$is_valid()) - expect_false(con$is_valid()) - expect_true(surf$is_valid()) - # }}} +# TO_TABLE {{{ +test_that("$to_table()", { + expect_is(idf <- read_idf(text("idf", 8.8), use_idd(8.8, "auto")), "Idf") + expect_is(mat <- IdfObject$new(1, parent = idf), "IdfObject") + expect_is(con <- IdfObject$new(2, parent = idf), "IdfObject") - # Table {{{ expect_equal( con$to_table(all = FALSE, unit = TRUE, wide = FALSE, string_value = TRUE), data.table(id = 2L, name = "WALL-1", class = "Construction", index = 1:5, field = c("Name", "Outside Layer", paste("Layer", 2:4)), - value = c("WALL-1", "NewMaterialName", "PW03", "IN02", "GP01") + value = c("WALL-1", "WD01", "PW03", "IN02", "GP01") ) ) expect_equal( con$to_table(all = TRUE, unit = TRUE, wide = FALSE, string_value = TRUE), data.table(id = 2L, name = "WALL-1", class = "Construction", index = 1:11, field = c("Name", "Outside Layer", paste("Layer", 2:10)), - value = c("WALL-1", "NewMaterialName", "PW03", "IN02", "GP01", rep(NA_character_, 6)) + value = c("WALL-1", "WD01", "PW03", "IN02", "GP01", rep(NA_character_, 6)) ) ) expect_equal( con$to_table(all = TRUE, unit = FALSE, wide = FALSE, string_value = FALSE), data.table(id = 2L, name = "WALL-1", class = "Construction", index = 1:11, field = c("Name", "Outside Layer", paste("Layer", 2:10)), - value = as.list(c("WALL-1", "NewMaterialName", "PW03", "IN02", "GP01", rep(NA_character_, 6))) + value = as.list(c("WALL-1", "WD01", "PW03", "IN02", "GP01", rep(NA_character_, 6))) ) ) expect_equivalent( con$to_table(all = TRUE, unit = TRUE, wide = TRUE, string_value = FALSE), data.table(id = 2L, name = "WALL-1", class = "Construction", - Name = "WALL-1", `Outside Layer` = "NewMaterialName", `Layer 2` = "PW03", + Name = "WALL-1", `Outside Layer` = "WD01", `Layer 2` = "PW03", `Layer 3` = "IN02", `Layer 4` = "GP01", `Layer 5` = NA_character_, `Layer 6` = NA_character_, `Layer 7` = NA_character_, `Layer 8` = NA_character_, `Layer 9` = NA_character_, `Layer 10` = NA_character_ @@ -326,9 +439,9 @@ test_that("IdfObject class", { ) expect_equivalent(tolerance = 1e-5, mat$to_table(string_value = FALSE), - data.table(id = 1L, name = "NewMaterialName", class = "Material", index = 1:9, + data.table(id = 1L, name = "WD01", class = "Material", index = 1:9, field = mat$definition()$field_name(), - value = list("NewMaterialName", "MediumSmooth", units::set_units(0.0191, m), + value = list("WD01", "MediumSmooth", units::set_units(0.0191, m), units::set_units(0.115, W/K/m), units::set_units(513, kg/m^3), units::set_units(1381, J/K/kg), 0.9, 0.78, 0.78 ) @@ -336,7 +449,7 @@ test_that("IdfObject class", { ) expect_equivalent(tolerance = 1e-5, mat$to_table(wide = TRUE, string_value = FALSE), - data.table(id = 1L, name = "NewMaterialName", class = "Material", Name = "NewMaterialName", + data.table(id = 1L, name = "WD01", class = "Material", Name = "WD01", `Roughness` = "MediumSmooth", `Thickness` = units::set_units(0.0191, m), `Conductivity` = units::set_units(0.115, W/K/m), @@ -346,13 +459,18 @@ test_that("IdfObject class", { `Visible Absorptance` = 0.78 ) ) - # }}} +}) +# }}} + +# TO_STRING {{{ +test_that("$to_string()", { + expect_is(idf <- read_idf(text("idf", 8.8), use_idd(8.8, "auto")), "Idf") + expect_is(con <- IdfObject$new(2, parent = idf), "IdfObject") - # String {{{ expect_equal(con$to_string(leading = 0, sep_at = 10), c("Construction,", "WALL-1, !- Name", - "NewMaterialName, !- Outside Layer", + "WD01, !- Outside Layer", "PW03, !- Layer 2", "IN02, !- Layer 3", "GP01; !- Layer 4") @@ -360,7 +478,7 @@ test_that("IdfObject class", { expect_equal(con$to_string(leading = 0, sep_at = 10, all = TRUE), c("Construction,", "WALL-1, !- Name", - "NewMaterialName, !- Outside Layer", + "WD01, !- Outside Layer", "PW03, !- Layer 2", "IN02, !- Layer 3", "GP01, !- Layer 4", @@ -372,17 +490,70 @@ test_that("IdfObject class", { "; !- Layer 10" ) ) - # }}} +}) +# }}} + +# PRINT {{{ +test_that("$print()", { + expect_is(idf <- read_idf(text("idf", 8.8), use_idd(8.8, "auto")), "Idf") + expect_is(ver <- IdfObject$new(5, parent = idf), "IdfObject") + expect_is(con <- IdfObject$new(2, parent = idf), "IdfObject") + + expect_output(ver$print()) + expect_output(ver$print(brief = TRUE)) + expect_output(con$print()) + expect_output(con$print(all = TRUE), "11 :") + expect_output(con$print(auto_sep = FALSE)) + + expect_is(idf <- read_idf(example(), 8.8), "Idf") + expect_is(ver <- IdfObject$new(1, parent = idf), "IdfObject") + expect_is(out <- IdfObject$new(40, parent = idf), "IdfObject") + expect_output(ver$print()) + expect_output(out$print()) +}) +# }}} + +# S3 FORMAT {{{ +test_that("format.IdfObject, as.character.IdfObject, etc", { + expect_is(idf <- read_idf(text("idf", 8.8), use_idd(8.8, "auto")), "Idf") + expect_is(con <- IdfObject$new(2, parent = idf), "IdfObject") + + expect_is(format(con), "character") + expect_equal(as.character(con), con$to_string()) + expect_output(str(con)) + expect_output(print(con)) +}) +# }}} + +# S3 SUBSET {{{ +test_that("$.IdfObject and [[.IdfObject", { + expect_is(idf <- read_idf(text("idf", 8.8), use_idd(8.8, "auto")), "Idf") + expect_is(mat <- IdfObject$new(1, parent = idf), "IdfObject") + + expect_error(mat[1, 2]) + expect_equal(mat[1:2], list(Name = "WD01", Roughness = "MediumSmooth")) - # S3 {{{ expect_equal(mat$Roughness, "MediumSmooth") expect_null(mat$rOuGhness) + expect_equal(mat[["Roughness"]], "MediumSmooth") expect_null(mat[["roughness"]]) + expect_error(mat[[1:2]]) +}) +# }}} + +# S3 ASSIGN {{{ +test_that("$<-.IdfObject and [[<-.IdfObject", { + expect_is(idf <- read_idf(text("idf", 8.8), use_idd(8.8, "auto")), "Idf") + expect_is(mat <- IdfObject$new(1, parent = idf), "IdfObject") + + expect_error(mat$name <- "Smooth") expect_silent(mat$Roughness <- "Smooth") expect_equal(mat$Roughness, "Smooth") expect_silent(mat[["Roughness"]] <- "MediumSmooth") expect_equal(mat[["Roughness"]], "MediumSmooth") + expect_silent(mat[[2]] <- "Rough") + expect_equal(mat[[2]], "Rough") expect_error(mat$roughness <- "Smooth", "cannot add bindings to") expect_error(mat[["roughness"]] <- "Smooth", "cannot add bindings to") @@ -392,15 +563,57 @@ test_that("IdfObject class", { expect_silent(mat[["Visible Absorptance"]] <- 0.8) expect_equal(mat[["Visible Absorptance"]], 0.8, tolerance = 1e-5) expect_error(mat[["Visible_Absorptance"]] <- 0.8, "cannot add bindings to") + expect_silent(mat[["Visible Absorptance"]] <- NULL) + expect_error(mat[[1:2]] <- 0.8) + expect_error(mat[["name"]] <- 0.8) +}) +# }}} + +# S3 EQUITY {{{ +test_that("==.IdfObject and !=.IdfObject", { + expect_is(idf <- read_idf(text("idf", 8.8), use_idd(8.8, "auto")), "Idf") + expect_is(mat <- IdfObject$new(1, parent = idf), "IdfObject") + expect_is(con <- IdfObject$new(2, parent = idf), "IdfObject") - # can check equality + expect_false(con == TRUE) expect_true(con == con) expect_false(con == mat) expect_false(con != con) expect_true(con != mat) - # }}} +}) +# }}} - expect_output(con$print()) - expect_output(con$print(all = TRUE), "11 :") +# IDF_OBJECT {{{ +test_that("idf_object()", { + expect_error(idf_object()) + + idf <- read_idf(text("idf", 8.8), use_idd(8.8, "auto")) + + expect_error(idf_object(parent = idf)) + + expect_error(idf_object(idf, class = "Construction")) + expect_is(obj <- without_checking(idf_object(idf, class = "Construction")), "IdfObject") + expect_equal(obj$class_name(), "Construction") + + expect_is(idf_object(idf, 5), "IdfObject") +}) +# }}} + +# ACTIVE BINDING {{{ +test_that("add_idfobj_field_bindings()", { + expect_is(idf <- read_idf(text("idf", 8.8), use_idd(8.8, "auto")), "Idf") + + expect_is(ver <- with_option(list(autocomplete = FALSE), add_idfobj_field_bindings(IdfObject$new(5, parent = idf))), "IdfObject") + expect_false("Version Identifier" %in% ls(obj)) + + expect_is(ver <- with_option(list(autocomplete = TRUE), add_idfobj_field_bindings(IdfObject$new(5, parent = idf))), "IdfObject") + expect_true("Version Identifier" %in% ls(ver)) + + expect_is(mat <- with_option(list(autocomplete = TRUE), add_idfobj_field_bindings(IdfObject$new(1, parent = idf))), "IdfObject") + expect_true(all(mat$definition()$field_name() %in% ls(mat))) + expect_silent(mat$Visible_Absorptance <- NULL) + expect_silent(mat <- add_idfobj_field_bindings(mat, update = TRUE)) + expect_equal(length(mat$value()), 8) + expect_false("Visual Absorptance" %in% ls(mat)) }) # }}} diff --git a/tests/testthat/test_impl-idd.R b/tests/testthat/test-impl-idd.R similarity index 98% rename from tests/testthat/test_impl-idd.R rename to tests/testthat/test-impl-idd.R index cf8eb1c05..52184976e 100644 --- a/tests/testthat/test_impl-idd.R +++ b/tests/testthat/test-impl-idd.R @@ -1,4 +1,3 @@ -# IDD {{{ test_that("IDD implementation", { expect_silent(idd_parsed <- parse_idd_file(text("idd", "9.9.9"))) @@ -61,6 +60,10 @@ test_that("IDD implementation", { expect_equivalent(names(get_idd_class_field_num(idd_parsed$class[0L])), names(set(idd_parsed$class[0L], NULL, c("input_num", "acceptable_num"), integer(0))[]) ) + + expect_equal(get_class_component_name("Material"), "Material") + expect_equal(get_class_component_name("Material:NoMass"), "Material") + expect_equal(get_class_component_name("BuildingSurface:Detailed"), "BuildingSurface") # }}} # EXTENSIBLE GROUP {{{ @@ -339,4 +342,3 @@ test_that("IDD implementation", { ) # }}} }) -# }}} diff --git a/tests/testthat/test_impl-iddobj.R b/tests/testthat/test-impl-iddobj.R similarity index 100% rename from tests/testthat/test_impl-iddobj.R rename to tests/testthat/test-impl-iddobj.R diff --git a/tests/testthat/test_impl-idf.R b/tests/testthat/test-impl-idf.R similarity index 81% rename from tests/testthat/test_impl-idf.R rename to tests/testthat/test-impl-idf.R index 1c1e83c0e..3efcf79e8 100644 --- a/tests/testthat/test_impl-idf.R +++ b/tests/testthat/test-impl-idf.R @@ -10,32 +10,35 @@ test_that("table", { # OBJECT {{{ expect_equal(get_idf_object(idd_env, idf_env, 1), - data.table(class_id = 1L, object_id = 5L, comment = list(), - object_name = NA_character_, object_name_lower = NA_character_, - rleid = 1L, class_name = "Version" + data.table(rleid = 1L, class_id = 1L, class_name = "Version", + object_id = 5L, object_name = NA_character_, + object_name_lower = NA_character_, comment = list() ) ) expect_equal(get_idf_object(idd_env, idf_env, "Version"), - data.table(class_id = 1L, object_id = 5L, comment = list(), - object_name = NA_character_, object_name_lower = NA_character_, - rleid = 1L, class_name = "Version" + data.table(rleid = 1L, class_id = 1L, class_name = "Version", + object_id = 5L, object_name = NA_character_, + object_name_lower = NA_character_, comment = list() ) ) expect_equal(get_idf_object(idd_env, idf_env, "Version", 5), - data.table(object_id = 5L, class_id = 1L, comment = list(), - object_name = NA_character_, object_name_lower = NA_character_, - class_name = "Version", rleid = 1L + data.table(rleid = 1L, class_id = 1L, class_name = "Version", + object_id = 5L, object_name = NA_character_, + object_name_lower = NA_character_, comment = list() ) ) expect_equal(get_idf_object(idd_env, idf_env, "Version", 5, c("num_fields")), - data.table(object_id = 5L, class_id = 1L, comment = list(), - object_name = NA_character_, object_name_lower = NA_character_, - class_name = "Version", num_fields = 1L, rleid = 1L + data.table(rleid = 1L, class_id = 1L, class_name = "Version", + object_id = 5L, object_name = NA_character_, + object_name_lower = NA_character_, comment = list(), num_fields = 1L ) ) - expect_equal(get_idf_object(idd_env, idf_env), add_rleid(add_class_name(idd_env, copy(idf_env$object)))) + expect_equal(get_idf_object(idd_env, idf_env), setcolorder(add_rleid(add_class_name(idd_env, copy(idf_env$object))), c("rleid", "class_id", "class_name"))) expect_equal(get_idf_object(idd_env, idf_env, property = "has_name"), - add_rleid(add_class_property(idd_env, add_class_name(idd_env, copy(idf_env$object)), "has_name"))) + setcolorder(add_rleid(add_class_property(idd_env, add_class_name(idd_env, copy(idf_env$object)), "has_name")), + c("rleid", "class_id", "class_name") + ) + ) expect_equal(get_idf_object(idd_env, idf_env, 55, property = "has_name")$has_name, c(TRUE, TRUE)) expect_equal(get_idf_object(idd_env, idf_env, 55)$object_id, c(1L, 4L)) expect_equal(get_idf_object(idd_env, idf_env, 55, c("WD02", "WD01"))$object_id, c(4L, 1L)) @@ -47,6 +50,17 @@ test_that("table", { expect_error(get_idf_object(idd_env, idf_env, "Material", 15), class = "eplusr_error_invalid_object_id") expect_equal(get_idf_object(idd_env, idf_env, 55, c("wd02", "wd01"), ignore_case = TRUE)$object_id, c(4L, 1L)) + expect_equal(get_idf_object_multi_scope(idd_env, idf_env)$object_id, 1:5) + expect_equal(get_idf_object_multi_scope(idd_env, idf_env, 1, "Construction", "Thermal Zones and Surfaces"), + data.table(rleid = 1:3, class_id = c(55L, 90L, 103L), + class_name = c("Material", "Construction", "BuildingSurface:Detailed"), + object_id = 1:3, + object_name = c("WD01", "WALL-1", "WALL-1PF"), + object_name_lower = c("wd01", "wall-1", "wall-1pf"), + comment = list(" this is a test comment for WD01", NULL, NULL) + ) + ) + # can stop if same names found in input class idf_env1 <- idf_env idf_env1$object <- rbindlist(list(idf_env1$object, idf_env1$object[1][, object_id := 6L])) @@ -123,8 +137,8 @@ test_that("table", { # get all value from current idf {{{ expect_equivalent(nrow(get_idf_value(idd_env, idf_env)), 44L) expect_equivalent(names(get_idf_value(idd_env, idf_env)), - c("value_id", "value_chr", "value_num", "object_id", "field_id", - "class_id", "object_name", "class_name", "rleid", "field_index", "field_name" + c("rleid", "class_id", "class_name", "object_id", "object_name", + "field_id", "field_index", "field_name", "value_id", "value_chr", "value_num" ) ) # }}} @@ -469,6 +483,9 @@ test_that("table", { # can specify target class expect_equal(get_idf_relation(idd_env, idf_env, 51L, depth = NULL, class = "Schedule:Constant", name = TRUE)$src_class_name, "Schedule:Constant") + # can specify non-existing class + expect_equal(nrow(get_idf_relation(idd_env, idf_env, 51L, depth = NULL, class = "Window")), 0L) + # can specify target object expect_equal(get_idf_relation(idd_env, idf_env, 51L, object = 53L, name = TRUE)$src_object_name, "AlwaysOn") @@ -492,9 +509,52 @@ test_that("table", { idf_env <- parse_idf_file(path_idf, 8.8) idd_env <- get_priv_env(use_idd(8.8))$idd_env() - id <- get_idf_value(idd_env, idf_env, object = 277L, field = 5)$value_id - expect_equal(nrow(get_idf_node_relation(idd_env, idf_env, value_id = id, depth = NULL)), 10L) - expect_equal(nrow(get_idf_node_relation(idd_env, idf_env, 277L, depth = NULL)), 12L) + expect_error(get_idf_node_relation(idd_env, idf_env)) + + val <- get_idf_value(idd_env, idf_env, object = 277L, field = 5) + expect_equal(nrow(get_idf_node_relation(idd_env, idf_env, value_id = val$value_id, depth = NULL)), 10L) + expect_equal(nrow(get_idf_node_relation(idd_env, idf_env, val$object_id, depth = NULL)), 12L) + expect_equal(nrow(get_idf_node_relation(idd_env, idf_env, val$object_id, depth = NULL, keep_all = TRUE)), 26L) + expect_equal(nrow(get_idf_node_relation(idd_env, idf_env, val$object_id, val$value_id, depth = NULL)), 10L) + + # can specify object id + expect_equal(nrow(get_idf_node_relation(idd_env, idf_env, val$object_id, depth = NULL)), 12L) + + # can specify value id + expect_equal(nrow(get_idf_node_relation(idd_env, idf_env, value_id = val$value_id, depth = NULL)), 10L) + + # can specify both object id and value id + expect_equal(nrow(get_idf_node_relation(idd_env, idf_env, val$object_id, val$value_id, depth = NULL)), 10L) + + # can keep all input id + expect_equal(nrow(get_idf_node_relation(idd_env, idf_env, val$object_id, depth = NULL, keep_all = TRUE)), 26L) + + # can add format columns + expect_is(rel <- get_idf_node_relation(idd_env, idf_env, val$object_id, depth = NULL, name = TRUE), "data.table") + expect_equal(names(rel), c( + "class_id", "class_name", + "object_id", "object_name", + "field_id", "field_index", "field_name", + "value_id", "value_chr", "value_num", "type_enum", + "src_class_id", "src_class_name", + "src_object_id", "src_object_name", + "src_field_id", "src_field_index", "src_field_name", + "src_value_id", "src_value_chr", "src_value_num", "src_type_enum", + "src_enum", "dep" + )) + + # can specify target group + expect_equal(get_idf_node_relation(idd_env, idf_env, val$object_id, depth = NULL, group = "Node-Branch Management", name = TRUE)$class_name, + c(rep("Branch", 5), rep("Pipe:Adiabatic", 4))) + + # can specify target class + expect_equal(get_idf_node_relation(idd_env, idf_env, val$object_id, depth = NULL, class = "Branch", name = TRUE)$class_name, rep("Branch", 5)) + + # can specify non-existing class + expect_equal(nrow(get_idf_node_relation(idd_env, idf_env, val$object_id, depth = NULL, class = "Window")), 0L) + + # can specify target object + expect_equal(get_idf_node_relation(idd_env, idf_env, val$object_id, object = 223, name = TRUE)$class_name, "Branch") # }}} }) # }}} @@ -525,32 +585,37 @@ test_that("NAME DOTS", { # can work with only object ID inputs expect_equal( expand_idf_dots_name(idd_env, idf_env, 1:2, a = 3, .property = "has_name")[, -"comment"], - data.table(rleid = 1:3, object_id = 1:3, class_id = c(1L, 13L, 3L), + data.table(rleid = 1:3, + class_id = c(1L, 13L, 3L), class_name = c("Version", "Timestep", "Building"), + object_id = 1:3, object_name = c(NA_character_, NA_character_, "Simple One Zone (Wireframe DXF)"), object_name_lower = c(NA_character_, NA_character_, "simple one zone (wireframe dxf)"), - class_name = c("Version", "Timestep", "Building"), - has_name = c(FALSE, FALSE, TRUE), - new_object_name = c(NA_character_, NA_character_, "a") + new_object_name = c(NA_character_, NA_character_, "a"), + has_name = c(FALSE, FALSE, TRUE) ) ) # can exclude input names expect_equal( expand_idf_dots_name(idd_env, idf_env, 1:2, 3, .keep_name = FALSE)[, -"comment"], - data.table(rleid = 1:3, object_id = 1:3, class_id = c(1L, 13L, 3L), + data.table(rleid = 1:3, + class_id = c(1L, 13L, 3L), + class_name = c("Version", "Timestep", "Building"), + object_id = 1:3, object_name = c(NA_character_, NA_character_, "Simple One Zone (Wireframe DXF)"), - object_name_lower = c(NA_character_, NA_character_, "simple one zone (wireframe dxf)"), - class_name = c("Version", "Timestep", "Building") + object_name_lower = c(NA_character_, NA_character_, "simple one zone (wireframe dxf)") ) ) # can work with only object name inputs expect_equal( expand_idf_dots_name(idd_env, idf_env, Floor = "floor", c("zone one", l = "extlights"))[, -"comment"], - data.table(rleid = 1:3, object_id = c(16L, 18L, 49L), class_id = c(90L, 100L, 277L), + data.table(rleid = 1:3, + class_id = c(90L, 100L, 277L), + class_name = c("Construction", "Zone", "Exterior:Lights"), + object_id = c(16L, 18L, 49L), object_name = c("FLOOR", "ZONE ONE", "ExtLights"), object_name_lower = c("floor", "zone one", "extlights"), - class_name = c("Construction", "Zone", "Exterior:Lights"), new_object_name = c("Floor", NA_character_, "l") ) ) @@ -558,20 +623,24 @@ test_that("NAME DOTS", { # can exclude input names expect_equal( expand_idf_dots_name(idd_env, idf_env, Floor = "floor", c("zone one", l = "extlights"), .keep_name = FALSE)[, -"comment"], - data.table(rleid = 1:3, object_id = c(16L, 18L, 49L), class_id = c(90L, 100L, 277L), + data.table(rleid = 1:3, + class_id = c(90L, 100L, 277L), + class_name = c("Construction", "Zone", "Exterior:Lights"), + object_id = c(16L, 18L, 49L), object_name = c("FLOOR", "ZONE ONE", "ExtLights"), - object_name_lower = c("floor", "zone one", "extlights"), - class_name = c("Construction", "Zone", "Exterior:Lights") + object_name_lower = c("floor", "zone one", "extlights") ) ) # can work with both object ID and name inputs expect_equal( expand_idf_dots_name(idd_env, idf_env, 1L, Floor = "floor")[, -"comment"], - data.table(rleid = 1:2, object_id = c(1L, 16L), class_id = c(1L, 90L), + data.table(rleid = 1:2, + class_id = c(1L, 90L), + class_name = c("Version", "Construction"), + object_id = c(1L, 16L), object_name = c(NA_character_, "FLOOR"), object_name_lower = c(NA_character_, "floor"), - class_name = c("Version", "Construction"), new_object_name = c(NA_character_, "Floor") ) ) @@ -582,7 +651,7 @@ test_that("NAME DOTS", { test_that("VALUE DOTS", { # parse_dots_value {{{ # can stop if empty input - expect_error(parse_dots_value(), "missing value") + expect_error(parse_dots_value(), "Must have length >= 1") expect_error(parse_dots_value(NULL), "missing value") # can stop if not named @@ -814,12 +883,12 @@ test_that("VALUE DOTS", { ) ) ) - expect_equal({x <- list(a = list(1), b = list()); parse_dots_value(x, .empty = TRUE)}, - list(object = data.table(rleid = 1:2, each_rleid = 1L, id = NA_integer_, name = c("a", "b"), - comment = list(), is_ref = FALSE, lhs_sgl = FALSE, rhs_sgl = TRUE, is_empty = c(FALSE, TRUE)), - value = data.table(rleid = 1:2, each_rleid = 1L, id = NA_integer_, name = c("a", "b"), + expect_equal({x <- list(a = list(1), b = list(), ..5 = list()); parse_dots_value(x, .empty = TRUE)}, + list(object = data.table(rleid = 1:3, each_rleid = 1L, id = c(NA, NA, 5L), name = c("a", "b", NA), + comment = list(), is_ref = FALSE, lhs_sgl = FALSE, rhs_sgl = TRUE, is_empty = c(FALSE, TRUE, TRUE)), + value = data.table(rleid = 1:3, each_rleid = 1L, id = c(NA, NA, 5L), name = c("a", "b", NA), field_index = NA_integer_, field_name = NA_character_, - value_chr = c("1", NA_character_), value_num = c(1, NA_real_) + value_chr = c("1", NA, NA), value_num = c(1, NA, NA) ) ) ) @@ -1287,6 +1356,8 @@ test_that("OBJECT DOTS", { # can proceed if version is not the same expect_is(expand_idf_dots_object(idd_env, idf_env, empty_idf(8.7), .strict = FALSE), "list") + + expect_silent(expand_idf_dots_value(idd_env, idf_env, ..53 = list("sch"), .type = "object", .empty = FALSE)) }) # }}} @@ -1401,7 +1472,7 @@ test_that("LITERAL DOTS", { expect_equal(l$value$class_id, c(rep(55L, 6), rep(56L, 24))) expect_equal(l$value$object_id, rep(c(14L, 12L, 13L, 12L, 13L), each = 6)) expect_equal(l$value$object_name, c(rep("C5 - 4 IN HW CONCRETE", 6), rep(rep(c("R13LAYER", "R31LAYER"), 2), each = 6))) - expect_equal(l$value$value_id, c(1:6, rep(87:98, 2))) + expect_equal(l$value$value_id, c(rep(99:101, 2), rep(87:98, 2))) expect_equal(l$value$value_num, c(rep(c(NA, NA, 0.2), 2), rep(c(NA, NA, 2.290965, 0.9, 0.75, 0.75, NA, NA, 5.456, 0.9, 0.75, 0.75), 2))) }) # }}} @@ -1515,7 +1586,7 @@ test_that("make_idf_object_name", { set(obj, 1L, "object_name_lower", "construction") set(obj, 1L, "new_object_name", "Const") set(obj, 1L, "new_object_name_lower", "const") - make_idf_object_name(idd_env, idf_env, obj, include_ori = FALSE)[] + make_idf_object_name(idd_env, idf_env, obj, include_ori = FALSE) }, data.table(rleid = 1:2, class_id = 90L, class_name = "Construction", group_id = 5L, object_id = 54:55, @@ -1532,7 +1603,7 @@ test_that("make_idf_object_name", { obj <- init_idf_object(idd_env, idf_env, c(rep("Construction", 3), "Coil:Cooling:Water"), name = FALSE) set(obj, 1L, "object_name", "Const") set(obj, 1L, "object_name_lower", "const") - make_idf_object_name(idd_env, idf_env, obj, keep_na = FALSE)[] + make_idf_object_name(idd_env, idf_env, obj, keep_na = FALSE) }, data.table(rleid = 1:4, class_id = c(rep(90L, 3), 390L), class_name = c(rep("Construction", 3), "Coil:Cooling:Water"), @@ -1564,32 +1635,20 @@ test_that("Dup", { "RunPeriod.*R31LAYER 1" ) expect_is(dup, "list") - expect_equal(names(dup), c("object", "value", "reference")) - expect_equal(dup$object, - data.table(rleid = 1:4, class_id = c(22L, 22L, 56L, 56L), - class_name = c("RunPeriod", "RunPeriod", "Material:NoMass", "Material:NoMass"), + expect_equal(names(dup), c("object", "value", "reference", "changed", "updated")) + expect_equal(nrow(dup$object), 57) + expect_equal(dup$object[54:57], + data.table( object_id = 54:57, object_name = c("RunPeriod", "Annual", "nomass", "R31LAYER 1"), object_name_lower = c("runperiod", "annual", "nomass", "r31layer 1"), - comment = list() + comment = list(), + class_id = c(22L, 22L, 56L, 56L) ) ) - expect_equal(dup$value, + expect_equal(nrow(dup$value), 382) + expect_equal(dup$value[349:382], data.table( - rleid = c(rep(1L, 11), rep(2L, 11), rep(3L, 6), rep(4L, 6)), - class_id = c(rep(22L, 22), rep(56L, 12)), - class_name = c(rep("RunPeriod", 22), rep("Material:NoMass", 12)), - object_id = c(rep(54L, 11), rep(55L, 11), rep(56L, 6), rep(57L, 6)), - object_name = c(rep(NA_character_, 22), rep("R31LAYER", 12)), - field_id = c(104:114, 104:114, 7090:7095, 7090:7095), - field_index = c(1:11, 1:11, 1:6, 1:6), - field_name = c( - rep(c("Name", "Begin Month", "Begin Day of Month", "End Month", "End Day of Month", - "Day of Week for Start Day", "Use Weather File Holidays and Special Days", - "Use Weather File Daylight Saving Period", "Apply Weekend Holiday Rule", - "Use Weather File Rain Indicators", "Use Weather File Snow Indicators"), 2L), - rep(c("Name", "Roughness", "Thermal Resistance", "Thermal Absorptance", - "Solar Absorptance", "Visible Absorptance"), 2L)), value_id = 349:382, value_chr = c( "RunPeriod", "1", "1", "12", "31", "Tuesday", "Yes", "Yes", "No", "Yes", "Yes", @@ -1600,15 +1659,14 @@ test_that("Dup", { NA, 1, 1, 12, 31, NA, NA, NA, NA, NA, NA, NA, 1, 1, 12, 31, NA, NA, NA, NA, NA, NA, NA, NA, 5.456, 0.9, 0.75, 0.75, - NA, NA, 5.456, 0.9, 0.75, 0.75) - ) - ) - expect_equal(dup$reference, - data.table(object_id = integer(), value_id = integer(), - src_object_id = integer(), src_value_id = integer(), - src_enum = integer() + NA, NA, 5.456, 0.9, 0.75, 0.75), + object_id = c(rep(54L, 11), rep(55L, 11), rep(56L, 6), rep(57L, 6)), + field_id = c(104:114, 104:114, 7090:7095, 7090:7095) ) ) + expect_equal(nrow(dup$reference), 21) + expect_equal(dup$changed, 54:57) + expect_equal(dup$updated, integer()) }) # }}} @@ -1648,43 +1706,17 @@ test_that("Add", { }, class = "eplusr_error_validity_check") # can remove input objects that are the same as existing ones - expect_equal( + expect_is(class = "list", { l <- expand_idf_dots_value(idd_env, idf_env, floor = list(), .type = "object") - add_idf_object(idd_env, idf_env, l$object, l$value, level = "none", unique = TRUE) - }, - list( - object = data.table( - rleid = integer(), - class_id = integer(), - class_name = character(), - object_id = integer(), - object_name = character(), - object_name_lower = character(), - comment = list() - ), - value = data.table( - rleid = integer(), - class_id = integer(), - class_name = character(), - object_id = integer(), - object_name = character(), - field_id = integer(), - field_index = integer(), - field_name = character(), - value_id = integer(), - value_chr = character(), - value_num = double() - ), - reference = data.table( - object_id = integer(), - value_id = integer(), - src_object_id = integer(), - src_value_id = integer(), - src_enum = integer() - ) - ) + l <- add_idf_object(idd_env, idf_env, l$object, l$value, level = "none", unique = TRUE) + } ) + expect_equal(nrow(l$object), 53) + expect_equal(nrow(l$value), 348) + expect_equal(nrow(l$reference), 21) + expect_equal(l$changed, integer()) + expect_equal(l$updated, integer()) # can handle references expect_equal( @@ -1694,14 +1726,14 @@ test_that("Add", { Construction = list("NewConst", "NewMat"), Material = list("NewMat"), .unique = FALSE ) - add_idf_object(idd_env, idf_env, l$object, l$value, level = custom_validate(reference = TRUE))$reference + add_idf_object(idd_env, idf_env, l$object, l$value, level = custom_validate(reference = TRUE))$reference[22:23] }, data.table(object_id = 54:55, value_id = c(350L, 352L), src_object_id = c(12L, 56L), src_value_id = c(87L, 353L), src_enum = 2L) ) # whole game - expect_equal( + expect_is(class = "list", { l <- expand_idf_dots_value(idd_env, idf_env, Material := list(paste("Mat", 1:3)), @@ -1710,56 +1742,45 @@ test_that("Add", { Zone = list("Zone"), .scalar = FALSE, .pair = TRUE, .empty = TRUE, .unique = FALSE ) - add_idf_object(idd_env, idf_env, l$object, l$value, level = "none", unique = TRUE) - }, - list( - object = data.table( - rleid = 1:6, - class_id = c(55L, 55L, 55L, 90L, 103L, 100L), - class_name = c("Material", "Material", "Material", "Construction", "BuildingSurface:Detailed", "Zone"), - object_id = 54:59, - object_name = c("Mat 1", "Mat 2", "Mat 3", "Const", "Surf", "Zone"), - object_name_lower = c("mat 1", "mat 2", "mat 3", "const", "surf", "zone"), - comment = list() - ), - value = data.table( - rleid = c(rep(1L, 6), rep(2L, 6), rep(3L, 6), rep(4L, 4), rep(5L, 19), 6L), - class_id = c(rep(55L, 18), rep(90L, 4), rep(103L, 19), 100L), - class_name = c(rep("Material", 18), rep("Construction", 4), rep("BuildingSurface:Detailed", 19), "Zone"), - object_id = c(rep(54L, 6), rep(55L, 6), rep(56L, 6), rep(57L, 4), rep(58L, 19), 59L), - object_name = c(rep("Mat 1", 6), rep("Mat 2", 6), rep("Mat 3", 6), rep("Const", 4), rep("Surf", 19), "Zone"), - field_id = c(rep(7081:7086, 3), 11006:11009, 11622:11640, 11105L), - field_index = c(rep(1:6, 3), 1:4, 1:19, 1L), - field_name = c( - rep(c("Name", "Roughness", "Thickness", "Conductivity", "Density", "Specific Heat"), 3), - "Name", "Outside Layer", "Layer 2", "Layer 3", - "Name", "Surface Type", "Construction Name", "Zone Name", "Outside Boundary Condition", - "Outside Boundary Condition Object", "Sun Exposure", "Wind Exposure", - "View Factor to Ground", "Number of Vertices", - "Vertex 1 X-coordinate", "Vertex 1 Y-coordinate", "Vertex 1 Z-coordinate", - "Vertex 2 X-coordinate", "Vertex 2 Y-coordinate", "Vertex 2 Z-coordinate", - "Vertex 3 X-coordinate", "Vertex 3 Y-coordinate", "Vertex 3 Z-coordinate", - "Name"), - value_id = 349:390, - value_chr = c( - "Mat 1", NA, NA, NA, NA, NA, - "Mat 2", NA, NA, NA, NA, NA, - "Mat 3", NA, NA, NA, NA, NA, - "Const", "Mat1", "Mat2", "Mat3", - "Surf", "Floor", "Const", "Zone", NA, NA, "SunExposed", - "WindExposed", "autocalculate", "autocalculate", - NA, NA, NA, NA, NA, NA, NA, NA, NA, "Zone"), - value_num = NA_real_ - ), - reference = data.table( - object_id = c(57L, 57L, 57L, 58L, 58L), - value_id = c(368L, 369L, 370L, 373L, 374L), - src_object_id = c(NA, NA, NA, 57L, 59L), - src_value_id = c(NA, NA, NA, 367L, 390L), - src_enum = c(NA, NA, NA, 2L, 2L) - ) + l <- add_idf_object(idd_env, idf_env, l$object, l$value, level = "none", unique = TRUE) + } + ) + expect_equal(l$object[54:59], + object = data.table( + object_id = 54:59, + object_name = c("Mat 1", "Mat 2", "Mat 3", "Const", "Surf", "Zone"), + object_name_lower = c("mat 1", "mat 2", "mat 3", "const", "surf", "zone"), + comment = list(), + class_id = c(55L, 55L, 55L, 90L, 103L, 100L) + ) + ) + expect_equal(l$value[349:390], + data.table( + value_id = 349:390, + value_chr = c( + "Mat 1", NA, NA, NA, NA, NA, + "Mat 2", NA, NA, NA, NA, NA, + "Mat 3", NA, NA, NA, NA, NA, + "Const", "Mat1", "Mat2", "Mat3", + "Surf", "Floor", "Const", "Zone", NA, NA, "SunExposed", + "WindExposed", "autocalculate", "autocalculate", + NA, NA, NA, NA, NA, NA, NA, NA, NA, "Zone"), + value_num = NA_real_, + object_id = c(rep(54L, 6), rep(55L, 6), rep(56L, 6), rep(57L, 4), rep(58L, 19), 59L), + field_id = c(rep(7081:7086, 3), 11006:11009, 11622:11640, 11105L) + ) + ) + expect_equal(l$reference[22:26], + data.table( + object_id = c(57L, 57L, 57L, 58L, 58L), + value_id = c(368L, 369L, 370L, 373L, 374L), + src_object_id = c(NA, NA, NA, 57L, 59L), + src_value_id = c(NA, NA, NA, 367L, 390L), + src_enum = c(NA, NA, NA, 2L, 2L) ) ) + expect_equal(l$changed, 54:59) + expect_equal(l$updated, integer()) }) # }}} @@ -1792,13 +1813,15 @@ test_that("Set", { rp <- set_idf_object(idd_env, idf_env, l$object, l$value) } ) - expect_equal(nrow(rp$object), 1L) - expect_equal(rp$object$object_id, 8L) - expect_equal(rp$object$object_name, "Test") - expect_equal(rp$object$object_name_lower, "test") - expect_equal(nrow(rp$value), 11L) - expect_equal(rp$value$value_chr[1L], "Test") - expect_equal(nrow(rp$reference), 0L) + expect_equal(nrow(rp$object), 53L) + expect_equal(rp$object$object_id[8], 8L) + expect_equal(rp$object$object_name[8], "Test") + expect_equal(rp$object$object_name_lower[8], "test") + expect_equal(nrow(rp$value), 348L) + expect_equal(rp$value$value_chr[19L], "Test") + expect_equal(nrow(rp$reference), 21L) + expect_equal(rp$changed, 8L) + expect_equal(rp$updated, integer()) expect_is(class = "list", { @@ -1806,18 +1829,20 @@ test_that("Set", { floor <- set_idf_object(idd_env, idf_env, l$object, l$value) } ) - expect_equal(nrow(floor$object), 1L) - expect_equal(floor$object$object_id, 16) - expect_equal(floor$object$object_name, "Flr") - expect_equal(floor$object$object_name_lower, "flr") - expect_equal(nrow(floor$value), 2) - expect_equal(floor$value$value_chr[1L], "Flr") - expect_equal(floor$reference, + expect_equal(nrow(floor$object), 53L) + expect_equal(floor$object$object_id[16], 16) + expect_equal(floor$object$object_name[16], "Flr") + expect_equal(floor$object$object_name_lower[16], "flr") + expect_equal(nrow(floor$value), 348) + expect_equal(floor$value$value_chr[220L], "Flr") + expect_equal(floor$reference[20:21], data.table(object_id = c(16L, 25L), value_id = c(111L, 220L), src_object_id = c(14L, 16L), src_value_id = c(99L, 110L), src_enum = 2L ) ) + expect_equal(floor$changed, 16L) + expect_equal(floor$updated, 25L) # delete fields expect_is(class = "list", @@ -1826,13 +1851,23 @@ test_that("Set", { rp <- set_idf_object(idd_env, idf_env, l$object, l$value) } ) - expect_equal(nrow(rp$object), 1L) - expect_equal(rp$object$object_id, 8L) - expect_equal(rp$object$object_name, "name") - expect_equal(rp$object$object_name_lower, "name") - expect_equal(nrow(rp$value), 11L) - expect_equal(rp$value$value_chr[1L], "name") - expect_equal(nrow(rp$reference), 0L) + expect_equal(nrow(rp$object), 53) + expect_equal(rp$object$object_id[8], 8L) + expect_equal(rp$object$object_name[8], "name") + expect_equal(rp$object$object_name_lower[8], "name") + expect_equal(nrow(rp$value), 348L) + expect_equal(rp$value$value_chr[19L], "name") + expect_equal(nrow(rp$reference), 21) + expect_equal(rp$changed, 8L) + expect_equal(rp$updated, integer()) + + expect_is(class = "list", + { + l <- expand_idf_dots_value(idd_env, idf_env, ..14 = list(visible_absorptance = NULL), .type = "object", .default = FALSE) + mat <- set_idf_object(idd_env, idf_env, l$object, l$value) + } + ) + expect_equal(nrow(get_idf_value(idd_env, mat, object = 14)), 8) # can set whole class expect_is(class = "list", @@ -1843,38 +1878,42 @@ test_that("Set", { mat <- set_idf_object(idd_env, idf_env, l$object, l$value) } ) - expect_equal(nrow(mat$object), 2L) - expect_equal(mat$object$object_id, 12:13) - expect_equal(mat$object$object_name, c("R13LAYER", "R31LAYER")) - expect_equal(mat$object$object_name_lower, c("r13layer", "r31layer")) - expect_equal(nrow(mat$value), 8L) - expect_equal(mat$value$field_index, rep(1:4, 2)) - expect_equal(mat$value$value_chr[c(4, 8)], c("0.8", "0.8")) - expect_equal(mat$reference, + expect_equal(nrow(mat$object), 53L) + expect_equal(mat$object$object_id[12:13], 12:13) + expect_equal(mat$object$object_name[12:13], c("R13LAYER", "R31LAYER")) + expect_equal(mat$object$object_name_lower[12:13], c("r13layer", "r31layer")) + expect_equal(get_idf_value(idd_env, mat, "Material:NoMass", field = "roughness")$value_chr, rep("smooth", 2)) + expect_equal(get_idf_value(idd_env, mat, "Material:NoMass", field = "thermal_absorptance")$value_num, rep(0.8, 2)) + expect_equal(mat$reference[20:21], data.table(object_id = c(15L, 17L), value_id = c(109L, 113L), src_object_id = c(12L, 13L), src_value_id = c(87L, 93L), src_enum = 2L ) ) + expect_equal(mat$changed, 12:13) + expect_equal(mat$updated, c(15L, 17L)) # can handle references - expect_equal(class = "list", + expect_is(class = "list", { l <- expand_idf_dots_value(idd_env, idf_env, .type = "object", ROOF31 = list(outside_layer = "R13LAYER"), FLOOR = list(outside_layer = "NoSuchMaterial") ) - set_idf_object(idd_env, idf_env, l$object, l$value, level = "none")$reference - }, + l <- set_idf_object(idd_env, idf_env, l$object, l$value, level = "none") + } + ) + expect_equal(l$reference[19:21], data.table( - object_id = c(17L, 16L, 26L, 25L), - value_id = c(113L, 111L, 242L, 220L), - src_object_id = c(12L, NA, 17L, 16L), - src_value_id = c(87L, NA, 112L, 110L), - src_enum = c(2L, NA, 2L, 2L) + object_id = c(17L, 16L, 26L), + value_id = c(113L, 111L, 242L), + src_object_id = c(12L, NA, 17L), + src_value_id = c(87L, NA, 112L), + src_enum = c(2L, NA, 2L) ) ) - + expect_equal(l$changed, c(17L, 16L)) + expect_equal(l$updated, 26L) }) # }}} @@ -1887,9 +1926,12 @@ test_that("Del", { expect_error(del_idf_object(idd_env, idf_env, get_idf_object(idd_env, idf_env, "Version")), class = "eplusr_error_del_version") expect_error(del_idf_object(idd_env, idf_env, get_idf_object(idd_env, idf_env, object = 3)), class = "eplusr_error_del_required") expect_error(del_idf_object(idd_env, idf_env, get_idf_object(idd_env, idf_env, object = 7)), class = "eplusr_error_del_unique") + expect_error(del_idf_object(idd_env, idf_env, get_idf_object(idd_env, idf_env, object = rep(53, 2))), class = "eplusr_error_del_same") expect_error(del_idf_object(idd_env, idf_env, get_idf_object(idd_env, idf_env, object = c("R13WALL", "FLOOR", "ROOF31"))), class = "eplusr_error_del_referenced") expect_message({del <- with_option(list(verbose_info = TRUE), del_idf_object(idd_env, idf_env, get_idf_object(idd_env, idf_env, object = c(21:26, 14)), ref_to = TRUE, ref_by = TRUE, recursive = TRUE))}, "relation") - expect_equivalent(setdiff(idf_env$object$object_id, del$object$object_id), c(14:17, 21:26)) + expect_equal(setdiff(idf_env$object$object_id, del$object$object_id), c(14:17, 21:26)) + expect_equal(del$changed, c(21:26, 14:17)) + expect_equal(del$updated, integer()) }) # }}} @@ -1900,19 +1942,25 @@ test_that("Purge", { idd_env <- get_priv_env(use_idd(8.8))$idd_env() expect_message(pu <- with_option(list(verbose_info = TRUE), purge_idf_object(idd_env, idf_env, get_idf_object(idd_env, idf_env, "SimulationControl"))), "ignored") - expect_equal(pu$object, data.table()) - expect_equal(pu$value, data.table()) - expect_equal(pu$reference, data.table()) + expect_equal(pu$object, idf_env$object) + expect_equal(pu$value, idf_env$value) + expect_equal(pu$reference, idf_env$reference) + expect_equal(pu$changed, integer()) + expect_equal(pu$updated, integer()) expect_is(pu <- purge_idf_object(idd_env, idf_env, get_idf_object(idd_env, idf_env, "Material:NoMass")), "list") - expect_equal(pu$object, data.table()) - expect_equal(pu$value, data.table()) - expect_equal(pu$reference, data.table()) + expect_equal(pu$object, idf_env$object) + expect_equal(pu$value, idf_env$value) + expect_equal(pu$reference, idf_env$reference) + expect_equal(pu$changed, integer()) + expect_equal(pu$updated, integer()) expect_is(pu <- purge_idf_object(idd_env, idf_env, get_idf_object(idd_env, idf_env, "RunPeriod")), "list") - expect_equal(pu$object$object_id, 8L) - expect_equal(nrow(pu$value), 11L) - expect_equal(nrow(pu$reference), 0L) + expect_equal(setdiff(idf_env$object$object_id, pu$object$object_id), 8L) + expect_equal(nrow(pu$value), 337L) + expect_equal(pu$reference, idf_env$reference) + expect_equal(pu$changed, 8L) + expect_equal(pu$updated, integer()) }) # }}} @@ -1922,9 +1970,8 @@ test_that("Duplicated", { idf_env <- parse_idf_file(example(), 8.8) idd_env <- get_priv_env(use_idd(8.8))$idd_env() - dup_idf_object(idd_env, idf_env, get_idf_object(idd_env, idf_env, "SimulationControl"), "none") - expect_equal(duplicated_idf_object(idd_env, idf_env, get_idf_object(idd_env, idf_env))$duplicated, rep(FALSE, 53)) - expect_equal(duplicated_idf_object(idd_env, idf_env, get_idf_object(idd_env, idf_env))$duplicated, rep(FALSE, 53)) + l <- dup_idf_object(idd_env, idf_env, get_idf_object(idd_env, idf_env, "SimulationControl"), "none") + expect_equal(duplicated_idf_object(idd_env, l, get_idf_object(idd_env, l))$unique_object_id, c(rep(NA, 53), 7L)) }) # }}} @@ -1934,7 +1981,27 @@ test_that("Unique", { idf_env <- parse_idf_file(example(), 8.8) idd_env <- get_priv_env(use_idd(8.8))$idd_env() - expect_equal(duplicated_idf_object(idd_env, idf_env, get_idf_object(idd_env, idf_env))$duplicated, rep(FALSE, 53)) + expect_message(with_option(list(verbose_info = TRUE), unique_idf_object(idd_env, idf_env, get_idf_object(idd_env, idf_env))), "Skip") + + # change references from the original ones to duplicated ones + ori_obj <- get_idf_object(idd_env, idf_env, "Material:NoMass") + ori_val <- get_idf_value(idd_env, idf_env, "Material:NoMass") + l <- dup_idf_object(idd_env, idf_env, ori_obj) + new_val <- data.table::fsetdiff(l$value, idf_env$value) + ref <- set(ori_val[, list(object_id, value_id)], NULL, + c("new_object_id", "new_value_id"), new_val[, list(object_id, value_id)] + ) + l$reference[ref, on = c("src_value_id" = "value_id"), + `:=`(src_object_id = i.new_object_id, src_value_id = i.new_value_id)] + + expect_message(l <- with_option(list(verbose_info = TRUE), unique_idf_object(idd_env, l, get_idf_object(idd_env, l))), + "have been removed" + ) + expect_equivalent(l$object, idf_env$object) + expect_equivalent(l$value, idf_env$value) + expect_equivalent(l$reference, idf_env$reference) + expect_equivalent(l$changed, 54:55) + expect_equivalent(l$updated, c(15L, 17L)) }) # }}} @@ -1993,12 +2060,67 @@ test_that("Rename", { l <- rename_idf_object(idd_env, idf_env, obj) } ) - expect_equal(l$object$object_name, c("r13", "flr", "roof", "r31")) - expect_equal(l$value[field_index == 1L, value_chr], c("r13", "flr", "roof", "r31")) - expect_equal(nrow(l$reference), 7) - expect_equal(idf_env$value[J(l$reference$value_id), on = "value_id", value_chr], + expect_is(get_idf_object(idd_env, l, object = c("r13", "flr", "roof", "r31")), "data.table") + expect_equal(get_idf_value(idd_env, l, object = c("r13", "flr", "roof", "r31"), field = rep(1, 4))$value_chr, + c("r13", "flr", "roof", "r31")) + expect_equal(nrow(data.table::fsetdiff(l$reference, idf_env$reference)), 0) + expect_equal( + { + id <- get_idf_value(idd_env, l, object = c("r13", "flr", "roof", "r31"), field = rep(1, 4))$value_id + id <- l$reference[J(id), on = "src_value_id", value_id] + idf_env$value[J(id), on = "value_id", value_chr] + }, c(rep("r13", 4), "flr", "roof", "r31") ) + expect_equal(l$changed, c(15:17, 13L)) + expect_equal(l$updated, 21:26) +}) +# }}} + +# REMOVE {{{ +test_that("Remove", { + # read idf + idf_env <- parse_idf_file(example(), 8.8) + idd_env <- get_priv_env(use_idd(8.8))$idd_env() + + # REMOVE FIELDS + # can work if no trailing empty fields are found + expect_equal(nrow(remove_empty_fields(idd_env, idf_env, get_idf_value(idd_env, idf_env, "SimulationControl"))), 5L) + # can work for non-extensible fields + val <- get_idf_value(idd_env, idf_env, "Material")[field_index > 7L, + `:=`(value_chr = NA_character_, value_num = NA_real_)] + expect_equal(nrow(remove_empty_fields(idd_env, idf_env, val)), 7L) + # can work for extensible fields + val <- get_idf_value(idd_env, idf_env, object = "Zn001:Wall001", field = 24, complete = TRUE) + ## (a) can skip if extensible group is incomplete + expect_equal(nrow(remove_empty_fields(idd_env, idf_env, val[field_index <= 24L])), 24L) + ## (b) can remove if all extensible fields in a extensible group are empty + expect_equal(nrow(remove_empty_fields(idd_env, idf_env, val)), 22L) + ## (c) can skip if not all extensible fields in a group are empty + expect_equal(nrow(remove_empty_fields(idd_env, idf_env, val[field_index == 24L, value_chr := "1"])), 25L) + + # REMOVE OBJECTS + l <- list() + l1 <- expand_idf_dots_value(idd_env, idf_env, "Site:WeatherStation" = list()) + expect_is(rev <- remove_duplicated_objects(idd_env, idf_env, l1$object, l1$value), "list") + expect_equal(l1$object, rev$object) + expect_equal(l1$value, rev$value) + l2 <- dup_idf_object(idd_env, idf_env, get_idf_object(idd_env, idf_env, object = rep("Zn001:Wall001", 2L))) + l$object <- rbindlist(list( + l1$object, + get_idf_object(idd_env, l2, object = 54:55)[, + `:=`(object_name = stri_sub(object_name, to = -3), + object_name_lower = stri_sub(object_name_lower, to = -3))] + )) + l$value <- rbindlist(list( + l1$value, + get_idf_value(idd_env, l2, object = 54:55)[, + `:=`(object_name = stri_sub(object_name, to = -3))][ + field_index == 1L, value_chr := stri_sub(value_chr, to = -3)] + )) + expect_message(with_option(list(verbose_info = TRUE), rev <- remove_duplicated_objects(idd_env, idf_env, l$object, l$value)), "removed") + expect_equal(rev$object$class_name, "Site:WeatherStation") + expect_equal(nrow(rev$value), 4L) }) # }}} @@ -2121,6 +2243,29 @@ test_that("to_table", { "Visible Absorptance" = 0.65 ), tolerance = 1e-5 ) + + expect_error(get_idf_table(idd_env, idf_env, wide = TRUE), class = "eplusr_error") + expect_error(get_idf_table(idd_env, idf_env, idf_env$object[, unique(class_id)][1:4], wide = TRUE), class = "eplusr_error") + expect_equal(get_idf_table(idd_env, idf_env, 1, string_value = FALSE)$value, list("8.8")) + + expect_is(val <- get_idf_table(idd_env, idf_env, object = get_idf_object(idd_env, idf_env, "BuildingSurface:Detailed")$object_id[1:2], + string_value = FALSE, wide = TRUE, group_ext = "group"), + "data.table" + ) + expect_equal(names(val)[14:ncol(val)], sprintf("Vrtx%sX-crd|Vrtx%sY-crd|Vrtx%sZ-crd", 1:4, 1:4, 1:4)) + expect_equal(val[["Vrtx3X-crd|Vrtx3Y-crd|Vrtx3Z-crd"]], list(list(15.24, 0., 0.), list(15.24, 15.24, 0.))) + + expect_is(val <- get_idf_table(idd_env, idf_env, object = get_idf_object(idd_env, idf_env, "BuildingSurface:Detailed")$object_id[1:2], + string_value = FALSE, wide = TRUE, group_ext = "index"), + "data.table" + ) + expect_equal(names(val)[14:ncol(val)], sprintf("Vertex %s-coordinate", c("X", "Y", "Z"))) + expect_equal(val[["Vertex X-coordinate"]], list(c(0., 0., 15.24, 15.24), c(15.24, 15.24, 15.24, 15.24))) + + # can init object value table + expect_is(val <- get_idf_table(idd_env, idf_env, "Material", init = TRUE, all = TRUE), "data.table") + expect_equal(nrow(val), 9) + expect_equal(val$value, c(rep(NA, 6), ".9", ".7", ".7")) }) # }}} @@ -2156,6 +2301,7 @@ test_that("to_string", { expect_equal(length(get_idf_string(idd_env, idf_env, class = "Version", comment = FALSE)), 12) expect_equal(length(get_idf_string(idd_env, idf_env, class = "Version", comment = FALSE, header = FALSE)), 5) expect_equal(length(get_idf_string(idd_env, idf_env, class = "Material", header = FALSE, in_ip = TRUE)), 13L) + expect_equal(length(get_idf_string(idd_env, idf_env, idf_env$object[0, list(object_id, object_order = integer())], class = "Material", header = FALSE, format = "new_top")), 11) }) # }}} @@ -2165,9 +2311,32 @@ test_that("Save", { idf_env <- parse_idf_file(example(), 8.8) idd_env <- get_priv_env(use_idd(8.8))$idd_env() + expect_error(class = "eplusr_error_idf_save_ext", + save_idf(idd_env, idf_env, idf_env$object[, list(object_id, object_order = 0)], + tempfile(fileext = ".txt") + ) + ) + f <- tempfile(fileext = ".idf") expect_silent( save_idf(idd_env, idf_env, idf_env$object[, list(object_id, object_order = 0)], - tempfile(fileext = ".idf"), format = "sorted" + f, format = "sorted" + ) + ) + expect_error(class = "eplusr_error_idf_save_exist", + save_idf(idd_env, idf_env, idf_env$object[, list(object_id, object_order = 0)], + f, format = "sorted" + ) + ) + expect_message( + with_option(list(verbose_info = TRUE), + save_idf(idd_env, idf_env, idf_env$object[, list(object_id, object_order = 0)], + f, format = "sorted", overwrite = TRUE + )), + "Replace the existing" + ) + expect_silent( + save_idf(idd_env, idf_env, idf_env$object[, list(object_id, object_order = 0)], + file.path(tempdir(), tempfile(), basename(tempfile(fileext = ".idf"))), format = "new_top" ) ) expect_silent( @@ -2183,3 +2352,56 @@ test_that("Save", { }) # }}} +# RESOLVE_EXTERNAL {{{ +test_that("resolve external link", { + # read idf + idf_env <- parse_idf_file(example(), 8.8) + idd_env <- get_priv_env(use_idd(8.8))$idd_env() + + expect_false(resolve_idf_external_link(idd_env, idf_env)) + + # add a Schedule:File object + f <- tempfile(fileext = ".csv") + l <- expand_idf_dots_value(idd_env, idf_env, `Schedule:File` = list("sch_file", NULL, f, 1, 0)) + l <- add_idf_object(idd_env, idf_env, l$object, l$value) + + # can give warnings if links are broken + expect_warning(flg <- resolve_idf_external_link(idd_env, l, example(), tempfile(fileext = ".idf")), "Broken") + expect_false(flg) + + # can keep the original link if copy is not required + writeLines(",\n", f) + expect_false(resolve_idf_external_link(idd_env, l, tempfile(fileext = ".idf"), example(), copy = FALSE)) + expect_equal(l$value[field_id == 7074, normalizePath(value_chr)], normalizePath(f)) + + expect_true(resolve_idf_external_link(idd_env, l, tempfile(fileext = ".idf"), example(), copy = TRUE)) + expect_true(file.exists(file.path(dirname(example()), basename(f)))) + expect_equal(l$value[field_id == 7074, normalizePath(value_chr, mustWork = FALSE)], basename(f)) + + unlink(file.path(dirname(example()), basename(f)), force = TRUE) +}) +# }}} + +# UTILITIES {{{ +test_that("utilities", { + # read idf + idf_env <- parse_idf_file(example(), 8.8) + idd_env <- get_priv_env(use_idd(8.8))$idd_env() + + l <- expand_idf_dots_value(idd_env, idf_env, Building := list()) + obj <- l$object + val <- l$value + obj[1, object_id := 1L] + val[3:4, value_id := 1:2] + + expect_equal(assign_new_id(idf_env, obj, "object", keep = TRUE)$object_id, 1L) + expect_equal(assign_new_id(idf_env, obj, "object", keep = FALSE)$object_id, 54L) + + expect_equal(assign_new_id(idf_env, val, "value", keep = TRUE)$value_id, c(349:350, 1:2, 351:354)) + expect_equal(assign_new_id(idf_env, val, "value", keep = FALSE)$value_id, 349:356) + + expect_is(def <- with_option(list(view_in_ip = TRUE), assign_idf_value_default(idd_env, idf_env, l$value[, `:=`(value_chr = NA_character_, value_num = NA_real_)])), "data.table") + expect_true(all(!is.na(def$value_chr))) + expect_equal(sum(!is.na(def$value_num)), 5) +}) +# }}} diff --git a/tests/testthat/test-impl-idfobj.R b/tests/testthat/test-impl-idfobj.R new file mode 100644 index 000000000..75ccba0e4 --- /dev/null +++ b/tests/testthat/test-impl-idfobj.R @@ -0,0 +1,199 @@ +context("IdfObject Implementation") + +# VALUE {{{ +test_that("get_idfobj_value()", { + idf_env <- parse_idf_file(text("idf", 8.8)) + idd_env <- get_priv_env(use_idd(8.8))$idd_env() + + expect_equivalent(get_idfobj_value(idd_env, idf_env, 1), tolerance = 1e-5, + list(Name = "WD01", + Roughness = "MediumSmooth", + Thickness = 0.0191, + Conductivity = 0.115, + Density = 513, + `Specific Heat` = 1381, + `Thermal Absorptance` = 0.9, + `Solar Absorptance` = 0.78, + `Visible Absorptance` = 0.78 + ) + ) + + expect_equivalent(get_idfobj_value(idd_env, idf_env, 1, unit = TRUE), tolerance = 1e-5, + list(Name = "WD01", + Roughness = "MediumSmooth", + Thickness = units::set_units(0.0191, "m"), + Conductivity = units::set_units(0.115, "W/K/m"), + Density = units::set_units(513, "kg/m^3"), + `Specific Heat` = units::set_units(1381, "J/K/kg"), + `Thermal Absorptance` = 0.9, + `Solar Absorptance` = 0.78, + `Visible Absorptance` = 0.78 + ) + ) + + expect_equal(get_idfobj_value(idd_env, idf_env, 1, simplify = TRUE), + c("WD01", "MediumSmooth", "0.019099999", "0.115", "513", "1381", "0.9", "0.78", "0.78") + ) + + val <- get_idf_value(idd_env, idf_env, object = 1, property = "type_enum") + expect_silent(with_option(list(view_in_ip = TRUE), get_value_list(val, TRUE))) + + idf_env <- parse_idf_file(example()) + idd_env <- get_priv_env(use_idd(8.8))$idd_env() + + val <- get_idf_value(idd_env, idf_env, object = 8, property = "type_enum") + val[2, `:=`(value_chr = "4.5", value_num = 4.5)] + expect_warning(l <- get_value_list(val), "Truncated error") + expect_equal(l[[2]], 4L) +}) +# }}} + +# VALUE_POSSIBLE {{{ +test_that("get_idfobj_possible()", { + idf_env <- parse_idf_file(text("idf", 8.8)) + idd_env <- get_priv_env(use_idd(8.8))$idd_env() + + expect_equivalent(get_idfobj_possible(idd_env, idf_env, 2), + data.table(class_id = 90L, class_name = "Construction", object_id = 2L, + object_name = "WALL-1", field_id = 11006:11010, field_index = 1:5, + field_name = c("Name", "Outside Layer", paste("Layer", 2:4)), + value_id = 10:14, value_chr = c("WALL-1", "WD01", "PW03", "IN02", "GP01"), + value_num = rep(NA_real_, 5), + auto = NA_character_, default = rep(list(NA_character_), 5), + choice = list(), range = rep(list(ranger(NA_real_, FALSE, NA_real_, FALSE)), 5), + source = c(list(NULL), rep(list(c("WD01", "WD02")), 4)) + ) + ) + + expect_equivalent(get_idfobj_possible(idd_env, idf_env, 2, 2), + data.table(class_id = 90L, class_name = "Construction", object_id = 2L, + object_name = "WALL-1", field_id = 11007, field_index = 2, + field_name = "Outside Layer", + value_id = 11, value_chr = "WD01", value_num = NA_real_, + auto = NA_character_, default = list(NA_character_), + choice = list(), range = list(ranger(NA_real_, FALSE, NA_real_, FALSE)), + source = list(c("WD01", "WD02")) + ) + ) + + if (!is_avail_eplus(8.8)) install_eplus(8.8) + idf_env <- parse_idf_file(file.path(eplus_config(8.8)$dir, "ExampleFiles/5Zone_Transformer.idf")) + expect_equal(length(get_idfobj_possible(idd_env, idf_env, object = 278, 11)$source[[1]]), 88) +}) +# }}} + +# VALUE_RELATION {{{ +test_that("get_idfobj_relation()", { + idf_env <- parse_idf_file(text("idf", 8.8)) + idd_env <- get_priv_env(use_idd(8.8))$idd_env() + + expect_equivalent(get_idfobj_relation(idd_env, idf_env, 2, 10), + list( + ref_to = data.table( + class_id = integer(), class_name = character(), + object_id = integer(), object_name = character(), + field_id = integer(), field_index = integer(), field_name = character(), + value_id = integer(), value_chr = character(), value_num = double(), type_enum = integer(), + src_class_id = integer(), src_class_name = character(), + src_object_id = integer(), src_object_name = character(), + src_field_id = integer(), src_field_index = integer(), src_field_name = character(), + src_value_id = integer(), src_value_chr = character(), src_value_num = double(), src_type_enum = integer(), + src_enum = integer(), dep = integer() + ), + ref_by = data.table( + class_id = 103L, class_name = "BuildingSurface:Detailed", + object_id = 3L, object_name = "WALL-1PF", + field_id = 11624L, field_index = 3L, field_name = "Construction Name", + value_id = 17L, value_chr = "WALL-1", value_num = NA_integer_, type_enum = 5L, + src_class_id = 90L, src_class_name = "Construction", + src_object_id = 2L, src_object_name = "WALL-1", + src_field_id = 11006L, src_field_index = 1L, src_field_name = "Name", + src_value_id = 10L, src_value_chr = "WALL-1", src_value_num = NA_integer_, src_type_enum = 4L, + src_enum = 2L, dep = 0L + ), + node = data.table( + class_id = integer(), class_name = character(), + object_id = integer(), object_name = character(), + field_id = integer(), field_index = integer(), field_name = character(), + value_id = integer(), value_chr = character(), value_num = double(), type_enum = integer(), + src_class_id = integer(), src_class_name = character(), + src_object_id = integer(), src_object_name = character(), + src_field_id = integer(), src_field_index = integer(), src_field_name = character(), + src_value_id = integer(), src_value_chr = character(), src_value_num = double(), src_type_enum = integer(), + src_enum = integer(), dep = integer() + ) + ) + ) +}) +# }}} + +# TABLE {{{ +test_that("get_idfobj_table()", { + idf_env <- parse_idf_file(text("idf", 8.8)) + idd_env <- get_priv_env(use_idd(8.8))$idd_env() + + expect_equal( + get_idfobj_table(idd_env, idf_env, 2), + data.table(id = 2L, name = "WALL-1", class = "Construction", index = 1:5, + field = c("Name", "Outside Layer", paste("Layer", 2:4)), + value = c("WALL-1", "WD01", "PW03", "IN02", "GP01") + ) + ) +}) +# }}} + +# STRING {{{ +test_that("get_idfobj_string()", { + idf_env <- parse_idf_file(text("idf", 8.8)) + idd_env <- get_priv_env(use_idd(8.8))$idd_env() + + expect_equal(get_idfobj_string(idd_env, idf_env, 2, leading = 0, sep_at = 10, comment = FALSE), + c("Construction,", + "WALL-1, !- Name", + "WD01, !- Outside Layer", + "PW03, !- Layer 2", + "IN02, !- Layer 3", + "GP01; !- Layer 4") + ) + + expect_equal(get_idfobj_string(idd_env, idf_env, 1, leading = 0, sep_at = 10), + c("! this is a test comment for WD01", + "", + "Material,", + "WD01, !- Name", + "MediumSmooth, !- Roughness", + "0.019099999, !- Thickness {m}", + "0.115, !- Conductivity {W/m-K}", + "513, !- Density {kg/m3}", + "1381, !- Specific Heat {J/kg-K}", + "0.9, !- Thermal Absorptance", + "0.78, !- Solar Absorptance", + "0.78; !- Visible Absorptance") + ) +}) +# }}} + +# COMMENT {{{ +test_that("set_idfobj_comment", { + idf_env <- parse_idf_file(text("idf", 8.8)) + idd_env <- get_priv_env(use_idd(8.8))$idd_env() + + # can delete comments + expect_equal(set_idfobj_comment(idd_env, idf_env, 1, comment = NULL)$comment, list(NULL)) + + # can append comments + expect_equal(set_idfobj_comment(idd_env, idf_env, 1, comment = "a")$comment[[1]][2], "a") + + # can prepend comments + expect_equal(set_idfobj_comment(idd_env, idf_env, 1, comment = "a", append = FALSE)$comment[[1]][1], "a") + + # can reset comments + expect_equal(set_idfobj_comment(idd_env, idf_env, 1, comment = "a", append = NULL)$comment, list("a")) + + # can detect invalid `append` value + expect_error(set_idfobj_comment(idd_env, idf_env, 1, comment = "a", append = 1:2)$comment, class = "eplusr_error") + + # can wrap comment at specified `width` + expect_equal(set_idfobj_comment(idd_env, idf_env, 1, comment = c("a", "bb ccc"), append = NULL, width = 1L)$comment[[1]], c("a", "bb", "ccc")) +}) +# }}} diff --git a/tests/testthat/test_impl.R b/tests/testthat/test-impl.R similarity index 98% rename from tests/testthat/test_impl.R rename to tests/testthat/test-impl.R index 715dc60a7..20c5f3461 100644 --- a/tests/testthat/test_impl.R +++ b/tests/testthat/test-impl.R @@ -2,7 +2,7 @@ test_that("Basic Table Implementation", { expect_equal(assert_valid_type("a"), "a") expect_error(assert_valid_type("a", type = "id"), "integerish") - expect_error(assert_valid_type("a", "object", type = "id"), "object") + expect_error(assert_valid_type("a", "Object ID", type = "id"), "Object") expect_error(assert_valid_type("a", len = 2, type = "name"), "length 2") expect_equal(assert_valid_type(1, type = "id"), 1L) expect_equal(assert_valid_type(1), 1L) diff --git a/tests/testthat/test_options.R b/tests/testthat/test-options.R similarity index 100% rename from tests/testthat/test_options.R rename to tests/testthat/test-options.R diff --git a/tests/testthat/test_parse.R b/tests/testthat/test-parse.R similarity index 93% rename from tests/testthat/test_parse.R rename to tests/testthat/test-parse.R index 661026a46..b2abc93d7 100644 --- a/tests/testthat/test_parse.R +++ b/tests/testthat/test-parse.R @@ -265,16 +265,16 @@ test_that("parse_idd_file()", { test_that("parse_idf_file()", { # get version {{{ # Normal formatted - expect_equal( + expect_equivalent( get_idf_ver(data.table(string = c("Version,", "8.6;"), line = 1:2)), numeric_version(8.6) ) # One line formatted - expect_equal( + expect_equivalent( get_idf_ver(data.table(string = "Version, 8.6;", line = 1)), numeric_version(8.6) ) - expect_equal( + expect_equivalent( get_idf_ver(data.table(string = "Version, 8.6; !- Version", line = 1)), numeric_version(8.6) ) @@ -329,11 +329,11 @@ test_that("parse_idf_file()", { # can parse one-line empty object expect_silent(idf_parsed <- parse_idf_file("Version,8.8;\nOutput:Surfaces:List,,;")) expect_equivalent(idf_parsed$object, - data.table(object_id = 1:2, class_id = c(1L, 764L), - comment = list(), object_name = rep(NA_character_, 2), object_name_lower = rep(NA_character_, 2)) + data.table(object_id = 1:2, object_name = rep(NA_character_, 2), + object_name_lower = rep(NA_character_, 2), comment = list(), class_id = c(1L, 764L)) ) expect_equivalent(idf_parsed$value, - data.table(object_id = 1:3, value_chr = c("8.8", NA_character_, NA_character_), + data.table(value_id = 1:3, value_chr = c("8.8", NA_character_, NA_character_), value_num = rep(NA_real_, 3), object_id = c(1L, 2L, 2L), field_id = c(1L, 58822L, 58823L)) ) @@ -359,7 +359,8 @@ test_that("parse_idf_file()", { 0.7800000, !- Solar Absorptance 0.7800000; !- Visible Absorptance ") - expect_error(parse_idf_file(idf_wrong, 8.8), "Invalid line found") + expect_error(parse_idf_file(idf_wrong, 8.8), class = "eplusr_error_parse_idf_line") + expect_error(parse_idf_file("Construction, const1, mat; Construction, const2;\nVersion, 8.8;")) # can detect incomplete object idf_wrong <- c( @@ -375,7 +376,7 @@ test_that("parse_idf_file()", { 0.7800000, !- Solar Absorptance 0.7800000, !- Visible Absorptance ") - expect_error(parse_idf_file(idf_wrong, 8.8), "Incomplete object") + expect_error(parse_idf_file(idf_wrong, 8.8), class = "eplusr_error_parse_idf_object") # can detect error of invalid class name idf_wrong <- c( @@ -387,16 +388,16 @@ test_that("parse_idf_file()", { WrongClass, WD01; !- Name ") - expect_error(parse_idf_file(idf_wrong, 8.8), "Invalid class name") + expect_error(parse_idf_file(idf_wrong, 8.8), class = "eplusr_error_parse_idf_class") idf_wrong <- c( "Version,8.8; WrongClass, WD01; ") - expect_error(parse_idf_file(idf_wrong, 8.8), "Invalid class name") + expect_error(parse_idf_file(idf_wrong, 8.8), class = "eplusr_error_parse_idf_class") # can detect error of multiple version idf_wrong <- "Version, 8.8;\nVersion, 8.9;" - expect_error(parse_idf_file(idf_wrong, 8.8), "Multiple versions found") + expect_error(parse_idf_file(idf_wrong, 8.8), class = "eplusr_error_parse_idf_ver") # can detect error of invalid field number idf_wrong <- " @@ -405,7 +406,7 @@ test_that("parse_idf_file()", { Simple, !- Algorithm Simple, !- Algorithm TARP; !- Algorithm" - expect_error(parse_idf_file(idf_wrong, 8.8), "Invalid field number") + expect_error(parse_idf_file(idf_wrong, 8.8), class = "eplusr_error_parse_idf_field") # can optional discard reference parsing expect_equal(nrow(parse_idf_file(text(ver = 8.8), 8.8, ref = FALSE)$reference), 0L) diff --git a/tests/testthat/test_run.R b/tests/testthat/test-run.R similarity index 100% rename from tests/testthat/test_run.R rename to tests/testthat/test-run.R diff --git a/tests/testthat/test_utils.R b/tests/testthat/test-utils.R similarity index 100% rename from tests/testthat/test_utils.R rename to tests/testthat/test-utils.R diff --git a/tests/testthat/test_param.R b/tests/testthat/test_param.R index 2d08085ae..503dd8c03 100644 --- a/tests/testthat/test_param.R +++ b/tests/testthat/test_param.R @@ -12,7 +12,7 @@ test_that("Parametric methods", { param <- param_job(example$idf, example$epw) - priv <- ._get_private(param) + priv <- get_priv_env(param) # Seed and Weather {{{ expect_is(param$seed(), "Idf") From 2d89b9ec867692ccfd0c2f5d530560104eff86be Mon Sep 17 00:00:00 2001 From: Hongyuan Jia Date: Mon, 20 Jul 2020 01:22:41 +0800 Subject: [PATCH 25/43] [refactor] Refactor transition.R --- R/transition.R | 668 +++--- man/transition.Rd | 2 +- man/version_updater.Rd | 2 +- tests/testthat/files/v8.2.idf | 157 -- tests/testthat/files/v8.8.idf | 302 --- tests/testthat/files/v9.1.idf | 3280 ---------------------------- tests/testthat/helper-transition.R | 440 +--- tests/testthat/test-transition.R | 1745 +++++++++++++++ tests/testthat/test_transition.R | 322 --- 9 files changed, 2112 insertions(+), 4806 deletions(-) delete mode 100644 tests/testthat/files/v8.2.idf delete mode 100644 tests/testthat/files/v8.8.idf delete mode 100644 tests/testthat/files/v9.1.idf create mode 100644 tests/testthat/test-transition.R delete mode 100644 tests/testthat/test_transition.R diff --git a/R/transition.R b/R/transition.R index 38ca65c17..b95fc071f 100644 --- a/R/transition.R +++ b/R/transition.R @@ -16,7 +16,7 @@ CLASS_DEL_COMMON <- c( #' specified version. #' #' @param idf An [Idf] object or a path of IDF file. -#' @param ver A valid EnergyPlus version, e.g. `9`, `8.8`, or `"8.8.0"`. +#' @param ver A valid EnergyPlus IDD version, e.g. `9`, `8.8`, or `"8.8.0"`. #' @param save If `TRUE`, the models will be saved into specified directory. #' Default: `FALSE`. #' @param dir Only applicable when `save` is `TRUE`. The directory to save the @@ -55,25 +55,25 @@ CLASS_DEL_COMMON <- c( #' } #' @export # transition {{{ +#' @importFrom checkmate assert_vector # TODO: how to give the names of saved files transition <- function (idf, ver, keep_all = FALSE, save = FALSE, dir = NULL) { if (!is_idf(idf)) idf <- read_idf(idf) - assert(is_idd_ver(ver)) - ver <- standardize_ver(ver)[, 1L:2L] + if (length(ver) != 1L || is.na(ver <- convert_to_idd_ver(ver))) { + abort("'ver' must be a valid EnergyPlus IDD version") + } + ver <- ver[, 1:2] if (idf$version() < 7.2) { - abort("error_trans_not_supported", - paste0( - "Input IDF has version ", surround(idf$version()), ". ", - "Currently only EnergyPlus v7.2 and above are suppored." - ) - ) + abort(paste0("Input IDF has version ", surround(idf$version()), ". ", + "Currently only EnergyPlus v7.2 and above are suppored." + )) } # only compare Major and Mversioninor version, skip patch version if (idf$version()[, 1L:2L] == ver) { - verbose_info("IDF is already at latest version ", ver, ". No transition needed.") + verbose_info("IDF is already at latest version ", ver, ". No transition is needed.") if (keep_all) { res <- list(idf) setattr(res, "names", as.character(idf$version()[, 1L:2L])) @@ -83,16 +83,12 @@ transition <- function (idf, ver, keep_all = FALSE, save = FALSE, dir = NULL) { } # cannot go reverse } else if (idf$version()[, 1L:2L] > ver) { - abort("error_trans_reverse", "Only version updating is supported. Downgrading is not supported.") + abort("Only version updating is supported. Downgrading is not supported.") } # stop if unsaved if (idf$is_unsaved()) { - abort("error_idf_not_saved", - paste0("Idf has been modified since read or last saved. ", - "Please save Idf using $save() before transition." - ) - ) + abort("Idf has been modified since read or last saved. Please save Idf using '$save()' before transition.") } # clone original input @@ -106,12 +102,7 @@ transition <- function (idf, ver, keep_all = FALSE, save = FALSE, dir = NULL) { # check if original file exists if (is.null(idf$path())) { - abort("error_idf_not_local", - paste0( - "The Idf object is not created from local file. ", - "Please save Idf using $save() before transition." - ) - ) + abort("The Idf object is not created from local file. Please save Idf using '$save()' before transition.") } if (is.null(dir)) { @@ -177,8 +168,9 @@ trans_apply <- function (idf, ver, keep_all) { trans_funs <- new.env(parent = emptyenv()) # trans_720_800 {{{ +#' @importFrom checkmate assert_true trans_funs$f720t800 <- function (idf) { - assert(idf$version()[, 1:2] == 7.2) + assert_true(idf$version()[, 1:2] == 7.2) target_cls <- c( "ShadowCalculation", # 1 @@ -256,7 +248,7 @@ trans_funs$f720t800 <- function (idf) { # update key value dt4[units, on = c("id", "index"), value := i.value] # update unit - set(units, NULL, "index", 6L) + set(units, NULL, "index", 9L) dt4[units, on = c("id", "index"), value := i.unit] } # }}} @@ -287,7 +279,7 @@ trans_funs$f720t800 <- function (idf) { c(3L, 6L, 7L, 9L, 4L, 5L, 8L, 2L), c(2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L) ), - reset = list(9L, "PlateFrame", "CrossFlowBothUnmixed"), + reset = list(9L, "PlateFrame", "CrossFlowBothUnMixed"), insert = list(11L, "CoolingDifferentialOnOff"), insert = list(12L), add = list(14L, "FreeCooling") @@ -392,12 +384,12 @@ trans_funs$f720t800 <- function (idf) { dt <- trans_action(idf, class, reset = list(index, old, new)) if (nrow(dt)) { - warn("warning_trans_720_800", - paste0("Default values for some fields in class ", - "`", class, "` have been changed from v7.2 to v8.0. ", + warn(paste0("Default values for some fields in class ", surround(class), + " have been changed from v7.2 to v8.0. ", "Results may be different than previous. ", "See InputOutputReference document for details." - ) + ), + "warning_trans_720_800" ) } @@ -444,8 +436,9 @@ trans_funs$f720t800 <- function (idf) { } # }}} # trans_800_810 {{{ +#' @importFrom checkmate assert_true trans_funs$f800t810 <- function (idf) { - assert(idf$version()[, 1:2] == 8.0) + assert_true(idf$version()[, 1:2] == 8.0) target_cls <- c( "People", # 1 @@ -576,18 +569,18 @@ trans_funs$f800t810 <- function (idf) { if (!is.na(value[min_fields])) { if (stri_trans_tolower(value[min_fields]) == "cycling") { sch <- "CyclingFanSchedule" - len <- 100L - nchar(paste0(class, sch)) - 1L + len <- 100L - nchar(paste0(class[[1L]], sch)) - 1L nm <- stri_sub(value[1L], to = len) if (is.na(nm)) nm <- "" - value[min_fields] <- paste0(class, nm, sch) + value[min_fields] <- paste0(class[[1L]], nm, sch) new_idf$add(`Schedule:Constant` = list(value[[min_fields]], "Any Number", 0)) } else if (stri_trans_tolower(value[min_fields]) == "continuous") { sch <- "ContinuousFanSchedule" - len <- 100L - nchar(paste0(class, sch)) - 1L + len <- 100L - nchar(paste0(class[[1L]], sch)) - 1L nm <- stri_sub(value[1L], to = len) if (is.na(nm)) nm <- "" - value[min_fields] <- paste0(class, nm, sch) - new_idf$add(`Schedule:Constant` = list(value[[13]], "Any Number", 1)) + value[min_fields] <- paste0(class[[1L]], nm, sch) + new_idf$add(`Schedule:Constant` = list(value[[min_fields]], "Any Number", 1)) } } value @@ -618,8 +611,9 @@ trans_funs$f800t810 <- function (idf) { } # }}} # trans_810_820 {{{ +#' @importFrom checkmate assert_true trans_funs$f810t820 <- function (idf) { - assert(idf$version()[, 1:2] == 8.1) + assert_true(idf$version()[, 1:2] == 8.1) target_cls <- c( "ZoneHVAC:UnitVentilator", # 1 @@ -648,20 +642,21 @@ trans_funs$f810t820 <- function (idf) { ) # }}} # 2: ZoneHVAC:UnitHeater {{{ - dt2 <- trans_action(idf, class = "ZoneHVAC:UnitHeater", all = TRUE, - offset = list(8L, 11L), - insert = list(10L) - ) + dt2 <- trans_action(idf, class = "ZoneHVAC:UnitHeater", all = TRUE, add = list(15L)) if (nrow(dt2)) { - dt2[J(11L), on = "index", value := { - value[stri_trans_tolower(value) == "onoff"] <- "No" - value[stri_trans_tolower(value) == "continuous"] <- "Yes" - if (any(!value %in% c("No", "Yes"))) { - warn("warning_trans_810_820", - "Invalid fan control type in original v8.1 idf...expected onoff or continuous...assuming onoff" + dt2[, by = "id", value := { + fantype <- value[[8L]] + fantype[stri_trans_tolower(fantype) == "onoff"] <- "No" + fantype[stri_trans_tolower(fantype) == "continuous"] <- "Yes" + if (any(!fantype %in% c("No", "Yes"))) { + warn(paste0("Invalid 'Fan Control Type' value for object [ID:", id, "] ", + "in class 'ZoneHVAC:UnitHeater' in original v8.1 IDF. ", + "Expected 'OnOff' or 'Continuous'. Assuming 'OnOff'..."), + "warning_trans_810_820" ) - value[!value %in% c("No", "Yes")] <- "No" + fantype[!fantype %in% c("No", "Yes")] <- "No" } + c(value[c(1:7, 9:10)], value[15], fantype, value[11:14]) }] } # }}} @@ -764,8 +759,9 @@ trans_funs$f810t820 <- function (idf) { } # }}} # trans_820_830 {{{ +#' @importFrom checkmate assert_true trans_funs$f820t830 <- function (idf) { - assert(idf$version()[, 1:2] == 8.2) + assert_true(idf$version()[, 1:2] == 8.2) target_cls <- c( "Chiller:Electric:ReformulatedEIR", # 1 @@ -821,8 +817,9 @@ trans_funs$f820t830 <- function (idf) { } # }}} # trans_830_840 {{{ +#' @importFrom checkmate assert_true trans_funs$f830t840 <- function (idf) { - assert(idf$version()[, 1:2] == 8.3) + assert_true(idf$version()[, 1:2] == 8.3) target_cls <- c( "Coil:WaterHeating:AirToWaterHeatPump", # 1 @@ -876,7 +873,7 @@ trans_funs$f830t840 <- function (idf) { value[36L] <- NA_character_ if (heater_num > 0L) { - tank <- idf$object(.BY$id)$ref_to_object(18L)[[1L]] + tank <- with_silent(idf$object(.BY$id)$ref_to_object(18L)[[1L]]) if (length(tank)) { if (stri_trans_tolower(tank$class_name()) == "waterheater:stratified") { if (heater_num == 1L) { @@ -987,7 +984,7 @@ trans_funs$f830t840 <- function (idf) { dt12_2[J(1L), on = "index", value := paste("KATemp", seq.int(.N) + ka_num)] dt12_2[J(c(2L:4L)), on = "index", value := { # get material properties - mat <- idf$object(.BY$id)$ref_to_object(8L, "Material")[[1L]] + mat <- with_silent(idf$object(.BY$id)$ref_to_object(8L, "Material")[[1L]]) if (length(mat)) { value <- mat$value(simplify = TRUE)[2L:4L] } @@ -1077,8 +1074,9 @@ trans_funs$f830t840 <- function (idf) { } # }}} # trans_840_850 {{{ +#' @importFrom checkmate assert_true trans_funs$f840t850 <- function (idf) { - assert(idf$version()[, 1:2] == 8.4) + assert_true(idf$version()[, 1:2] == 8.4) target_cls <- c( "EnergyManagementSystem:Actuator" # 1 @@ -1099,8 +1097,9 @@ trans_funs$f840t850 <- function (idf) { } # }}} # trans_850_860 {{{ +#' @importFrom checkmate assert_true trans_funs$f850t860 <- function (idf) { - assert(idf$version()[, 1:2] == 8.5) + assert_true(idf$version()[, 1:2] == 8.5) target_cls <- c( "Exterior:FuelEquipment", # 1 @@ -1125,7 +1124,7 @@ trans_funs$f850t860 <- function (idf) { # SPECIAL # replace all "Coil:Heating:Gas" with "Coil:Heating:Fuel" - ._get_private(idf)$idf_env()$value[ + get_priv_env(idf)$idf_env()$value[ stri_detect_fixed(value_chr, "coil:heating:gas", case_insensitive = TRUE), value_chr := "Coil:Heating:Fuel" ] @@ -1281,15 +1280,15 @@ trans_funs$f850t860 <- function (idf) { dt14 <- rbindlist(list(dt14_1, dt14_2, dt14_3)) # }}} # 15: Daylighting:DELight:ReferencePoint {{{ - dt15 <- trans_action(idf, min_fields = 5L, + dt15 <- trans_action(idf, all = TRUE, class = c("Daylighting:ReferencePoint" = "Daylighting:DELight:ReferencePoint") ) if (nrow(dt15)) { dt15 <- dt15[index <= 5L] nm_zone <- vcapply(unique(dt15$id), function (id) { - zone <- idf$object(id)$ref_to_object(2L, class = "Zone", depth = NULL)[[1L]] - if (!length(zone)) NA_character_ else zone$name() + zone <- with_silent(idf$object(id)$ref_to_object(2L, class = "Zone", depth = NULL)[[1L]]) + if (!length(zone)) NA_character_ else zone$value(2)[[1L]] } ) dt15[J(2L), on = "index", value := nm_zone] @@ -1331,7 +1330,7 @@ trans_funs$f850t860 <- function (idf) { if (!length(refp)) { data.table() } else { - dt <- rbindlist(lapply(refp, function (x) x$to_table()))[index %in% c(1L, 6L, 7L)] + dt <- rbindlist(lapply(refp, function (x) x$to_table(all = TRUE)))[index %in% c(1L, 6L, 7L)] # update object id set(dt, NULL, "id", id) set(dt, NULL, "class", "Daylighting:Controls") @@ -1341,6 +1340,7 @@ trans_funs$f850t860 <- function (idf) { ) dt16 <- rbindlist(c(list(dt16_1), dt16_2)) + setorderv(dt16, c("id", "index")) } # }}} # 17: MaterialProperty:MoisturePenetrationDepth:Settings {{{ @@ -1387,22 +1387,25 @@ trans_funs$f850t860 <- function (idf) { psat } # }}} - dt17 <- dt17[, + dt17 <- dt17[, by = "id", value := { value[7L] <- value[2L] # get material density - mat <- idf$object(.BY$id)$ref_to_object(1L, "Material")[[1L]] - if (!length(mat)) { - warn("warning_tran_850_860", - paste0( + mat <- with_silent(idf$object(.BY$id)$ref_to_object(1L, "Material")[[1L]]) + if (length(mat)) { + den <- mat$Density + } else { + warn(paste0( "Material match issue:\n", - "Did not find a material component match for name `", - idf$object(.BY$id)$name(), "`." - ) + "Did not find a matched material component for name '", + value[[1L]], "' referenced in class ", + "'MaterialProperty:MoisturePenetrationDepth:Settings'." + ), + "warning_tran_850_860" ) + den <- NA_real_ } - den <- mat$Density # calculate coeffs <- suppressWarnings(as.double(value[3L:6L])) @@ -1416,8 +1419,7 @@ trans_funs$f850t860 <- function (idf) { value[2L] <- sprintf("%.7f", mu) } value - }, - by = "id" + } ] } # }}} @@ -1440,10 +1442,12 @@ trans_funs$f850t860 <- function (idf) { # DELight Reference Point if (nrow(dt15)) { refpt <- dt15[index == 1L, list(id, key_value = stri_trans_tolower(stri_trim_both(value)))] - dt19_1[!refpt, on = key_value, list(id, class, index = 1L, value = paste0(stri_trim_both(`Key Value`), "_DaylCtrl"))] + dt19_1[!refpt, on = "key_value", list(id, class, index = 1L, value = paste0(stri_trim_both(`Key Value`), "_DaylCtrl"))] } else { dt19_1 <- dt19_1[, list(id, class = class, index = 1L, value = paste0(stri_trim_both(`Key Value`), "_DaylCtrl"))] } + set(dt19_1, NULL, c("key_value", "variable_name"), NULL) + dt19_1 <- dt_to_load(dt19_1) } else { dt19_1 <- data.table() } @@ -1452,10 +1456,10 @@ trans_funs$f850t860 <- function (idf) { if (nrow(dt19_2)) { # DELight Reference Point if (nrow(dt15)) { - refpt <- dcast.data.table(dt15[J(c(1:2)), on = "index"], class ~ field, value.var = "value") + refpt <- dcast.data.table(dt15[J(c(1:2)), on = "index"], id + class ~ field, value.var = "value") # add control name refpt[, `:=`(ctrlname = idf$object(id[[1L]])$value(2L)[[1L]]), by = "id"] - dt19_2 <- dt19_2[refpt, on = key_value, list(id, class, index = 1L, value = ctrlname), nomatch = 0L] + dt19_2 <- dt19_2[refpt, on = c("key_value" = "DElight Name"), list(id, class, index = 1L, value = ctrlname), nomatch = 0L] } else { dt19_2 <- dt19_2[, list(id, class = class, index = 1L, value = paste0(stri_trim_both(`Key Value`), "_DaylCtrl"))] } @@ -1463,7 +1467,7 @@ trans_funs$f850t860 <- function (idf) { dt19_2 <- data.table() } - dt19 <- rbindlist(list(dt19_1, dt19_2)) + dt19 <- rbindlist(list(dt19_1, dt19_2), fill = TRUE) if (nrow(dt19)) new_idf$update(dt19, .default = FALSE) } @@ -1475,8 +1479,9 @@ trans_funs$f850t860 <- function (idf) { } # }}} # trans_860_870 {{{ +#' @importFrom checkmate assert_true trans_funs$f860t870 <- function (idf) { - assert(idf$version()[, 1:2] == 8.6) + assert_true(idf$version()[, 1:2] == 8.6) target_cls <- c( "Coil:Cooling:DX:MultiSpeed", # 1 @@ -1555,8 +1560,9 @@ trans_funs$f860t870 <- function (idf) { } # }}} # trans_870_880 {{{ +#' @importFrom checkmate assert_true trans_funs$f870t880 <- function (idf) { - assert(idf$version()[, 1:2] == 8.7) + assert_true(idf$version()[, 1:2] == 8.7) target_cls <- c( "Output:Surfaces:List", # 1 @@ -1603,28 +1609,31 @@ trans_funs$f870t880 <- function (idf) { # if not, give a warning and add one dt3 <- rbindlist(lapply(obj_id, function (i) { - perim <- with_silent(idf$object(i)$ref_by_object(1L, "SurfaceProperty:ExposedFoundationPerimeter")[[1L]]) - - if (!length(perim)) { - dt <- dt3[J(i), on = "id"] - n <- ceiling((nrow(dt) - 10L) / 3L) - dt <- dt[index <= 4L + n] - dt[J(2L), on = "index", value := "BySegment"] - dt[J(c(3L, 4L)), on = "index", value := NA_character_] - dt[index > 4L, value := "Yes"] - warn("warning_trans_870_880", - paste0( - "Foundation floors now require a ", - "`SurfaceProperty:ExposedFoundationPerimeter` ", - "object. One was added with each segment of the ", - "floor surface exposed (`",idf$object(i)$name(),"`). ", - "Please check your inputs to make sure this ", - "reflects your foundation." - ) - ) - } else { - data.table() - } + perim <- with_silent(idf$object(i)$ref_by_object(1L, class = "SurfaceProperty:ExposedFoundationPerimeter")[[1L]]) + + if (length(perim)) return(data.table()) + + dt <- dt3[J(i), on = "id"] + n <- ceiling((nrow(dt) - 10L) / 3L) + dt <- dt[index <= 4L + n] + set(dt, NULL, "class", "SurfaceProperty:ExposedFoundationPerimeter") + + dt[J(2L), on = "index", value := "BySegment"] + dt[J(c(3L, 4L)), on = "index", value := NA_character_] + dt[index > 4L, value := "Yes"] + + warn(paste0( + "Foundation floors now require a ", + "'SurfaceProperty:ExposedFoundationPerimeter' ", + "object. One was added with each segment of the ", + "floor surface exposed (", surround(idf$object(i)$name()), "). ", + "Please check your inputs to make sure this ", + "reflects your foundation." + ), + "warning_trans_870_880" + ) + + dt } )) } @@ -1643,28 +1652,30 @@ trans_funs$f870t880 <- function (idf) { # if not, give a warning and add one dt4 <- rbindlist(lapply(obj_id, function (i) { - perim <- with_silent(idf$object(i)$ref_by_object(1L, "SurfaceProperty:ExposedFoundationPerimeter")[[1L]]) - - if (!length(perim)) { - dt <- dt4[J(i), on = "id"] - n <- ceiling((nrow(dt) - 9L) / 3L) - dt <- dt[index <= 4L + n] - dt[J(2L), on = "index", value := "BySegment"] - dt[J(c(3L, 4L)), on = "index", value := NA_character_] - dt[index > 4L, value := "Yes"] - warn("warning_trans_870_880", - paste0( - "Foundation floors now require a ", - "`SurfaceProperty:ExposedFoundationPerimeter` ", - "object. One was added with each segment of the ", - "floor surface exposed (`",idf$object(i)$name(),"`). ", - "Please check your inputs to make sure this ", - "reflects your foundation." - ) - ) - } else { - data.table() - } + perim <- with_silent(idf$object(i)$ref_by_object(1L, class = "SurfaceProperty:ExposedFoundationPerimeter")[[1L]]) + + if (length(perim)) return(data.table()) + dt <- dt4[J(i), on = "id"] + n <- ceiling((nrow(dt) - 9L) / 3L) + dt <- dt[index <= 4L + n] + + set(dt, NULL, "class", "SurfaceProperty:ExposedFoundationPerimeter") + + dt[J(2L), on = "index", value := "BySegment"] + dt[J(c(3L, 4L)), on = "index", value := NA_character_] + dt[index > 4L, value := "Yes"] + warn(paste0( + "Foundation floors now require a ", + "'SurfaceProperty:ExposedFoundationPerimeter' ", + "object. One was added with each segment of the ", + "floor surface exposed (", surround(idf$object(i)$name()), "). ", + "Please check your inputs to make sure this ", + "reflects your foundation." + ), + "warning_trans_870_880" + ) + + dt } )) } @@ -1718,8 +1729,9 @@ trans_funs$f870t880 <- function (idf) { } # }}} # trans_880_890 {{{ +#' @importFrom checkmate assert_true trans_funs$f880t890 <- function (idf) { - assert(idf$version()[, 1:2] == 8.8) + assert_true(idf$version()[, 1:2] == 8.8) target_cls <- c( "ZoneHVAC:EquipmentList", # 1 @@ -1855,8 +1867,9 @@ trans_funs$f880t890 <- function (idf) { } # }}} # trans_890_900 {{{ +#' @importFrom checkmate assert_true trans_funs$f890t900 <- function (idf) { - assert(idf$version()[, 1:2] == 8.9) + assert_true(idf$version()[, 1:2] == 8.9) target_cls <- c( "AirflowNetwork:Distribution:Component:OutdoorAirFlow", # 1 @@ -1879,24 +1892,24 @@ trans_funs$f890t900 <- function (idf) { class = "AirflowNetwork:Distribution:Component:OutdoorAirFlow", insert = list(2, tryCatch(idf$object_name("OutdoorAir:Mixer", simplify = TRUE)[[1L]], - error_class_name = function (e) NA_character_ + eplusr_error_invalid_class_name = function (e) NA_character_ ) ) ) if (nrow(dt1) && idf$object_num("OutdoorAir:Mixer") > 1L) { - warn("warning_trans_890_900", "Multiple `OutdoorAir:Mixer` object found.") + warn("Multiple 'OutdoorAir:Mixer' object found.", "warning_trans_890_900") } # }}} # 2: AirflowNetwork:Distribution:Component:ReliefAirFlow {{{ dt2 <- trans_action(idf, "AirflowNetwork:Distribution:Component:ReliefAirFlow", insert = list(2, tryCatch(idf$object_name("OutdoorAir:Mixer", simplify = TRUE)[[1L]], - error_class_name = function (e) NA_character_ + eplusr_error_invalid_class_name = function (e) NA_character_ ) ) ) if (nrow(dt2) && idf$object_num("OutdoorAir:Mixer") > 1L) { - warn("warning_trans_890_900", "Multiple `OutdoorAir:Mixer` object found.") + warn("Multiple 'OutdoorAir:Mixer' object found.", "warning_trans_890_900") } # }}} # 3: Boiler:HotWater {{{ @@ -1916,10 +1929,12 @@ trans_funs$f890t900 <- function (idf) { if (nrow(dt6)) { dt6[index == 8L, value := { if (any(usewthrfile <- tolower(value) == "useweatherfile")) { - warn("warning_trans_890_900", - paste0("Run period start day of week `UseWeatherFile` option ", - "has been removed, start week day is set by the input start date." - ) + warn(paste0( + "For 'RunPeriod:CustomRange' ", surround(name[[1L]]), " [ID:", id[[1L]], "]:\n", + "Option 'UseWeatherFile' for 'Start Day of Week' has been removed, ", + "start week day is set by the input start date." + ), + "warning_trans_890_900" ) value[usewthrfile] <- NA_character_ } @@ -1941,71 +1956,148 @@ trans_funs$f890t900 <- function (idf) { num_rep <- value[12L + 2L] if (!is.na(start_year)) { - assert(is_strint(start_year), prefix = "`Start Year`") + if (!test_strint(start_year)) { + abort(paste0( + "For 'RunPeriod' ", surround(name[[1L]]), " [ID:", id[[1L]], "]:\n", + "Invalid 'Start Year' value (", surround(start_year), ") found." + )) + } # if start year is set in the old run period, use it value[4L] <- start_year - start_year <- as.integer(start_year) } + start_year <- as.integer(start_year) # convert num of repeats to integer if (!is.na(num_rep)) { - assert(is_strint(num_rep), prefix = "`Number of Times Runperiod to be Repeated`") + if (!test_strint(num_rep)) { + abort(paste0( + "For 'RunPeriod' ", surround(name[[1L]]), " [ID:", id[[1L]], "]:\n", + "Invalid 'Number of Times Runperiod to be Repeated' value (", + surround(num_rep), ") found." + )) + } + num_rep <- as.integer(num_rep) } else { num_rep <- 0L - } - - # if start year is not set but repeat times larger than 1 - if (!is.na(start_year) & num_rep > 1L) { - # in case of leap year - start_date <- lubridate::make_date(year = 2016L, month = value[2L], day = value[3L]) - if (is.na(start_date)) { - abort("error_trans_890_900", - "Invalid `Start Month` or `Start Day of Month` in `RunPeriod` found." + if (!is.na(value[8L]) && tolower(value[8L]) == "useweatherfile") { + warn(paste0( + "For 'RunPeriod' ", surround(name[[1L]]), " [ID:", id[[1L]], "]:\n", + "Option 'UseWeatherFile' for 'Start Day of Week' has been removed, ", + "start week day is set by the input start date." + ), + "warning_trans_890_900" ) + value[8L] <- NA_character_ } - - weekday <- if (is.na(value[8L])) "Sunday" else value[8L] - start_year <- find_nearst_wday_year(start_date, weekday, 2017, - start_date == lubridate::as_date("2016-02-29") - ) - - value[4L] <- start_year } if (num_rep > 1L) { - # if start year is blank, end year should also be - if (is.na(start_year)) { - value[7L] <- NA_character_ + # for case when start year is given + if (!is.na(start_year)) { + if (!is.na(value[8L]) && tolower(value[8L]) == "useweatherfile") { + warn(paste0( + "For 'RunPeriod' ", surround(name[[1L]]), " [ID:", id[[1L]], "]:\n", + "Option 'UseWeatherFile' for 'Start Day of Week' has been removed, ", + "start week day is set by the input start date." + ), + "warning_trans_890_900" + ) + value[8L] <- NA_character_ + } + # if start year is not set but repeat times larger than 1 + # need to calculate start year } else { - # end year - end_year <- start_year + num_rep - value[7L] <- as.character(end_year) - - assert(is_strint(value[5L]), prefix = "End Month") - assert(is_strint(value[6L]), prefix = "End Day of Month") - - # check if leap day of end date is specified in an non-leap year - if ((!leap_year(end_year)) && as.integer(value[5L]) == 2L && as.integer(value[6L]) == 29L) { - warn("error_trans_890_900", msg = paste0( - "With `Number of Times Runperiod to be Repeated` being ", num_rep, - "the end year will be ", end_year, ", which is not a leap year. ", - "The end date will be reset to Feb 28th." + # in case of leap year + start_date <- lubridate::make_date(year = 2016L, month = value[2L], day = value[3L]) + # validate start month and day + if (is.na(start_date)) { + abort(paste0( + "For 'RunPeriod' ", surround(name[[1L]]), " [ID:", id[[1L]], "]:\n", + "Invalid 'Start Month' (", surround(value[2]), ") or ", + "'Start Day of Month' (", surround(value[3]), ") found." )) - value[6L] <- "28" } + + # validate day of week + if (is.na(value[8L])) { + # Sunday + weekday <- 1L + } else if (tolower(value[8L]) == "useweatherfile") { + warn(paste0( + "For 'RunPeriod' ", surround(name[[1L]]), " [ID:", id[[1L]], "]:\n", + "Option 'UseWeatherFile' for 'Start Day of Week' has been removed, ", + "start week day is set by the input start date." + ), + "warning_trans_890_900" + ) + value[8L] <- NA_character_ + # Sunday + weekday <- 0L + } else { + weekday <- get_epw_wday(value[8L], monday_start = FALSE) + if (is.na(weekday)) { + warn(paste0( + "For 'RunPeriod' ", surround(name[[1L]]), " [ID:", id[[1L]], "]:\n", + "Invalid 'Start Day of Week' (", surround(value[8L]), ") found. ", + "Assuming 'Sunday'." + ), + "warning_trans_890_900" + ) + } + } + + # NOTE: just to make sure the year calculation results are + # the same as VersionUpdater + YEARS <- c(2013, 2014, 2015, 2010, 2011, 2017, 2007, 2013, 2014, 2015, 2010, 2011, 2017) + LYEARS <- c(2008, 1992, 2004, 2016, 2000, 2012, 1996, 2008, 1992, 2004, 2016, 2000, 2012) + + if (lubridate::month(start_date) == 2 && lubridate::mday(start_date) == 29) { + leap <- TRUE + } else { + leap <- FALSE + lubridate::year(start_date) <- 2017L + } + ord <- lubridate::yday(start_date) + rem <- ord %% 7L + + # start year + if (leap) { + start_year <- LYEARS[weekday - rem + 6] + } else { + start_year <- YEARS[weekday - rem + 6] + } + value[4L] <- as.character(start_year) } - # as year, month, day has been calculate, day of week for - # start day should be empty - value[8L] <- NA_character_ - } else if (!is.na(value[8L]) && tolower(value[8L]) == "useweatherfile") { - warn("warning_trans_890_900", - paste0("Run period start day of week `UseWeatherFile` option ", - "has been removed, start week day is set by the input start date." - ) - ) - value[8L] <- NA_character_ + # end year + end_year <- start_year + num_rep + value[7L] <- as.character(end_year) + + end_month <- assert_strint(value[5L], coerce = TRUE, .var.name = "End Month") + end_day <- assert_strint(value[6L], coerce = TRUE, .var.name = "End Day of Month") + + # check if leap day of end date is specified in an non-leap year + if ((!leap_year(end_year)) && end_month == 2L && end_day == 29L) { + warn(paste0( + "For 'RunPeriod' ", surround(name[[1L]]), " [ID:", id[[1L]], "]:\n", + "With 'Number of Times Runperiod to be Repeated' being ", num_rep, + "the end year will be ", end_year, ", which is not a leap year. ", + "The end date will be reset to Feb 28th." + ), "error_trans_890_900") + value[6L] <- "28" + } + + # validate end month and day + end_date <- lubridate::make_date(year = end_year, month = end_month, day = end_day) + # validate start month and day + if (is.na(end_date)) { + abort(paste0( + "For 'RunPeriod' ", surround(name[[1L]]), " [ID:", id[[1L]], "]:\n", + "Invalid 'End Month' (", surround(value[2]), ") or ", + "'End Day of Month' (", surround(value[3]), ") found." + )) + } } value }, @@ -2052,8 +2144,8 @@ trans_funs$f890t900 <- function (idf) { fene <- data.table(id_fene = viapply(fene, function (f) f$id()), name_fene = names(fene)) surf <- get_idf_value( - ._get_private(idf)$idd_env(), - ._get_private(idf)$idf_env(), + get_priv_env(idf)$idd_env(), + get_priv_env(idf)$idf_env(), object = fene$id_fene, field = rep("Building Surface Name", nrow(fene)), align = TRUE ) @@ -2062,13 +2154,13 @@ trans_funs$f890t900 <- function (idf) { # get zone name this fenestration belongs to zone <- get_idf_relation( - ._get_private(idf)$idd_env(), - ._get_private(idf)$idf_env(), + get_priv_env(idf)$idd_env(), + get_priv_env(idf)$idf_env(), value_id = unique(fene$id_surf), name = TRUE, direction = "ref_to", keep_all = TRUE, depth = 1 ) # get surface name - surf <- zone[dep == 0, list(id_surf = src_object_id, name_surf = value_chr)] + surf <- zone[dep == 0L, list(id_surf = src_object_id, name_surf = value_chr)] # get zone name zone <- zone[J(1L, "Zone"), on = c("dep", "src_class_name")][ surf, on = c("object_id" = "id_surf"), list(id_zone = src_object_id, name_zone = value_chr)] @@ -2078,8 +2170,8 @@ trans_funs$f890t900 <- function (idf) { # get daylighting control for each zone daylgt <- get_idf_relation( - ._get_private(idf)$idd_env(), - ._get_private(idf)$idf_env(), + get_priv_env(idf)$idd_env(), + get_priv_env(idf)$idf_env(), object_id = unique(zone$id_zone), name = TRUE, direction = "ref_by", keep_all = TRUE )[class_name == "Daylighting:Controls", @@ -2088,7 +2180,7 @@ trans_funs$f890t900 <- function (idf) { if (!nrow(daylgt)) { set(daylgt, NULL, "name_daylgt", character()) } else { - daylgt[._get_private(idf)$idf_env()$object, on = c("id_daylgt" = "object_id"), + daylgt[get_priv_env(idf)$idf_env()$object, on = c("id_daylgt" = "object_id"), name_daylgt := i.object_name ] } @@ -2136,19 +2228,20 @@ trans_funs$f890t900 <- function (idf) { dt11[fene_daylight_zone, on = c("rleid", "id" = "id_ctrl", "index"), value := i.name_zone] # assign new object ID - fene_daylight_zone[, id_ctrl := new_id(._get_private(idf)$idf_env()$object, "object_id", .N)] + fene_daylight_zone[, id_ctrl := new_id(get_priv_env(idf)$idf_env()$object, "object_id", .N)] # update dt dt11[fene_daylight_zone, on = "rleid", id := i.id_ctrl] # if unused, remove and throw a warning if (nrow(empty <- dt11[J(2L, NA_character_), on = c("index", "value"), nomatch = 0L])) { - warn("warning_trans_890_900", paste0( + warn(paste0( "WindowProperty:ShadingControl = ", collapse(unique(empty[, {ifelse(is.na(name), "", (name))}])), - " was not used by any surfaces, so it has not been deleted.", + " was not used by any surfaces, so it has been deleted.", collpase = "\n" - )) + ), "warning_trans_890_900") dt11 <- dt11[!empty, on = c("id", "name")] + fene_daylight_zone <- fene_daylight_zone[!empty, on = c("id_ctrl" = "id", "name_ctrl" = "name")] } if (!nrow(dt11)) { @@ -2187,8 +2280,8 @@ trans_funs$f890t900 <- function (idf) { dt11 <- rbindlist(list(dt11, fene_fld), use.names = TRUE) setorderv(dt11, c("id", "index")) + set(dt11, NULL, "rleid", NULL) } - set(dt11, NULL, "rleid", NULL) } # }}} @@ -2198,8 +2291,9 @@ trans_funs$f890t900 <- function (idf) { } # }}} # trans_900_910 {{{ +#' @importFrom checkmate assert_true trans_funs$f900t910 <- function (idf) { - assert(idf$version()[, 1:2] == 9.0) + assert_true(idf$version()[, 1:2] == 9.0) target_cls <- c( "HybridModel:Zone", # 1 @@ -2233,8 +2327,9 @@ trans_funs$f900t910 <- function (idf) { } # }}} # trans_910_920 {{{ +#' @importFrom checkmate assert_true trans_funs$f910t920 <- function (idf) { - assert(idf$version()[, 1:2] == 9.1) + assert_true(idf$version()[, 1:2] == 9.1) target_cls <- c( "Foundation:Kiva", # 1 @@ -2380,10 +2475,9 @@ trans_funs$f910t920 <- function (idf) { # }}} # warn_removed_as_comment {{{ warn_removed_as_comment <- function (idf, class) { - warn("warning_trans_910_920", paste0( - "Class '", class, "' has been removed in EnergyPlus v9.2. ", + warn(paste0("Class '", class, "' has been removed in EnergyPlus v9.2. ", "Objects in that class will be listed as comments in the new output file." - )) + ), "warning_trans_910_920") # separate by objects cmt <- idf$to_string(class = class, header = FALSE, format = "new_top") @@ -2394,7 +2488,7 @@ trans_funs$f910t920 <- function (idf) { # assign to object table ids <- idf$object_id(class = class, simplify = TRUE) - ._get_private(idf)$idf_env()$object[J(ids), on = "object_id", comment := list(cmt)] + get_priv_env(idf)$idf_env()$object[J(ids), on = "object_id", comment := list(cmt)] } # }}} # warn_table_convert {{{ @@ -2408,18 +2502,17 @@ trans_funs$f910t920 <- function (idf) { # get file path files <- dt_file$value - warn("warning_trans_910_920", paste0( - "Objects in Class '", class, "' references external ", + warn(paste0("Objects in Class '", class, "' references external ", "file. External files must be converted to the new format and saved ", "to CSV with a name suffix '-New':\n", paste0(obj, ": ", surround(files)) - )) + ), "warning_trans_910_920") # convert if (is.null(ascending)) { tables <- lapply(files, trans_table_convert) } else { - assert(have_same_len(files, ascending)) + assert_same_len(files, ascending) tables <- apply2(files, ascending, trans_table_convert) } @@ -2441,7 +2534,7 @@ trans_funs$f910t920 <- function (idf) { if (!anyNA(dt[[col]])) return(dt) - abort("error_trans_910_920", paste0("Failed to get ", name, "objects below:\n", obj_info(dt))) + abort(paste0("Failed to get ", name, "objects below:\n", obj_info(dt))) } # }}} # obj_info {{{ @@ -2487,22 +2580,34 @@ trans_funs$f910t920 <- function (idf) { warn_removed_as_comment(idf, "Table:TwoIndependentVariables") dt5 <- warn_table_convert(dt5, "Table:TwoIndependentVariables", 14L) + val <- dt5[index > 14, by = "id", { + val <- matrix(suppressWarnings(as.numeric(value)), ncol = 3L, byrow = TRUE) + val <- setnames(as.data.table(val), c("x", "y", "out")) + setorderv(val, c("x", "y")) + list(x = list(unique(val$x)), y = list(unique(val$y)), out = list(val$out) + ) + }] + # independent variable ## X - dt5_11 <- init_var_dt(dt5, - quote(index <= 10L | (index > 14L & (index - 15L) %% 3L == 0)), - min_max = 4L:5L, type = 10L - ) + dt5_11 <- init_var_dt(dt5, quote(index <= 10L), min_max = 4L:5L, type = 10L) dt5_11 <- init_var_type(dt5_11, 3L) dt5_11[J(1L), on = "index", value := paste0(value, "_IndependentVariable1")] + dt5_11 <- rbindlist(fill = TRUE, list( + dt5_11, + val[, by = "id", list(class = "Table:IndependentVariable", + index = 10L + seq_along((x[[1L]])), value = as.character(x[[1L]]))] + )) ## Y - dt5_12 <- init_var_dt(dt5, - quote(index <= 11L | (index > 15L & (index - 16L) %% 3L == 0)), - min_max = 6L:7L, type = 11L - ) + dt5_12 <- init_var_dt(dt5, quote(index <= 11L), min_max = 6L:7L, type = 11L) dt5_12 <- init_var_type(dt5_12, 3L) dt5_12[J(1L), on = "index", value := paste0(value, "_IndependentVariable2")] + dt5_12 <- rbindlist(fill = TRUE, list( + dt5_12, + val[, by = "id", list(class = "Table:IndependentVariable", + index = 10L + seq_along((y[[1L]])), value = as.character(y[[1L]]))] + )) dt5_12[, id := -.GRP + id_max, by = "id"] id_max <- min(dt5_12$id) @@ -2515,43 +2620,17 @@ trans_funs$f910t920 <- function (idf) { id_max <- min(dt5_2$id) # lookup - dt5_3 <- init_lookup_dt(dt5, - quote(index <= 13L | (index > 16L & (index - 17L) %% 3L == 0L)), - ref = 13L, min_max = 8L:9L, type = 12L, del = 11L - ) - - # extract values {{{ - # extract_values {{{ - extract_values <- function (dt, var) { - dt <- dt[, .SD, .SDcols = paste0(c("id", "var"), var)] - setnames(dt, c("id", "value")) - dt[, list(value = as.character(unique(value))), by = "id"][ - , `:=`( - index = seq.int(.N) + 10L, - class = "Table:IndependentVariable" - ), by = "id" - ] - } - # }}} - - dt5_vals <- cbind( - dt5_11[index > 10L, list(id1 = id, var1 = as.numeric(value))], - dt5_12[index > 10L, list(id2 = id, var2 = as.numeric(value))], - dt5_3[index > 10L, list(out = as.numeric(value))] - ) - setorderv(dt5_vals, c("id1", "var1", "var2"), c(-1L, 1L, 1L)) - - # extract values - dt5_11 <- rbindlist(list(dt5_11[index <= 10L], extract_values(dt5_vals, 1L)), fill = TRUE) - dt5_12 <- rbindlist(list(dt5_12[index <= 10L], extract_values(dt5_vals, 2L)), fill = TRUE) - dt5_1 <- rbindlist(list(dt5_11, dt5_12)) - - dt5_3[index > 10L, value := as.character(dt5_vals$out)] - # }}} + dt5_3 <- init_lookup_dt(dt5, quote(index <= 13L), ref = 13L, min_max = 8L:9L, type = 12L, del = 11L) + dt5_3 <- rbindlist(fill = TRUE, list( + dt5_3, + val[, by = "id", list(class = "Table:Lookup", + index = 10L + seq_along((out[[1L]])), value = as.character(out[[1L]]))] + )) dt5_3[, id := -.GRP + id_max, by = "id"] id_max <- min(dt5_3$id) dt5 <- rbindlist(list(dt5_1, dt5_2, dt5_3)) + setorderv(dt5, c("id", "index")) } # }}} # 6: Table:MultiVariableLookup {{{ @@ -2574,8 +2653,7 @@ trans_funs$f910t920 <- function (idf) { num_vars <- dt6[J(31L), on = "index"] set(num_vars, NULL, "value", suppressWarnings(as.integer(num_vars$value))) if (anyNA(num_vars$value)) { - abort("error_trans_910_920", paste0("Failed to get number of ", - "independent variables for 'Table:MultiVariableLookup' objects ", + abort(paste0("Failed to get number of independent variables for 'Table:MultiVariableLookup' objects ", "objects below:\n", obj_info(num_vars[is.na(value)]) )) } @@ -2599,10 +2677,7 @@ trans_funs$f910t920 <- function (idf) { obj <- obj_info(invld, collapse = NULL) mes <- paste0(obj, " for independent variable #", invld$idx_var) - abort("error_trans_910_920", paste0( - "Failed to get value number of independent variables for 'Table:MultiVariableLookup' ", - "objects below:\n", mes) - ) + abort(paste0("Failed to get value number of independent variables for 'Table:MultiVariableLookup' objects below:\n", mes)) } meta[, cum := cumsum(data.table::shift(val_number, fill = 0L)), by = "id"] @@ -2731,6 +2806,7 @@ trans_funs$f910t920 <- function (idf) { # }}} dt6 <- rbindlist(list(dt6_1, dt6_2, dt6_3)) + setorderv(dt6, c("id", "index")) } # }}} @@ -2738,7 +2814,7 @@ trans_funs$f910t920 <- function (idf) { dt7 <- trans_action(idf, "ThermalStorage:Ice:Detailed", reset = list(6L, "quadraticlinear", "FractionDischargedLMTD"), reset = list(6L, "cubiclinear", "LMTDMassFlow"), - reset = list(8L, "quadraticlinear", "FractionDischargedLMTD"), + reset = list(8L, "quadraticlinear", "FractionChargedLMTD"), reset = list(8L, "cubiclinear", "LMTDMassFlow") ) # }}} @@ -2838,7 +2914,7 @@ trans_preprocess <- function (idf, version, class = NULL) { with_silent(new_idf$del(new_idf$object_id(class, simplify = TRUE), .force = TRUE)) } - priv <- ._get_private(new_idf) + priv <- get_priv_env(new_idf) # use old class name in object and value table add_joined_cols(priv$idd_env()$class, priv$idf_env()$object, "class_id", "class_name") @@ -2911,7 +2987,7 @@ trans_preprocess <- function (idf, version, class = NULL) { ) set(val, NULL, "defaulted", TRUE) # assign default values - val <- assign_default_value(priv$idd_env(), priv$idf_env(), val) + val <- assign_idf_value_default(priv$idd_env(), priv$idf_env(), val) # assign old object id val[obj, on = "rleid", object_id := i.object_id] @@ -2952,10 +3028,10 @@ trans_process <- function (new_idf, old_idf, dt) { if (!nrow(dt)) return(new_idf) # remove redundant empty fields - dt[._get_private(new_idf)$idd_env()$class, on = c("class" = "class_name"), + dt[get_priv_env(new_idf)$idd_env()$class, on = c("class" = "class_name"), `:=`(class_id = i.class_id, min_fields = i.min_fields, num_extensible = i.num_extensible) ] - dt[._get_private(new_idf)$idd_env()$field, on = c("class_id", index = "field_index"), + dt[get_priv_env(new_idf)$idd_env()$field, on = c("class_id", index = "field_index"), `:=`(extensible_group = i.extensible_group, required_field = i.required_field) ] @@ -2969,7 +3045,7 @@ trans_process <- function (new_idf, old_idf, dt) { # add fake value id dt[, value_id := .I] setnames(dt, c("id", "index", "value"), c("object_id", "field_index", "value_chr")) - dt <- remove_empty_fields(dt) + dt <- remove_empty_fields(get_priv_env(new_idf)$idd_env(), get_priv_env(new_idf)$idf_env(), dt) setnames(dt, c("object_id", "field_index", "value_chr"), c("id", "index", "value")) trans_process_load(new_idf, old_idf, dt) @@ -2989,7 +3065,7 @@ trans_postprocess <- function (idf, from, to) { if (!nrow(dt)) return(dt) if (!nrow(mapping)) return(dt) - if (!has_name(dt, "value_lower")) { + if (!has_names(dt, "value_lower")) { set(dt, NULL, "value_lower", stri_trans_tolower(dt$value)) } @@ -3070,7 +3146,6 @@ trans_postprocess <- function (idf, from, to) { # }}} # handle CondFD Nodal Temperature {{{ if (!is_meter) { - dt[index == 2, value_lower] # can still use the old name as value_lower has not been changed nodal <- dt[J(field_index, "condfd nodal temperature"), on = c("index", "value_lower"), nomatch = 0L @@ -3093,7 +3168,7 @@ trans_postprocess <- function (idf, from, to) { # get the smallest negative id in case processes above # also assign negative id for distinguishing purpose - id_ne <- if (!nrow(dt)) 0L else min(dt$id) + id_ne <- if (!nrow(dt)) 0L else min(c(dt$id, 0L)) obj_wild <- rbindlist(lapply(id_ne - (1L:10L), function (dt, id) set(copy(dt), NULL, "id", id), dt = obj_wild @@ -3189,8 +3264,9 @@ trans_postprocess <- function (idf, from, to) { # }}} # trans_action {{{ +#' @importFrom checkmate assert_true test_names trans_action <- function (idf, class, min_fields = 1L, all = FALSE, align = TRUE, ...) { - assert(idf$is_valid_class(class, all = TRUE)) + assert_true(idf$is_valid_class(class, all = TRUE)) if (!idf$is_valid_class(class)) return(data.table()) dt <- idf$to_table(class = class, align = align, all = all) @@ -3208,7 +3284,7 @@ trans_action <- function (idf, class, min_fields = 1L, all = FALSE, align = TRUE setindexv(dt, c("index")) setindexv(dt, c("id")) setindexv(dt, c("id", "index")) - if (is_named(class)) set(dt, NULL, "class", names(class)) + if (!is.null(names(class))) set(dt, NULL, "class", names(class)) trans_action_dt(dt, ...) } @@ -3260,7 +3336,7 @@ trans_action_dt <- function (dt, ...) { num <- 1L } else { num <- .N / content[[3L]] + 1L - assert(is_integer(num), msg = "Invalid step for row insertion.") + assert_count(num, .var.name = "step for row insertion") } index <- content[[1L]] + rep((length(content[[1L]]) + content[[3L]]) * (seq_len(num) - 1L), each = length(content[[1L]])) value <- rep(rep(content[[2L]], length.out = length(content[[1L]])), num) @@ -3341,10 +3417,10 @@ trans_process_load <- function (new_idf, old_idf, dt) { if (!nrow(dt)) return(new_idf) # get object table from old input - old <- ._get_private(old_idf)$idf_env()$object[J(unique(dt$id)), on = "object_id", nomatch = 0L] + old <- get_priv_env(old_idf)$idf_env()$object[J(unique(dt$id)), on = "object_id", nomatch = 0L] # get object table before inserting new objects - new_before <- ._get_private(new_idf)$idf_env()$object + new_before <- get_priv_env(new_idf)$idf_env()$object # insert new objects new_idf$load(dt, .unique = FALSE, .default = FALSE, .empty = TRUE) @@ -3355,7 +3431,7 @@ trans_process_load <- function (new_idf, old_idf, dt) { input <- dt[, list(rleid = .GRP), by = list(object_id = id, class)] input[old, on = "object_id", comment := i.comment] - ._get_private(new_idf)$idf_env()$object[ + get_priv_env(new_idf)$idf_env()$object[ !new_before, on = "object_id", `:=`(comment = { if (.N == nrow(input)) { if (.N == 1L) { @@ -3365,15 +3441,15 @@ trans_process_load <- function (new_idf, old_idf, dt) { } } else { warn( - paste0("warning_trans_", - gsub(".", "", as.character(old_idf$version()), fixed = TRUE), "_", - gsub(".", "", as.character(new_idf$version()), fixed = TRUE)), - paste0("Failed to preserve comments of objects involved during transition ", "from ", old_idf$version()[, 1:2], " to ", new_idf$version()[, 1:2], ". ", "Comments of objects below will be removed:\n", get_object_info(.SD, c("name", "id"), collapse = "\n") - ) + ), + paste0("warning_trans_", + gsub(".", "", as.character(old_idf$version()), fixed = TRUE), "_", + gsub(".", "", as.character(new_idf$version()), fixed = TRUE)) + ) list(comment) } @@ -3396,8 +3472,7 @@ trans_table_convert <- function (path, ascending = c(TRUE, TRUE)) { num_vals <- viapply(val_vars, length) if (any(mismatch <- (num_vals != unlist(vars[, -"V1"])))) { invld <- unlist(vars[, .SD, .SDcols = setdiff(names(vars), "V1")[mismatch]]) - abort("error_trans_910_920", paste0( - "Number of independent variable values found mismatches with description in header:\n", + abort(paste0("Number of independent variable values found mismatches with description in header:\n", " #", which(mismatch), "| ", invld, " specified in header but ", num_vals[mismatch], " values found" )) @@ -3462,25 +3537,20 @@ version_updater <- function (idf, ver, dir = NULL, keep_all = FALSE) { # parse file if (!is_idf(idf)) idf <- read_idf(idf) - assert(is_idd_ver(ver)) + if (length(ver) != 1L || is.na(ver <- convert_to_idd_ver(ver))) { + abort("'ver' must be a valid EnergyPlus IDD version") + } # save the model to the output dir if necessary if (is.null(idf$path()) || !utils::file_test("-f", idf$path())) { - abort("error_idf_not_local", - paste0( - "The Idf object is not created from local file or local file has ", - "been deleted from disk. Please save Idf using $save() before transition." - ) - ) + abort(paste0("The Idf object is not created from local file or local file has ", + "been deleted from disk. Please save Idf using '$save()' before transition." + )) } # stop if unsaved if (idf$is_unsaved()) { - abort("error_idf_not_saved", - paste0("Idf has been modified since read or last saved. ", - "Please save Idf using $save() before transition." - ) - ) + abort("Idf has been modified since read or last saved. Please save Idf using '$save()' before transition.") } if (is.null(dir)) { @@ -3489,9 +3559,6 @@ version_updater <- function (idf, ver, dir = NULL, keep_all = FALSE) { dir.create(dir, recursive = TRUE) } - # stop if there is no newer version of EnergyPlus installed - ver <- standardize_ver(ver) - # skip if input is already at the specified version if (idf$version()[, 1:2] == ver[, 1:2]) { verbose_info("IDF is already at latest version ", ver, ". No transition needed.") @@ -3506,9 +3573,7 @@ version_updater <- function (idf, ver, dir = NULL, keep_all = FALSE) { latest_ver <- avail_eplus()[avail_eplus()[, 1:2] >= ver[, 1:2]] if (!length(latest_ver)) { - abort("error_updater_not_avail", paste0( - "EnergyPlus v", ver, " or newer are not installed." - )) + abort(paste0("EnergyPlus v", ver, " or newer are not installed.")) } # save the original file with trailing version number @@ -3521,6 +3586,7 @@ version_updater <- function (idf, ver, dir = NULL, keep_all = FALSE) { # avoid to use IDFVersionUpdater v9.0 as there are fital errors if (length(latest_ver[latest_ver[, 1:2] != 9.0])) latest_ver <- latest_ver[latest_ver[, 1:2] != 9.0] path_updater <- file.path(eplus_config(max(latest_ver))$dir, "PreProcess/IDFVersionUpdater") + verbose_info("IDFVersionUpdater: ", normalizePath(path_updater, mustWork = FALSE)) # get upper versions toward target version vers <- trans_upper_versions(idf, ver) @@ -3565,22 +3631,13 @@ version_updater <- function (idf, ver, dir = NULL, keep_all = FALSE) { trans_path <- file.path(path_updater, current_exe) if (!file.exists(trans_path)) { - abort("error_version_updater_exe_not_exist", - paste0( - "Transition executable ", surround(trans_path), " does not exist." - ) - ) + abort(paste0("Transition executable ", surround(trans_path), " does not exist.")) } job <- tryCatch(processx::run(trans_path, idf$path(), wd = path_updater), error = function (e) { if (grepl("System command error", conditionMessage(e))) { - abort("error_updater_failed", - paste0("Failed to update file ", idf$path(), - " from V", idf$version(), " to V", toward, ":\n", - conditionMessage(e) - ) - ) + abort(paste0("Failed to update file ", idf$path()," from V", idf$version(), " to V", toward, ":\n", conditionMessage(e))) } else { stop(e) } @@ -3588,11 +3645,7 @@ version_updater <- function (idf, ver, dir = NULL, keep_all = FALSE) { ) if (job$status != 0L) { - abort("error_updater_failed", - paste0("Failed to update file ", idf$path(), - " from V", idf$version(), " to V", toward, "." - ) - ) + abort(paste0("Failed to update file ", idf$path()," from V", idf$version(), " to V", toward, ".")) } verbose_info("[", idf$version(), " --> ", toward, "] SUCCEEDED.\n") @@ -3603,9 +3656,14 @@ version_updater <- function (idf, ver, dir = NULL, keep_all = FALSE) { # read error file path_err <- paste0(tools::file_path_sans_ext(idf$path()), ".VCpErr") - err <- read_err(path_err) - # remove VCpErr file generated - unlink(path_err, force = TRUE) + # in case VersionUpdater crashed + if (!file.exists(path_err)) { + err <- data.table() + } else { + err <- read_err(path_err) + # remove VCpErr file generated + unlink(path_err, force = TRUE) + } # rename the old file file.rename(paste0(tools::file_path_sans_ext(idf$path()), ".idfold"), idf$path()) diff --git a/man/transition.Rd b/man/transition.Rd index d3a09d142..49e23ddd9 100644 --- a/man/transition.Rd +++ b/man/transition.Rd @@ -9,7 +9,7 @@ transition(idf, ver, keep_all = FALSE, save = FALSE, dir = NULL) \arguments{ \item{idf}{An \link{Idf} object or a path of IDF file.} -\item{ver}{A valid EnergyPlus version, e.g. \code{9}, \code{8.8}, or \code{"8.8.0"}.} +\item{ver}{A valid EnergyPlus IDD version, e.g. \code{9}, \code{8.8}, or \code{"8.8.0"}.} \item{keep_all}{If \code{TRUE}, a list will be return which contains all \link{Idf} objects of intermediate versions. The list will be named using first diff --git a/man/version_updater.Rd b/man/version_updater.Rd index 4c3ed52ab..0477f1f7f 100644 --- a/man/version_updater.Rd +++ b/man/version_updater.Rd @@ -9,7 +9,7 @@ version_updater(idf, ver, dir = NULL, keep_all = FALSE) \arguments{ \item{idf}{An \link{Idf} object or a path of IDF file.} -\item{ver}{A valid EnergyPlus version, e.g. \code{9}, \code{8.8}, or \code{"8.8.0"}.} +\item{ver}{A valid EnergyPlus IDD version, e.g. \code{9}, \code{8.8}, or \code{"8.8.0"}.} \item{dir}{The directory to save the new IDF files. If the directory does not exist, it will be created before save. If \code{NULL}, the directory of input diff --git a/tests/testthat/files/v8.2.idf b/tests/testthat/files/v8.2.idf deleted file mode 100644 index 5dd844e1f..000000000 --- a/tests/testthat/files/v8.2.idf +++ /dev/null @@ -1,157 +0,0 @@ -!-Generator eplusr -!-Option SortedOrder - -!-NOTE: All comments with '!-' are ignored by the IDFEditor and are generated automatically. -!- Use '!' comments if they need to be retained when using the IDFEditor. - - -!- =========== ALL OBJECTS IN CLASS: VERSION =========== - -Version, - 8.2; !- Version Identifier - - -!- =========== ALL OBJECTS IN CLASS: BUILDING =========== - -Building, - Ref Bldg Large Office New2004_v1.3_5.0, !- Name - 0, !- North Axis {deg} - City, !- Terrain - 0.04, !- Loads Convergence Tolerance Value - 0.2, !- Temperature Convergence Tolerance Value {deltaC} - FullInteriorAndExterior, !- Solar Distribution - 25, !- Maximum Number of Warmup Days - 6; !- Minimum Number of Warmup Days - - -!- =========== ALL OBJECTS IN CLASS: SITE:GROUNDDOMAIN =========== - -Site:GroundDomain, - CoupledSlab, !- Name - 5, !- Ground Domain Depth {m} - 1, !- Aspect Ratio - 5, !- Perimeter Offset {m} - 1.8, !- Soil Thermal Conductivity {W/m-K} - 3200, !- Soil Density {kg/m3} - 836, !- Soil Specific Heat {J/kg-K} - 30, !- Soil Moisture Content Volume Fraction {percent} - 50, !- Soil Moisture Content Volume Fraction at Saturation {percent} - 15.5, !- Kusuda-Achenbach Average Surface Temperature {C} - 12.8, !- Kusuda-Achenbach Average Amplitude of Surface Temperature {deltaC} - 17.3, !- Kusuda-Achenbach Phase Shift of Minimum Surface Temperature {days} - 1, !- Evapotranspiration Ground Cover Parameter - GroundCoupledOSCM, !- Slab Boundary Condition Model Name - OnGrade, !- Slab Location - , !- Slab Material Name - No, !- Horizontal Insulation - , !- Horizontal Insulation Material Name - Full, !- Horizontal Insulation Extents - , !- Perimeter Insulation Width {m} - Yes, !- Vertical Insulation - Insulation, !- Vertical Insulation Material Name - 1.5, !- Vertical Insulation Depth {m} - Hourly; !- Simulation Timestep - - -!- =========== ALL OBJECTS IN CLASS: GLOBALGEOMETRYRULES =========== - -GlobalGeometryRules, - UpperLeftCorner, !- Starting Vertex Position - Counterclockwise, !- Vertex Entry Direction - Relative, !- Coordinate System - Relative; !- Daylighting Reference Point Coordinate System - - -!- =========== ALL OBJECTS IN CLASS: EVAPORATIVECOOLER:INDIRECT:RESEARCHSPECIAL =========== - -EvaporativeCooler:Indirect:ResearchSpecial, - FURNACE_PACU_CAV:1_OAIndRDD Evap Cooler, !- Name - ALWAYS_ON, !- Availability Schedule Name - 0.7500, !- Cooler Maximum Effectiveness - , !- Cooler Flow Ratio - 30.0000, !- Recirculating Water Pump Power Consumption {W} - Autosize, !- Secondary Fan Flow Rate {m3/s} - 0.6000, !- Secondary Fan Total Efficiency - 124.6000, !- Secondary Fan Delta Pressure {Pa} - FURNACE_PACU_CAV:1_OAInlet Node, !- Primary Air Inlet Node Name - FURNACE_PACU_CAV:1_OAIndRDD Evap Cooler-FURNACE_PACU_CAV:1_OADirect Evap CoolerNode, !- Primary Air Outlet Node Name - , !- Control Type - 0.9000, !- Dewpoint Effectiveness Factor - FURNACE_PACU_CAV:1_OAIndRDD Evap CoolerOA node, !- Secondary Air Inlet Node Name - FURNACE_PACU_CAV:1_OADirect Evap Cooler-FURNACE_PACU_CAV:1_OAMixing BoxNode, !- Sensor Node Name - , !- Relief Air Inlet Node Name - , !- Water Supply Storage Tank Name - 0.2, !- Drift Loss Fraction - 3; !- Blowdown Concentration Ratio - - -!- =========== ALL OBJECTS IN CLASS: EVAPORATIVECOOLER:DIRECT:RESEARCHSPECIAL =========== - -EvaporativeCooler:Direct:ResearchSpecial, - FURNACE_PACU_CAV:1_OADirect Evap Cooler, !- Name - ALWAYS_ON, !- Availability Schedule Name - 0.7, !- Cooler Effectiveness - 30.0, !- Recirculating Water Pump Power Consumption {W} - FURNACE_PACU_CAV:1_OAIndRDD Evap Cooler-FURNACE_PACU_CAV:1_OADirect Evap CoolerNode, !- Air Inlet Node Name - FURNACE_PACU_CAV:1_OADirect Evap Cooler-FURNACE_PACU_CAV:1_OAMixing BoxNode, !- Air Outlet Node Name - FURNACE_PACU_CAV:1_OADirect Evap Cooler-FURNACE_PACU_CAV:1_OAMixing BoxNode, !- Sensor Node Name - , !- Water Supply Storage Tank Name - 0.0, !- Drift Loss Fraction - 3; !- Blowdown Concentration Ratio - - -!- =========== ALL OBJECTS IN CLASS: CHILLER:ELECTRIC:REFORMULATEDEIR =========== - -Chiller:Electric:ReformulatedEIR, - CoolSys1 Chiller 1, !- Name - AUTOSIZE, !- Reference Capacity {W} - 5.5, !- Reference COP {W/W} - 6.67, !- Reference Leaving Chilled Water Temperature {C} - 35, !- Reference Leaving Condenser Water Temperature {C} - AutoSize, !- Reference Chilled Water Flow Rate {m3/s} - AutoSize, !- Reference Condenser Water Flow Rate {m3/s} - WC Screw Default 90.1-2004 Cap_fT, !- Cooling Capacity Function of Temperature Curve Name - WC Screw Default 90.1-2004 EIR_fT, !- Electric Input to Cooling Output Ratio Function of Temperature Curve Name - ReformEIRChiller Carrier 19XR 1259kW/6.26COP/Vanes EIRFPLR, !- Electric Input to Cooling Output Ratio Function of Part Load Ratio Curve Name - 0.1, !- Minimum Part Load Ratio - 1, !- Maximum Part Load Ratio - 1, !- Optimum Part Load Ratio - 0.2, !- Minimum Unloading Ratio - Pump-CoolSys1 ChillerNode 1, !- Chilled Water Inlet Node Name - Supply Equipment Outlet Node 1, !- Chilled Water Outlet Node Name - Chiller Water Inlet Node 1, !- Condenser Inlet Node Name - Chiller Water Outlet Node 1, !- Condenser Outlet Node Name - 1, !- Fraction of Compressor Electric Consumption Rejected by Condenser - 2, !- Leaving Chilled Water Lower Temperature Limit {C} - LeavingSetpointModulated,!- Chiller Flow Mode Type - 0, !- Design Heat Recovery Water Flow Rate {m3/s} - , !- Heat Recovery Inlet Node Name - , !- Heat Recovery Outlet Node Name - 0.5; !- Sizing Factor - - -!- =========== ALL OBJECTS IN CLASS: GROUNDHEATEXCHANGER:VERTICAL =========== - -GroundHeatExchanger:Vertical, - Vertical Ground Heat Exchanger, !- Name - GHE Inlet Node, !- Inlet Node Name - GHE Outlet Node, !- Outlet Node Name - 0.0033, !- Maximum Flow Rate {m3/s} - 120, !- Number of Bore Holes - 76.2, !- Bore Hole Length {m} - 0.063508, !- Bore Hole Radius {m} - 0.692626, !- Ground Thermal Conductivity {W/m-K} - 2347000, !- Ground Thermal Heat Capacity {J/m3-K} - 13.375, !- Ground Temperature {C} - 0.0033, !- Design Flow Rate {m3/s} - 0.692626, !- Grout Thermal Conductivity {W/m-K} - 0.391312, !- Pipe Thermal Conductivity {W/m-K} - 0.0266667, !- Pipe Out Diameter {m} - 0.0253977, !- U-Tube Distance {m} - 0.00241285, !- Pipe Thickness {m} - 2, !- Maximum Length of Simulation - 5e-04, !- G-Function Reference Ratio {dimensionless} - 35, !- Number of Data Pairs of the G Function - -15.2996, !- G-Function Ln(T/Ts) Value 1 - -0.348322; !- G-Function G Value 1 - diff --git a/tests/testthat/files/v8.8.idf b/tests/testthat/files/v8.8.idf deleted file mode 100644 index 4ce0d7f5c..000000000 --- a/tests/testthat/files/v8.8.idf +++ /dev/null @@ -1,302 +0,0 @@ -!-Generator eplusr -!-Option SortedOrder - -!-NOTE: All comments with '!-' are ignored by the IDFEditor and are generated automatically. -!- Use '!' comments if they need to be retained when using the IDFEditor. - - -!- =========== ALL OBJECTS IN CLASS: VERSION =========== - -Version, - 8.8; !- Version Identifier - - -!- =========== ALL OBJECTS IN CLASS: SCHEDULE:DAY:INTERVAL =========== - -Schedule:Day:Interval, - DaySchedule5, !- Name - Temperature, !- Schedule Type Limits Name - Yes, !- Interpolate to Timestep - until: 24:00, !- Time 1 {hh:mm} - 5; !- Value Until Time 1 - - -!- =========== ALL OBJECTS IN CLASS: SCHEDULE:DAY:LIST =========== - -Schedule:Day:List, - Example Weather Temp, !- Name - Any Number, !- Schedule Type Limits Name - Yes, !- Interpolate to Timestep - 15, !- Minutes per Item - 19.55, !- Value 1 - 20.1, !- N3 - 20.65, !- N4 - 21.2, !- N5 - 21.25, !- N6 - 21.3, !- N7 - 21.35, !- N8 - 21.4, !- N9 - 21.25, !- N10 - 21.1, !- N11 - 20.95, !- N12 - 20.8, !- N13 - 20.625, !- N14 - 20.45, !- N15 - 20.275, !- N16 - 20.1, !- N17 - 19.95, !- N18 - 19.8, !- N19 - 19.65, !- N20 - 19.5, !- N21 - 19.625, !- N22 - 19.75, !- N23 - 19.875, !- N24 - 20, !- N25 - 20.25, !- N26 - 20.5, !- N27 - 20.75, !- N28 - 21, !- N29 - 21.1, !- N30 - 21.2, !- N31 - 21.3, !- N32 - 21.4, !- N33 - 21.8, !- N34 - 22.2, !- N35 - 22.6, !- N36 - 23, !- N37 - 23, !- N38 - 23, !- N39 - 23, !- N40 - 23, !- N41 - 23.375, !- N42 - 23.75, !- N43 - 24.125, !- N44 - 24.5, !- N45 - 24.45, !- N46 - 24.4, !- N47 - 24.35, !- N48 - 24.3, !- N49 - 24.225, !- N50 - 24.15, !- N51 - 24.075, !- N52 - 24, !- N53 - 23.95, !- N54 - 23.9, !- N55 - 23.85, !- N56 - 23.8, !- N57 - 23.85, !- N58 - 23.9, !- N59 - 23.95, !- N60 - 24, !- N61 - 24, !- N62 - 24, !- N63 - 24, !- N64 - 24, !- N65 - 23.825, !- N66 - 23.65, !- N67 - 23.475, !- N68 - 23.3, !- N69 - 23.1, !- N70 - 22.9, !- N71 - 22.7, !- N72 - 22.5, !- N73 - 22.275, !- N74 - 22.05, !- N75 - 21.825, !- N76 - 21.6, !- N77 - 21.4, !- N78 - 21.2, !- N79 - 21, !- N80 - 20.8, !- N81 - 20.7, !- N82 - 20.6, !- N83 - 20.5, !- N84 - 20.4, !- N85 - 20.3, !- N86 - 20.2, !- N87 - 20.1, !- N88 - 20, !- N89 - 20, !- N90 - 20, !- N91 - 20, !- N92 - 20, !- N93 - 19.75, !- N94 - 19.5, !- N95 - 19.25, !- N96 - 19; !- N97 - - -!- =========== ALL OBJECTS IN CLASS: SCHEDULE:COMPACT =========== - -Schedule:Compact, - Kitchen_Flr_5_Case:1_WALKINFREEZER_CaseDefrost2aDaySched, !- Name - On/Off, !- Schedule Type Limits Name - Through: 12/31, !- Field 1 - For:AllDays, !- Field 2 - Interpolate:Yes, !- Field 3 - Until: 11:00, !- Field 4 - 0, !- Field 5 - Until: 11:20, !- Field 6 - 1, !- Field 7 - Until: 23:00, !- Field 8 - 0, !- Field 9 - Until: 23:20, !- Field 10 - 1, !- Field 11 - Until: 24:00, !- Field 12 - 0; !- Field 13 - - -!- =========== ALL OBJECTS IN CLASS: ELECTRICEQUIPMENT:ITE:AIRCOOLED =========== - -ElectricEquipment:ITE:AirCooled, - Data Center Servers, !- Name - Main Zone, !- Zone Name - Watts/Unit, !- Design Power Input Calculation Method - 500, !- Watts per Unit {W} - 100, !- Number of Units - , !- Watts per Zone Floor Area {W/m2} - Data Center Operation Schedule, !- Design Power Input Schedule Name - Data Center CPU Loading Schedule, !- CPU Loading Schedule Name - Data Center Servers Power fLoadTemp, !- CPU Power Input Function of Loading and Air Temperature Curve Name - 0.4, !- Design Fan Power Input Fraction - 1e-04, !- Design Fan Air Flow Rate per Power Input {m3/s-W} - Data Center Servers Airflow fLoadTemp, !- Air Flow Function of Loading and Air Temperature Curve Name - ECM FanPower fFlow, !- Fan Power Input Function of Flow Curve Name - 15, !- Design Entering Air Temperature {C} - A3, !- Environmental Class - AdjustedSupply, !- Air Inlet Connection Type - , !- Air Inlet Room Air Model Node Name - , !- Air Outlet Room Air Model Node Name - Main Zone Inlet Node, !- Supply Air Node Name - 0.1, !- Design Recirculation Fraction - Data Center Recirculation fLoadTemp, !- Recirculation Function of Loading and Supply Temperature Curve Name - 0.9, !- Design Electric Power Supply Efficiency - UPS Efficiency fPLR, !- Electric Power Supply Efficiency Function of Part Load Ratio Curve Name - 1, !- Fraction of Electric Power Supply Losses to Zone - ITE-CPU, !- CPU End-Use Subcategory - ITE-Fans, !- Fan End-Use Subcategory - ITE-UPS; !- Electric Power Supply End-Use Subcategory - - -!- =========== ALL OBJECTS IN CLASS: ZONEHVAC:EQUIPMENTCONNECTIONS =========== - -ZoneHVAC:EquipmentConnections, - SPACE1-1, !- Zone Name - Zone1Equipment, !- Zone Conditioning Equipment List Name - Zone1Inlets, !- Zone Air Inlet Node or NodeList Name - Zone 1 Outlet Node, !- Zone Air Exhaust Node or NodeList Name - Zone 1 Node, !- Zone Air Node Name - Zone 1 Return Node; !- Zone Return Air Node or NodeList Name - - -!- =========== ALL OBJECTS IN CLASS: BRANCH =========== - -Branch, - Condenser Supply GHE Branch, !- Name - , !- Pressure Drop Curve Name - GroundHeatExchanger:Vertical, !- Component 1 Object Type - Vertical Ground Heat Exchanger, !- Component 1 Name - GHE Inlet Node, !- Component 1 Inlet Node Name - GHE Outlet Node; !- Component 1 Outlet Node Name - - -!- =========== ALL OBJECTS IN CLASS: GROUNDHEATEXCHANGER:VERTICAL =========== - -GroundHeatExchanger:Vertical, - Vertical Ground Heat Exchanger, !- Name - GHE Inlet Node, !- Inlet Node Name - GHE Outlet Node, !- Outlet Node Name - 0.00033, !- Design Flow Rate {m3/s} - 24, !- Number of Bore Holes - 76.2, !- Bore Hole Length {m} - 0.063508, !- Bore Hole Radius {m} - 0.692626, !- Ground Thermal Conductivity {W/m-K} - 2347000, !- Ground Thermal Heat Capacity {J/m3-K} - 13.375, !- Ground Temperature {C} - 0.692626, !- Grout Thermal Conductivity {W/m-K} - 0.391312, !- Pipe Thermal Conductivity {W/m-K} - 0.0266667, !- Pipe Out Diameter {m} - 0.0253977, !- U-Tube Distance {m} - 0.00241285, !- Pipe Thickness {m} - 2, !- Maximum Length of Simulation {years} - 5e-04, !- G-Function Reference Ratio {dimensionless} - 35, !- Number of Data Pairs of the G Function - -15.2996, !- G-Function Ln(T/Ts) Value 1 - -0.348322, !- G-Function G Value 1 - -14.201, !- G-Function Ln(T/Ts) Value 2 - 0.022208, !- G-Function G Value 2 - -13.2202, !- G-Function Ln(T/Ts) Value 3 - 0.412345, !- G-Function G Value 3 - -12.2086, !- G-Function Ln(T/Ts) Value 4 - 0.867498, !- G-Function G Value 4 - -11.1888, !- G-Function Ln(T/Ts) Value 5 - 1.357839, !- G-Function G Value 5 - -10.1816, !- G-Function Ln(T/Ts) Value 6 - 1.852024, !- G-Function G Value 6 - -9.1815, !- G-Function Ln(T/Ts) Value 7 - 2.345656, !- G-Function G Value 7 - -8.6809, !- G-Function Ln(T/Ts) Value 8 - 2.593958, !- G-Function G Value 8 - -8.5, !- G-Function Ln(T/Ts) Value 9 - 2.679, !- G-Function G Value 9 - -7.8, !- G-Function Ln(T/Ts) Value 10 - 3.023, !- G-Function G Value 10 - -7.2, !- G-Function Ln(T/Ts) Value 11 - 3.32, !- G-Function G Value 11 - -6.5, !- G-Function Ln(T/Ts) Value 12 - 3.681, !- G-Function G Value 12 - -5.9, !- G-Function Ln(T/Ts) Value 13 - 4.071, !- G-Function G Value 13 - -5.2, !- G-Function Ln(T/Ts) Value 14 - 4.828, !- G-Function G Value 14 - -4.5, !- G-Function Ln(T/Ts) Value 15 - 6.253, !- G-Function G Value 15 - -3.963, !- G-Function Ln(T/Ts) Value 16 - 7.894, !- G-Function G Value 16 - -3.27, !- G-Function Ln(T/Ts) Value 17 - 11.82, !- G-Function G Value 17 - -2.864, !- G-Function Ln(T/Ts) Value 18 - 15.117, !- G-Function G Value 18 - -2.577, !- G-Function Ln(T/Ts) Value 19 - 18.006, !- G-Function G Value 19 - -2.171, !- G-Function Ln(T/Ts) Value 20 - 22.887, !- G-Function G Value 20 - -1.884, !- G-Function Ln(T/Ts) Value 21 - 26.924, !- G-Function G Value 21 - -1.191, !- G-Function Ln(T/Ts) Value 22 - 38.004, !- G-Function G Value 22 - -0.497, !- G-Function Ln(T/Ts) Value 23 - 49.919, !- G-Function G Value 23 - -0.274, !- G-Function Ln(T/Ts) Value 24 - 53.407, !- G-Function G Value 24 - -0.051, !- G-Function Ln(T/Ts) Value 25 - 56.632, !- G-Function G Value 25 - 0.196, !- G-Function Ln(T/Ts) Value 26 - 59.825, !- G-Function G Value 26 - 0.419, !- G-Function Ln(T/Ts) Value 27 - 62.349, !- G-Function G Value 27 - 0.642, !- G-Function Ln(T/Ts) Value 28 - 64.524, !- G-Function G Value 28 - 0.873, !- G-Function Ln(T/Ts) Value 29 - 66.412, !- G-Function G Value 29 - 1.112, !- G-Function Ln(T/Ts) Value 30 - 67.993, !- G-Function G Value 30 - 1.335, !- G-Function Ln(T/Ts) Value 31 - 69.162, !- G-Function G Value 31 - 1.679, !- G-Function Ln(T/Ts) Value 32 - 70.476, !- G-Function G Value 32 - 2.028, !- G-Function Ln(T/Ts) Value 33 - 71.361, !- G-Function G Value 33 - 2.275, !- G-Function Ln(T/Ts) Value 34 - 71.79, !- G-Function G Value 34 - 3.003, !- G-Function Ln(T/Ts) Value 35 - 72.511; !- G-Function G Value 35 - - -!- =========== ALL OBJECTS IN CLASS: CONDENSEREQUIPMENTLIST =========== - -CondenserEquipmentList, - All Towers, !- Name - GroundHeatExchanger:Vertical, !- Equipment 1 Object Type - Vertical Ground Heat Exchanger; !- Equipment 1 Name - diff --git a/tests/testthat/files/v9.1.idf b/tests/testthat/files/v9.1.idf deleted file mode 100644 index f0152bbf5..000000000 --- a/tests/testthat/files/v9.1.idf +++ /dev/null @@ -1,3280 +0,0 @@ -!-Generator eplusr -!-Option SortedOrder - -!-NOTE: All comments with '!-' are ignored by the IDFEditor and are generated automatically. -!- Use '!' comments if they need to be retained when using the IDFEditor. - - -!- =========== ALL OBJECTS IN CLASS: VERSION =========== - -Version, - 9.1; !- Version Identifier - - -!- =========== ALL OBJECTS IN CLASS: RUNPERIOD =========== - -RunPeriod, - , !- Name - 1, !- Begin Month - 14, !- Begin Day of Month - , !- Begin Year - 1, !- End Month - 14, !- End Day of Month - , !- End Year - Tuesday, !- Day of Week for Start Day - Yes, !- Use Weather File Holidays and Special Days - Yes, !- Use Weather File Daylight Saving Period - No, !- Apply Weekend Holiday Rule - Yes, !- Use Weather File Rain Indicators - Yes; !- Use Weather File Snow Indicators - -RunPeriod, - , !- Name - 7, !- Begin Month - 7, !- Begin Day of Month - , !- Begin Year - 7, !- End Month - 7, !- End Day of Month - , !- End Year - Tuesday, !- Day of Week for Start Day - Yes, !- Use Weather File Holidays and Special Days - Yes, !- Use Weather File Daylight Saving Period - No, !- Apply Weekend Holiday Rule - Yes, !- Use Weather File Rain Indicators - No; !- Use Weather File Snow Indicators - - -!- =========== ALL OBJECTS IN CLASS: ZONEHVAC:EQUIPMENTLIST =========== - -ZoneHVAC:EquipmentList, - Zone1Equipment, !- Name - SequentialLoad, !- Load Distribution Scheme - ZoneHVAC:PackagedTerminalHeatPump, !- Zone Equipment 1 Object Type - Zone1PTHP, !- Zone Equipment 1 Name - 1, !- Zone Equipment 1 Cooling Sequence - 1, !- Zone Equipment 1 Heating or No-Load Sequence - , !- Zone Equipment 1 Sequential Cooling Fraction - ; !- Zone Equipment 1 Sequential Heating Fraction - -ZoneHVAC:EquipmentList, - Zone2Equipment, !- Name - SequentialLoad, !- Load Distribution Scheme - ZoneHVAC:PackagedTerminalHeatPump, !- Zone Equipment 1 Object Type - Zone2PTHP, !- Zone Equipment 1 Name - 1, !- Zone Equipment 1 Cooling Sequence - 1, !- Zone Equipment 1 Heating or No-Load Sequence - , !- Zone Equipment 1 Sequential Cooling Fraction - ; !- Zone Equipment 1 Sequential Heating Fraction - -ZoneHVAC:EquipmentList, - Zone3Equipment, !- Name - SequentialLoad, !- Load Distribution Scheme - ZoneHVAC:PackagedTerminalHeatPump, !- Zone Equipment 1 Object Type - Zone3PTHP, !- Zone Equipment 1 Name - 1, !- Zone Equipment 1 Cooling Sequence - 1, !- Zone Equipment 1 Heating or No-Load Sequence - , !- Zone Equipment 1 Sequential Cooling Fraction - ; !- Zone Equipment 1 Sequential Heating Fraction - - -!- =========== ALL OBJECTS IN CLASS: TABLE:ONEINDEPENDENTVARIABLE =========== - -Table:OneIndependentVariable, - HPACCoolCapFFF, !- Name - Quadratic, !- Curve Type - EvaluateCurveToLimits, !- Interpolation Method - 0.5, !- Minimum Value of X - 1.5, !- Maximum Value of X - 0.8, !- Minimum Table Output - 1.5, !- Maximum Table Output - Dimensionless, !- Input Unit Type for X - Dimensionless, !- Output Unit Type - , !- Normalization Reference - 0, !- X Value #1 - 0.8, !- Output Value #1 - 1, !- X Value #2 - 1, !- Output Value #2 - 1.5, !- X Value #3 - 1.1; !- Output Value #3 - -!- =========== ALL OBJECTS IN CLASS: TABLE:TWOINDEPENDENTVARIABLES =========== - -Table:TwoIndependentVariables, - HPACCoolCapFT, !- Name - BiQuadratic, !- Curve Type - EvaluateCurveToLimits, !- Interpolation Method - 12.77778, !- Minimum Value of X - 23.88889, !- Maximum Value of X - 18, !- Minimum Value of Y - 46.11111, !- Maximum Value of Y - 0, !- Minimum Table Output - 40000, !- Maximum Table Output - Temperature, !- Input Unit Type for X - Temperature, !- Input Unit Type for Y - Dimensionless, !- Output Unit Type - 24999.9597049817, !- Normalization Reference - , !- External File Name - 12.77778, !- X Value #1 - 36, !- Y Value #1 - 19524.15032, !- Output Value #1 - 12.77778, !- X Value #2 - 41, !- Y Value #2 - 18178.81244, !- Output Value #2 - 12.77778, !- X Value #3 - 46.11111, !- Y Value #3 - 16810.36004, !- Output Value #3 - 15, !- X Value #4 - 18, !- Y Value #4 - 25997.3589, !- Output Value #4 - 15, !- N20 - 30, !- N21 - 22716.4017, !- N22 - 12.77778, !- N23 - 30, !- N24 - 21147.21662, !- N25 - 12.77778, !- N26 - 35, !- N27 - 19794.00525, !- N28 - 15, !- N29 - 24, !- N30 - 24352.1562, !- N31 - 12.77778, !- N32 - 18, !- N33 - 24421.69383, !- N34 - 12.77778, !- N35 - 24, !- N36 - 22779.73113, !- N37 - 15, !- N38 - 35, !- N39 - 21360.49033, !- N40 - 15, !- N41 - 36, !- N42 - 21090.0954, !- N43 - 15, !- N44 - 41, !- N45 - 19742.05753, !- N46 - 15, !- N47 - 46.11111, !- N48 - 18370.84513, !- N49 - 18, !- N50 - 18, !- N51 - 28392.31868, !- N52 - 23.88889, !- N53 - 41, !- N54 - 27683.36592, !- N55 - 23.88889, !- N56 - 46.11111, !- N57 - 26301.11353, !- N58 - 18, !- N59 - 24, !- N60 - 26742.74198, !- N61 - 18, !- N62 - 30, !- N63 - 25102.61348, !- N64 - 23.88889, !- N65 - 35, !- N66 - 29314.75872, !- N67 - 23.88889, !- N68 - 36, !- N69 - 29042.2038, !- N70 - 19.44448943, !- N71 - 24, !- N72 - 28003.546, !- N73 - 19.44448943, !- N74 - 30, !- N75 - 26361.31143, !- N76 - 18, !- N77 - 35, !- N78 - 23743.0571, !- N79 - 18, !- N80 - 36, !- N81 - 23471.93318, !- N82 - 18, !- N83 - 41, !- N84 - 22120.2503, !- N85 - 18, !- N86 - 46.11111, !- N87 - 20745.3119, !- N88 - 21, !- N89 - 18, !- N90 - 31094.97495, !- N91 - 21, !- N92 - 24, !- N93 - 29441.02425, !- N94 - 19.44448943, !- N95 - 18, !- N96 - 29655.22876, !- N97 - 21, !- N98 - 30, !- N99 - 27796.52175, !- N100 - 21, !- N101 - 35, !- N102 - 26433.32038, !- N103 - 21, !- N104 - 36, !- N105 - 26161.46745, !- N106 - 21, !- N107 - 41, !- N108 - 24806.13958, !- N109 - 21, !- N110 - 46.11111, !- N111 - 23427.47518, !- N112 - 23.88889, !- N113 - 18, !- N114 - 33988.3473, !- N115 - 23.88889, !- N116 - 24, !- N117 - 32330.1846, !- N118 - 23.88889, !- N119 - 30, !- N120 - 30681.4701, !- N121 - 19.44448943, !- N122 - 35, !- N123 - 25000, !- N124 - 19.44448943, !- N125 - 36, !- N126 - 24728.52506, !- N127 - 19.44448943, !- N128 - 41, !- N129 - 23375.08713, !- N130 - 19.44448943, !- N131 - 46.11111, !- N132 - 21998.35468; !- N133 - -!- =========== ALL OBJECTS IN CLASS: TABLE:MULTIVARIABLELOOKUP =========== - -Table:MultiVariableLookup, - My5VariableLookupTable, !- Name - LagrangeInterpolationLinearExtrapolation, !- Interpolation Method - 3, !- Number of Interpolation Points - BiQuadratic, !- Curve Type - SingleLineIndependentVariableWithMatrix, !- Table Data Format - , !- External File Name - ASCENDING, !- X1 Sort Order - DESCENDING, !- X2 Sort Order - , !- Normalization Reference - 60, !- Minimum Value of X1 - 120, !- Maximum Value of X1 - 0, !- Minimum Value of X2 - 1, !- Maximum Value of X2 - 0, !- Minimum Value of X3 - 1, !- Maximum Value of X3 - 60, !- Minimum Value of X4 - 120, !- Maximum Value of X4 - 30, !- Minimum Value of X5 - 60, !- Maximum Value of X5 - , !- Minimum Value of X6 - , !- Maximum Value of X6 - 0, !- Minimum Table Output - 10, !- Maximum Table Output - Temperature, !- Input Unit Type for X1 - Dimensionless, !- Input Unit Type for X2 - Dimensionless, !- Input Unit Type for X3 - Temperature, !- Input Unit Type for X4 - Dimensionless, !- Input Unit Type for X5 - Dimensionless, !- Input Unit Type for X6 - Dimensionless, !- Output Unit Type - 5, !- Number of Independent Variables - 5, !- Number of Values for Independent Variable X1 - 6, !- Field 1 Determined by the Number of Independent Variables - 9, !- Field 2 Determined by the Number of Independent Variables - 5, !- Field 3 Determined by the Number of Independent Variables - 2, !- N22 - 72, !- N23 - 74, !- N24 - 76, !- N25 - 78, !- N26 - 80, !- N27 - 0.400000006, !- N28 - 0.449999988, !- N29 - 0.5, !- N30 - 0.550000012, !- N31 - 0.599999964, !- N32 - 0.649999976, !- N33 - 0.100000001, !- N34 - 0.199999988, !- N35 - 0.299999982, !- N36 - 0.399999976, !- N37 - 0.49999997, !- N38 - 0.599999964, !- N39 - 0.699999988, !- N40 - 0.799999952, !- N41 - 0.899999976, !- N42 - 75, !- N43 - 85, !- N44 - 95, !- N45 - 105, !- N46 - 115, !- N47 - 38.900001526, !- N48 - 58.299999237, !- N49 - 0.100000001, !- N50 - 75, !- N51 - 38.900001526, !- N52 - 8.362903595, !- N53 - 8.673998833, !- N54 - 8.985898018, !- N55 - 9.311108589, !- N56 - 9.640462875, !- N57 - 8.132709503, !- N58 - 8.430570602, !- N59 - 8.734939575, !- N60 - 9.043934822, !- N61 - 9.37100029, !- N62 - 7.932241917, !- N63 - 8.218854904, !- N64 - 8.503153801, !- N65 - 8.792686462, !- N66 - 9.090137482, !- N67 - 7.745451927, !- N68 - 8.006804466, !- N69 - 8.278247833, !- N70 - 8.558484077, !- N71 - 8.845284462, !- N72 - 7.555707932, !- N73 - 7.807681561, !- N74 - 8.068052292, !- N75 - 8.333242416, !- N76 - 8.604722977, !- N77 - 7.362575054, !- N78 - 7.589694977, !- N79 - 7.834506035, !- N80 - 8.091814995, !- N81 - 8.347365379, !- N82 - 0.199999988, !- N83 - 75, !- N84 - 38.900001526, !- N85 - 8.009307861, !- N86 - 8.301462173, !- N87 - 8.601654053, !- N88 - 8.909973145, !- N89 - 9.222886086, !- N90 - 7.791565418, !- N91 - 8.070688248, !- N92 - 8.363984108, !- N93 - 8.65114975, !- N94 - 8.960956573, !- N95 - 7.600991249, !- N96 - 7.873175621, !- N97 - 8.143985748, !- N98 - 8.419803619, !- N99 - 8.701591492, !- N100 - 7.423594952, !- N101 - 7.667917728, !- N102 - 7.928957462, !- N103 - 8.195877075, !- N104 - 8.46938324, !- N105 - 7.243413448, !- N106 - 7.482439041, !- N107 - 7.730514526, !- N108 - 7.981428146, !- N109 - 8.239952087, !- N110 - 7.05847168, !- N111 - 7.277166367, !- N112 - 7.5133214, !- N113 - 7.751350403, !- N114 - 7.99594593, !- N115 - 0.299999982, !- N116 - 75, !- N117 - 38.900001526, !- N118 - 7.685127735, !- N119 - 7.971322536, !- N120 - 8.256714821, !- N121 - 8.544967651, !- N122 - 8.849281311, !- N123 - 7.484996319, !- N124 - 7.747642994, !- N125 - 8.031193733, !- N126 - 8.304456711, !- N127 - 8.598163605, !- N128 - 7.303447723, !- N129 - 7.562814236, !- N130 - 7.820975304, !- N131 - 8.084726334, !- N132 - 8.354193687, !- N133 - 7.135470867, !- N134 - 7.367517948, !- N135 - 7.617700577, !- N136 - 7.870592117, !- N137 - 8.131596565, !- N138 - 6.962431431, !- N139 - 7.190596104, !- N140 - 7.426773548, !- N141 - 7.666893005, !- N142 - 7.912358284, !- N143 - 6.787916183, !- N144 - 6.996275425, !- N145 - 7.221558571, !- N146 - 7.452087879, !- N147 - 7.680626869, !- N148 - 0.399999976, !- N149 - 75, !- N150 - 38.900001526, !- N151 - 7.39979887, !- N152 - 7.671185017, !- N153 - 7.945892811, !- N154 - 8.224569321, !- N155 - 8.513233185, !- N156 - 7.208674908, !- N157 - 7.458854198, !- N158 - 7.725589275, !- N159 - 7.992704868, !- N160 - 8.270493507, !- N161 - 7.034598827, !- N162 - 7.285416126, !- N163 - 7.530445099, !- N164 - 7.782519341, !- N165 - 8.039845467, !- N166 - 6.876236439, !- N167 - 7.104327679, !- N168 - 7.33442831, !- N169 - 7.577397823, !- N170 - 7.826413631, !- N171 - 6.708562851, !- N172 - 6.927354813, !- N173 - 7.153215885, !- N174 - 7.383201599, !- N175 - 7.618229866, !- N176 - 6.546977043, !- N177 - 6.746573925, !- N178 - 6.957671642, !- N179 - 7.176038742, !- N180 - 7.397747993, !- N181 - 0.49999997, !- N182 - 75, !- N183 - 38.900001526, !- N184 - 7.145950794, !- N185 - 7.400495052, !- N186 - 7.667282104, !- N187 - 7.932030201, !- N188 - 8.207801819, !- N189 - 6.9576478, !- N190 - 7.198328972, !- N191 - 7.450638294, !- N192 - 7.709997177, !- N193 - 7.973426342, !- N194 - 6.790382385, !- N195 - 7.03071785, !- N196 - 7.266670704, !- N197 - 7.509929657, !- N198 - 7.756206036, !- N199 - 6.638187885, !- N200 - 6.857587814, !- N201 - 7.078690052, !- N202 - 7.311843395, !- N203 - 7.550194263, !- N204 - 6.477313995, !- N205 - 6.687936306, !- N206 - 6.904848099, !- N207 - 7.12588501, !- N208 - 7.351845264, !- N209 - 6.32466507, !- N210 - 6.51508522, !- N211 - 6.717224121, !- N212 - 6.927174091, !- N213 - 7.141005039, !- N214 - 0.599999964, !- N215 - 75, !- N216 - 38.900001526, !- N217 - 6.90778923, !- N218 - 7.148267746, !- N219 - 7.407217979, !- N220 - 7.666702271, !- N221 - 7.931069374, !- N222 - 6.728770256, !- N223 - 6.960438251, !- N224 - 7.199522972, !- N225 - 7.453735828, !- N226 - 7.702408791, !- N227 - 6.567364693, !- N228 - 6.791221619, !- N229 - 7.026438713, !- N230 - 7.259836197, !- N231 - 7.497921944, !- N232 - 6.419781208, !- N233 - 6.633556366, !- N234 - 6.848979473, !- N235 - 7.06976223, !- N236 - 7.299444199, !- N237 - 6.265988827, !- N238 - 6.468684673, !- N239 - 6.678459644, !- N240 - 6.890955448, !- N241 - 7.108711243, !- N242 - 6.122149467, !- N243 - 6.303151131, !- N244 - 6.497097015, !- N245 - 6.700903416, !- N246 - 6.906543255, !- N247 - 0.699999988, !- N248 - 75, !- N249 - 38.900001526, !- N250 - 6.68943882, !- N251 - 6.923577785, !- N252 - 7.17202282, !- N253 - 7.42682457, !- N254 - 7.705205441, !- N255 - 6.518424034, !- N256 - 6.74202919, !- N257 - 6.97183466, !- N258 - 7.218411446, !- N259 - 7.457614422, !- N260 - 6.36229229, !- N261 - 6.578548908, !- N262 - 6.803874016, !- N263 - 7.032155991, !- N264 - 7.261574745, !- N265 - 6.220606327, !- N266 - 6.428524494, !- N267 - 6.636671543, !- N268 - 6.846909046, !- N269 - 7.069701672, !- N270 - 6.072504997, !- N271 - 6.268546581, !- N272 - 6.470074654, !- N273 - 6.675432682, !- N274 - 6.88598156, !- N275 - 5.934712887, !- N276 - 6.109331131, !- N277 - 6.293673038, !- N278 - 6.492287636, !- N279 - 6.691280842, !- N280 - 0.799999952, !- N281 - 75, !- N282 - 38.900001526, !- N283 - 6.489015579, !- N284 - 6.716403484, !- N285 - 6.955620289, !- N286 - 7.22365284, !- N287 - 7.472298145, !- N288 - 6.325336933, !- N289 - 6.541736603, !- N290 - 6.763221741, !- N291 - 6.996306896, !- N292 - 7.233995914, !- N293 - 6.173942089, !- N294 - 6.383189678, !- N295 - 6.602017879, !- N296 - 6.82190752, !- N297 - 7.044112682, !- N298 - 6.037173748, !- N299 - 6.238247871, !- N300 - 6.439656258, !- N301 - 6.643716335, !- N302 - 6.858282089, !- N303 - 5.890603065, !- N304 - 6.083823681, !- N305 - 6.278072834, !- N306 - 6.477452755, !- N307 - 6.680627346, !- N308 - 5.764327049, !- N309 - 5.930488586, !- N310 - 6.10855484, !- N311 - 6.298379898, !- N312 - 6.49066925, !- N313 - 0.899999976, !- N314 - 75, !- N315 - 38.900001526, !- N316 - 6.303743839, !- N317 - 6.530200481, !- N318 - 6.784637928, !- N319 - 6.991819859, !- N320 - 7.231474876, !- N321 - 6.147313595, !- N322 - 6.356653214, !- N323 - 6.571243286, !- N324 - 6.79353714, !- N325 - 7.027364731, !- N326 - 6.000426292, !- N327 - 6.202982426, !- N328 - 6.414974213, !- N329 - 6.627170086, !- N330 - 6.843828201, !- N331 - 5.867774487, !- N332 - 6.062170506, !- N333 - 6.258625507, !- N334 - 6.460041046, !- N335 - 6.663432121, !- N336 - 5.731920242, !- N337 - 5.912743092, !- N338 - 6.101835251, !- N339 - 6.29545784, !- N340 - 6.491116524, !- N341 - 5.591607571, !- N342 - 5.765592575, !- N343 - 5.942604542, !- N344 - 6.125249863, !- N345 - 6.314370632, !- N346 - 0.100000001, !- N347 - 85, !- N348 - 38.900001526, !- N349 - 7.259115219, !- N350 - 7.515392303, !- N351 - 7.789088249, !- N352 - 8.064186096, !- N353 - 8.345357895, !- N354 - 7.068078518, !- N355 - 7.315042973, !- N356 - 7.565517902, !- N357 - 7.832796097, !- N358 - 8.10390377, !- N359 - 6.904254436, !- N360 - 7.141640186, !- N361 - 7.382932663, !- N362 - 7.630719185, !- N363 - 7.883708954, !- N364 - 6.740654945, !- N365 - 6.965732098, !- N366 - 7.194357395, !- N367 - 7.430022717, !- N368 - 7.673000336, !- N369 - 6.577650547, !- N370 - 6.79330492, !- N371 - 7.014332771, !- N372 - 7.240844727, !- N373 - 7.471778393, !- N374 - 6.41513443, !- N375 - 6.616100788, !- N376 - 6.822233677, !- N377 - 7.038028717, !- N378 - 7.252334118, !- N379 - 0.199999988, !- N380 - 85, !- N381 - 38.900001526, !- N382 - 6.885031223, !- N383 - 7.129337311, !- N384 - 7.416170597, !- N385 - 7.677256107, !- N386 - 7.939831257, !- N387 - 6.708860874, !- N388 - 6.941539764, !- N389 - 7.177498817, !- N390 - 7.424939156, !- N391 - 7.677475452, !- N392 - 6.554399967, !- N393 - 6.778627872, !- N394 - 7.005578995, !- N395 - 7.239647865, !- N396 - 7.478278637, !- N397 - 6.402157784, !- N398 - 6.611999512, !- N399 - 6.824309349, !- N400 - 7.050069332, !- N401 - 7.279421806, !- N402 - 6.249315739, !- N403 - 6.454176903, !- N404 - 6.658972263, !- N405 - 6.872204304, !- N406 - 7.090047359, !- N407 - 6.102263927, !- N408 - 6.284310341, !- N409 - 6.475070953, !- N410 - 6.682870865, !- N411 - 6.88354969, !- N412 - 0.299999982, !- N413 - 85, !- N414 - 38.900001526, !- N415 - 6.557442188, !- N416 - 6.801762104, !- N417 - 7.061593533, !- N418 - 7.288024902, !- N419 - 7.55907774, !- N420 - 6.393248558, !- N421 - 6.612651825, !- N422 - 6.837590218, !- N423 - 7.073652267, !- N424 - 7.316460609, !- N425 - 6.247449875, !- N426 - 6.459414959, !- N427 - 6.676310062, !- N428 - 6.896777153, !- N429 - 7.1232934, !- N430 - 6.103424549, !- N431 - 6.304987431, !- N432 - 6.509762287, !- N433 - 6.717011452, !- N434 - 6.93437767, !- N435 - 5.959203243, !- N436 - 6.152974606, !- N437 - 6.346560478, !- N438 - 6.54888773, !- N439 - 6.755382538, !- N440 - 5.821782112, !- N441 - 5.993262768, !- N442 - 6.174466133, !- N443 - 6.36959362, !- N444 - 6.561481953, !- N445 - 0.399999976, !- N446 - 85, !- N447 - 38.900001526, !- N448 - 6.267533302, !- N449 - 6.498164654, !- N450 - 6.747991085, !- N451 - 6.986202717, !- N452 - 7.204495907, !- N453 - 6.114499092, !- N454 - 6.323793411, !- N455 - 6.537453175, !- N456 - 6.756989956, !- N457 - 6.991371632, !- N458 - 5.969236374, !- N459 - 6.177954674, !- N460 - 6.384465694, !- N461 - 6.593772888, !- N462 - 6.810007572, !- N463 - 5.838998318, !- N464 - 6.030385017, !- N465 - 6.225597858, !- N466 - 6.421393871, !- N467 - 6.62951231, !- N468 - 5.698288918, !- N469 - 5.886136532, !- N470 - 6.070774078, !- N471 - 6.263503551, !- N472 - 6.460413456, !- N473 - 5.57485199, !- N474 - 5.73515892, !- N475 - 5.912261009, !- N476 - 6.094168186, !- N477 - 6.276163101, !- N478 - 0.49999997, !- N479 - 85, !- N480 - 38.900001526, !- N481 - 6.009854317, !- N482 - 6.225393772, !- N483 - 6.449347496, !- N484 - 6.6976614, !- N485 - 6.924942493, !- N486 - 5.864756584, !- N487 - 6.06635046, !- N488 - 6.271222115, !- N489 - 6.480144978, !- N490 - 6.699311733, !- N491 - 5.726833344, !- N492 - 5.926858902, !- N493 - 6.124229431, !- N494 - 6.323792934, !- N495 - 6.531667709, !- N496 - 5.602781773, !- N497 - 5.785144329, !- N498 - 5.975097656, !- N499 - 6.165617943, !- N500 - 6.358923912, !- N501 - 5.470835686, !- N502 - 5.647620678, !- N503 - 5.824313164, !- N504 - 6.00918293, !- N505 - 6.19702673, !- N506 - 5.339015961, !- N507 - 5.503248215, !- N508 - 5.674411297, !- N509 - 5.843969345, !- N510 - 6.022156715, !- N511 - 0.599999964, !- N512 - 85, !- N513 - 38.900001526, !- N514 - 5.780550957, !- N515 - 5.989607811, !- N516 - 6.202156544, !- N517 - 6.438942909, !- N518 - 6.661171436, !- N519 - 5.642451286, !- N520 - 5.835155964, !- N521 - 6.030970097, !- N522 - 6.232661724, !- N523 - 6.439006329, !- N524 - 5.512694359, !- N525 - 5.7015028, !- N526 - 5.890693188, !- N527 - 6.082732677, !- N528 - 6.282021523, !- N529 - 5.391224384, !- N530 - 5.565419674, !- N531 - 5.74768734, !- N532 - 5.930199146, !- N533 - 6.113877773, !- N534 - 5.26409483, !- N535 - 5.43378067, !- N536 - 5.603850365, !- N537 - 5.77963686, !- N538 - 5.96075058, !- N539 - 5.135111809, !- N540 - 5.29573822, !- N541 - 5.458507061, !- N542 - 5.623476505, !- N543 - 5.794256687, !- N544 - 0.699999988, !- N545 - 85, !- N546 - 38.900001526, !- N547 - 5.573001862, !- N548 - 5.766656399, !- N549 - 5.974468231, !- N550 - 6.183267593, !- N551 - 6.418684483, !- N552 - 5.440592766, !- N553 - 5.626262188, !- N554 - 5.815647602, !- N555 - 6.008687973, !- N556 - 6.206381321, !- N557 - 5.312497616, !- N558 - 5.490357399, !- N559 - 5.679677963, !- N560 - 5.864483356, !- N561 - 6.054956913, !- N562 - 5.199712276, !- N563 - 5.366889, !- N564 - 5.541965961, !- N565 - 5.720563889, !- N566 - 5.9004035, !- N567 - 5.077210903, !- N568 - 5.24016428, !- N569 - 5.408108711, !- N570 - 5.573952198, !- N571 - 5.747310638, !- N572 - 4.953996658, !- N573 - 5.108690739, !- N574 - 5.265069485, !- N575 - 5.423257828, !- N576 - 5.587748528, !- N577 - 0.799999952, !- N578 - 85, !- N579 - 38.900001526, !- N580 - 5.385197639, !- N581 - 5.570212364, !- N582 - 5.766171932, !- N583 - 5.970887661, !- N584 - 6.20060873, !- N585 - 5.256859303, !- N586 - 5.436903, !- N587 - 5.619208813, !- N588 - 5.804953575, !- N589 - 5.996304512, !- N590 - 5.133303165, !- N591 - 5.305369854, !- N592 - 5.488326073, !- N593 - 5.666195869, !- N594 - 5.850347519, !- N595 - 5.02493763, !- N596 - 5.186417103, !- N597 - 5.355296612, !- N598 - 5.528422832, !- N599 - 5.70152998, !- N600 - 4.907347679, !- N601 - 5.064217091, !- N602 - 5.225800514, !- N603 - 5.386115551, !- N604 - 5.553591728, !- N605 - 4.788144588, !- N606 - 4.938503265, !- N607 - 5.089111328, !- N608 - 5.24377346, !- N609 - 5.40122366, !- N610 - 0.899999976, !- N611 - 85, !- N612 - 38.900001526, !- N613 - 5.205968857, !- N614 - 5.392455578, !- N615 - 5.58401823, !- N616 - 5.779130936, !- N617 - 5.977272511, !- N618 - 5.089895725, !- N619 - 5.264051437, !- N620 - 5.440124512, !- N621 - 5.620657444, !- N622 - 5.805341244, !- N623 - 4.969322681, !- N624 - 5.136226654, !- N625 - 5.313691139, !- N626 - 5.485387802, !- N627 - 5.663928986, !- N628 - 4.861190319, !- N629 - 5.022156715, !- N630 - 5.184958458, !- N631 - 5.352128506, !- N632 - 5.522233963, !- N633 - 4.751545906, !- N634 - 4.903371334, !- N635 - 5.05978632, !- N636 - 5.215235233, !- N637 - 5.377421856, !- N638 - 4.637542248, !- N639 - 4.782901764, !- N640 - 4.928544521, !- N641 - 5.077798843, !- N642 - 5.230047226, !- N643 - 0.100000001, !- N644 - 95, !- N645 - 38.900001526, !- N646 - 6.265818119, !- N647 - 6.529644012, !- N648 - 6.74444294, !- N649 - 7.022602558, !- N650 - 7.244069099, !- N651 - 6.11725235, !- N652 - 6.336417675, !- N653 - 6.559382439, !- N654 - 6.786314011, !- N655 - 7.029621124, !- N656 - 5.974964142, !- N657 - 6.186730862, !- N658 - 6.402053356, !- N659 - 6.622272491, !- N660 - 6.844865322, !- N661 - 5.833756924, !- N662 - 6.037249565, !- N663 - 6.241466999, !- N664 - 6.446889877, !- N665 - 6.662258625, !- N666 - 5.687562466, !- N667 - 5.884980679, !- N668 - 6.084312439, !- N669 - 6.286014557, !- N670 - 6.487462521, !- N671 - 5.561378956, !- N672 - 5.730063438, !- N673 - 5.912848473, !- N674 - 6.106351376, !- N675 - 6.301912308, !- N676 - 0.199999988, !- N677 - 95, !- N678 - 38.900001526, !- N679 - 5.875678539, !- N680 - 6.099098682, !- N681 - 6.348540783, !- N682 - 6.557084084, !- N683 - 6.823448658, !- N684 - 5.743342876, !- N685 - 5.948241711, !- N686 - 6.156836033, !- N687 - 6.368998528, !- N688 - 6.592295647, !- N689 - 5.61036396, !- N690 - 5.808525085, !- N691 - 6.009937763, !- N692 - 6.215979099, !- N693 - 6.424310207, !- N694 - 5.478412151, !- N695 - 5.669564247, !- N696 - 5.860869884, !- N697 - 6.052073956, !- N698 - 6.253448486, !- N699 - 5.346921444, !- N700 - 5.527234077, !- N701 - 5.713076591, !- N702 - 5.902079582, !- N703 - 6.093647003, !- N704 - 5.210948944, !- N705 - 5.379645348, !- N706 - 5.557474613, !- N707 - 5.734667301, !- N708 - 5.918112278, !- N709 - 0.299999982, !- N710 - 95, !- N711 - 38.900001526, !- N712 - 5.552942753, !- N713 - 5.750362396, !- N714 - 5.961650372, !- N715 - 6.208573341, !- N716 - 6.431177139, !- N717 - 5.423380852, !- N718 - 5.61648035, !- N719 - 5.813141823, !- N720 - 6.013071537, !- N721 - 6.226220131, !- N722 - 5.298839569, !- N723 - 5.485311985, !- N724 - 5.675266266, !- N725 - 5.86913538, !- N726 - 6.065243244, !- N727 - 5.174295425, !- N728 - 5.35513401, !- N729 - 5.537789345, !- N730 - 5.719225883, !- N731 - 5.902607441, !- N732 - 5.056111336, !- N733 - 5.221462727, !- N734 - 5.396158218, !- N735 - 5.574186325, !- N736 - 5.754336834, !- N737 - 4.921727657, !- N738 - 5.083371162, !- N739 - 5.251560211, !- N740 - 5.418694496, !- N741 - 5.593299389, !- N742 - 0.399999976, !- N743 - 95, !- N744 - 38.900001526, !- N745 - 5.269816875, !- N746 - 5.454057693, !- N747 - 5.65719986, !- N748 - 5.887099266, !- N749 - 6.074626446, !- N750 - 5.146901608, !- N751 - 5.329955101, !- N752 - 5.516353607, !- N753 - 5.705649853, !- N754 - 5.899142265, !- N755 - 5.029285431, !- N756 - 5.206041336, !- N757 - 5.385974407, !- N758 - 5.56997633, !- N759 - 5.75590992, !- N760 - 4.912029266, !- N761 - 5.082716942, !- N762 - 5.255975723, !- N763 - 5.431810856, !- N764 - 5.606380463, !- N765 - 4.799509525, !- N766 - 4.958413124, !- N767 - 5.121944427, !- N768 - 5.291065693, !- N769 - 5.462572098, !- N770 - 4.670700073, !- N771 - 4.82732296, !- N772 - 4.986678123, !- N773 - 5.145022869, !- N774 - 5.307498932, !- N775 - 0.49999997, !- N776 - 95, !- N777 - 38.900001526, !- N778 - 5.022109032, !- N779 - 5.202180862, !- N780 - 5.381332397, !- N781 - 5.578413963, !- N782 - 5.805573463, !- N783 - 4.904779434, !- N784 - 5.079360962, !- N785 - 5.257004261, !- N786 - 5.437585354, !- N787 - 5.622056007, !- N788 - 4.793041706, !- N789 - 4.961609364, !- N790 - 5.133027554, !- N791 - 5.308581352, !- N792 - 5.485919476, !- N793 - 4.681702137, !- N794 - 4.845311165, !- N795 - 5.009767056, !- N796 - 5.176888466, !- N797 - 5.343790054, !- N798 - 4.574587345, !- N799 - 4.726264954, !- N800 - 4.882099152, !- N801 - 5.043515682, !- N802 - 5.207358837, !- N803 - 4.45241642, !- N804 - 4.6048522, !- N805 - 4.755833626, !- N806 - 4.905735016, !- N807 - 5.057929039, !- N808 - 0.599999964, !- N809 - 95, !- N810 - 38.900001526, !- N811 - 4.803382397, !- N812 - 4.975688934, !- N813 - 5.146772861, !- N814 - 5.333453655, !- N815 - 5.545248985, !- N816 - 4.69110775, !- N817 - 4.858166218, !- N818 - 5.02807045, !- N819 - 5.20099926, !- N820 - 5.377251148, !- N821 - 4.580348969, !- N822 - 4.745856285, !- N823 - 4.909888268, !- N824 - 5.077527523, !- N825 - 5.247940063, !- N826 - 4.478251457, !- N827 - 4.634954453, !- N828 - 4.792548656, !- N829 - 4.952445507, !- N830 - 5.114014149, !- N831 - 4.375974178, !- N832 - 4.521392822, !- N833 - 4.670769215, !- N834 - 4.824653149, !- N835 - 4.981656551, !- N836 - 4.261509418, !- N837 - 4.406624794, !- N838 - 4.54999733, !- N839 - 4.693954945, !- N840 - 4.839537621, !- N841 - 0.699999988, !- N842 - 95, !- N843 - 38.900001526, !- N844 - 4.608055115, !- N845 - 4.773705006, !- N846 - 4.9381423, !- N847 - 5.115269184, !- N848 - 5.295624256, !- N849 - 4.500204563, !- N850 - 4.660661221, !- N851 - 4.823926926, !- N852 - 4.990267277, !- N853 - 5.159505844, !- N854 - 4.394011021, !- N855 - 4.548789501, !- N856 - 4.710763454, !- N857 - 4.872128487, !- N858 - 5.03553772, !- N859 - 4.296442509, !- N860 - 4.447676182, !- N861 - 4.598396778, !- N862 - 4.752495289, !- N863 - 4.907447338, !- N864 - 4.196975231, !- N865 - 4.33833456, !- N866 - 4.481674671, !- N867 - 4.629499912, !- N868 - 4.780550003, !- N869 - 4.090961933, !- N870 - 4.229338169, !- N871 - 4.367697716, !- N872 - 4.505301952, !- N873 - 4.644484997, !- N874 - 0.799999952, !- N875 - 95, !- N876 - 38.900001526, !- N877 - 4.432907104, !- N878 - 4.592493534, !- N879 - 4.750811577, !- N880 - 4.921542168, !- N881 - 5.090443134, !- N882 - 4.33301878, !- N883 - 4.483508587, !- N884 - 4.640776634, !- N885 - 4.801027775, !- N886 - 4.964085102, !- N887 - 4.230231762, !- N888 - 4.380027294, !- N889 - 4.527555466, !- N890 - 4.687577724, !- N891 - 4.845128536, !- N892 - 4.137532234, !- N893 - 4.278978348, !- N894 - 4.424193382, !- N895 - 4.572300434, !- N896 - 4.721938133, !- N897 - 4.034814358, !- N898 - 4.174008369, !- N899 - 4.313586235, !- N900 - 4.45443821, !- N901 - 4.599135399, !- N902 - 3.94222331, !- N903 - 4.070342541, !- N904 - 4.204514027, !- N905 - 4.33607769, !- N906 - 4.472176552, !- N907 - 0.899999976, !- N908 - 95, !- N909 - 38.900001526, !- N910 - 4.274369717, !- N911 - 4.42854166, !- N912 - 4.581320763, !- N913 - 4.741332531, !- N914 - 4.908604622, !- N915 - 4.177935123, !- N916 - 4.32322073, !- N917 - 4.475039005, !- N918 - 4.62988615, !- N919 - 4.787294865, !- N920 - 4.079145908, !- N921 - 4.22344923, !- N922 - 4.370092869, !- N923 - 4.521348476, !- N924 - 4.672896862, !- N925 - 3.985496998, !- N926 - 4.126290321, !- N927 - 4.267317772, !- N928 - 4.409982204, !- N929 - 4.554020405, !- N930 - 3.893064976, !- N931 - 4.023557186, !- N932 - 4.160269737, !- N933 - 4.295764923, !- N934 - 4.435796738, !- N935 - 3.797810793, !- N936 - 3.928039551, !- N937 - 4.052258968, !- N938 - 4.182612419, !- N939 - 4.313734531, !- N940 - 0.100000001, !- N941 - 105, !- N942 - 38.900001526, !- N943 - 5.478792667, !- N944 - 5.672461987, !- N945 - 5.883401871, !- N946 - 6.12230587, !- N947 - 6.321151257, !- N948 - 5.351415634, !- N949 - 5.541706562, !- N950 - 5.735638618, !- N951 - 5.933269024, !- N952 - 6.134923458, !- N953 - 5.228453636, !- N954 - 5.41206646, !- N955 - 5.599658012, !- N956 - 5.791125774, !- N957 - 5.986018658, !- N958 - 5.106378078, !- N959 - 5.284238815, !- N960 - 5.463829041, !- N961 - 5.64359951, !- N962 - 5.824174404, !- N963 - 4.988528252, !- N964 - 5.152242184, !- N965 - 5.324547291, !- N966 - 5.500236511, !- N967 - 5.679171562, !- N968 - 4.856426239, !- N969 - 5.016389847, !- N970 - 5.182260513, !- N971 - 5.347247124, !- N972 - 5.517039299, !- N973 - 0.199999988, !- N974 - 105, !- N975 - 38.900001526, !- N976 - 5.078141689, !- N977 - 5.260044098, !- N978 - 5.442511082, !- N979 - 5.641021252, !- N980 - 5.871208668, !- N981 - 4.959412098, !- N982 - 5.135681152, !- N983 - 5.315515518, !- N984 - 5.498252869, !- N985 - 5.684760571, !- N986 - 4.846199036, !- N987 - 5.016622066, !- N988 - 5.189938545, !- N989 - 5.367602348, !- N990 - 5.547017097, !- N991 - 4.733241558, !- N992 - 4.89837265, !- N993 - 5.064977646, !- N994 - 5.234532833, !- N995 - 5.403240681, !- N996 - 4.62523365, !- N997 - 4.778360367, !- N998 - 4.936174393, !- N999 - 5.099000454, !- N1000 - 5.264979362, !- N1001 - 4.499900341, !- N1002 - 4.654961109, !- N1003 - 4.807723522, !- N1004 - 4.959453106, !- N1005 - 5.113693714, !- N1006 - 0.299999982, !- N1007 - 105, !- N1008 - 38.900001526, !- N1009 - 4.746022224, !- N1010 - 4.916712284, !- N1011 - 5.085526466, !- N1012 - 5.269220352, !- N1013 - 5.474384308, !- N1014 - 4.634940147, !- N1015 - 4.800217628, !- N1016 - 4.968211651, !- N1017 - 5.139404774, !- N1018 - 5.313824177, !- N1019 - 4.525182724, !- N1020 - 4.689095974, !- N1021 - 4.851440907, !- N1022 - 5.017714977, !- N1023 - 5.185760975, !- N1024 - 4.424629688, !- N1025 - 4.579445839, !- N1026 - 4.73545599, !- N1027 - 4.89386034, !- N1028 - 5.053450108, !- N1029 - 4.318246841, !- N1030 - 4.467160702, !- N1031 - 4.614931583, !- N1032 - 4.767291069, !- N1033 - 4.922698021, !- N1034 - 4.215000153, !- N1035 - 4.354058743, !- N1036 - 4.496406555, !- N1037 - 4.63821888, !- N1038 - 4.782167912, !- N1039 - 0.399999976, !- N1040 - 105, !- N1041 - 38.900001526, !- N1042 - 4.465662003, !- N1043 - 4.626673222, !- N1044 - 4.786415577, !- N1045 - 4.958582878, !- N1046 - 5.129953384, !- N1047 - 4.364847183, !- N1048 - 4.516757488, !- N1049 - 4.675396919, !- N1050 - 4.837037086, !- N1051 - 5.00150013, !- N1052 - 4.261543751, !- N1053 - 4.412250519, !- N1054 - 4.565674782, !- N1055 - 4.722590446, !- N1056 - 4.881437778, !- N1057 - 4.163243294, !- N1058 - 4.310263157, !- N1059 - 4.456765652, !- N1060 - 4.606181622, !- N1061 - 4.757133484, !- N1062 - 4.066405773, !- N1063 - 4.204323769, !- N1064 - 4.345078945, !- N1065 - 4.486968994, !- N1066 - 4.633729458, !- N1067 - 3.965012312, !- N1068 - 4.098854542, !- N1069 - 4.235047817, !- N1070 - 4.366966248, !- N1071 - 4.501732826, !- N1072 - 0.49999997, !- N1073 - 105, !- N1074 - 38.900001526, !- N1075 - 4.225430012, !- N1076 - 4.37823534, !- N1077 - 4.533998013, !- N1078 - 4.688241005, !- N1079 - 4.854315758, !- N1080 - 4.129887581, !- N1081 - 4.273901939, !- N1082 - 4.424383163, !- N1083 - 4.577785015, !- N1084 - 4.733813286, !- N1085 - 4.031987667, !- N1086 - 4.175057411, !- N1087 - 4.320383072, !- N1088 - 4.468637943, !- N1089 - 4.620494843, !- N1090 - 3.939349413, !- N1091 - 4.077044964, !- N1092 - 4.21863699, !- N1093 - 4.36003685, !- N1094 - 4.504095554, !- N1095 - 3.847514629, !- N1096 - 3.977113485, !- N1097 - 4.112696171, !- N1098 - 4.246874809, !- N1099 - 4.385681629, !- N1100 - 3.754904747, !- N1101 - 3.883594513, !- N1102 - 4.005920887, !- N1103 - 4.135806561, !- N1104 - 4.265062809, !- N1105 - 0.599999964, !- N1106 - 105, !- N1107 - 38.900001526, !- N1108 - 4.016684532, !- N1109 - 4.162656784, !- N1110 - 4.311038971, !- N1111 - 4.45791769, !- N1112 - 4.616483212, !- N1113 - 3.922473907, !- N1114 - 4.066949368, !- N1115 - 4.210782528, !- N1116 - 4.352741241, !- N1117 - 4.501504421, !- N1118 - 3.838938475, !- N1119 - 3.968930006, !- N1120 - 4.107569218, !- N1121 - 4.248976231, !- N1122 - 4.392503262, !- N1123 - 3.744658709, !- N1124 - 3.875930309, !- N1125 - 4.011085987, !- N1126 - 4.146692276, !- N1127 - 4.283577919, !- N1128 - 3.653898954, !- N1129 - 3.781394243, !- N1130 - 3.910522223, !- N1131 - 4.039862633, !- N1132 - 4.170699596, !- N1133 - 3.576648712, !- N1134 - 3.69217515, !- N1135 - 3.810397863, !- N1136 - 3.934948206, !- N1137 - 4.057412148, !- N1138 - 0.699999988, !- N1139 - 105, !- N1140 - 38.900001526, !- N1141 - 3.833137274, !- N1142 - 3.972941875, !- N1143 - 4.115065098, !- N1144 - 4.255578041, !- N1145 - 4.407533646, !- N1146 - 3.742910624, !- N1147 - 3.881416559, !- N1148 - 4.019218445, !- N1149 - 4.159143448, !- N1150 - 4.297399998, !- N1151 - 3.661478519, !- N1152 - 3.787622213, !- N1153 - 3.920671463, !- N1154 - 4.055865765, !- N1155 - 4.193391323, !- N1156 - 3.577022791, !- N1157 - 3.699072123, !- N1158 - 3.828642368, !- N1159 - 3.958528042, !- N1160 - 4.089569092, !- N1161 - 3.486876965, !- N1162 - 3.609050274, !- N1163 - 3.732484341, !- N1164 - 3.856472492, !- N1165 - 3.981773853, !- N1166 - 3.413802624, !- N1167 - 3.526281357, !- N1168 - 3.640485287, !- N1169 - 3.758456469, !- N1170 - 3.875012398, !- N1171 - 0.799999952, !- N1172 - 105, !- N1173 - 38.900001526, !- N1174 - 3.670227766, !- N1175 - 3.804687262, !- N1176 - 3.941093922, !- N1177 - 4.075778008, !- N1178 - 4.221858025, !- N1179 - 3.586875916, !- N1180 - 3.713503361, !- N1181 - 3.849284172, !- N1182 - 3.983653307, !- N1183 - 4.120388985, !- N1184 - 3.505703688, !- N1185 - 3.632487059, !- N1186 - 3.75467205, !- N1187 - 3.884611607, !- N1188 - 4.016403198, !- N1189 - 3.424330235, !- N1190 - 3.542086124, !- N1191 - 3.666731834, !- N1192 - 3.7915802, !- N1193 - 3.918364763, !- N1194 - 3.338736296, !- N1195 - 3.452963352, !- N1196 - 3.573394537, !- N1197 - 3.694033861, !- N1198 - 3.814131975, !- N1199 - 3.276224613, !- N1200 - 3.379363537, !- N1201 - 3.488256216, !- N1202 - 3.600348949, !- N1203 - 3.713266134, !- N1204 - 0.899999976, !- N1205 - 105, !- N1206 - 38.900001526, !- N1207 - 3.524268627, !- N1208 - 3.653710365, !- N1209 - 3.785371542, !- N1210 - 3.919330835, !- N1211 - 4.056106091, !- N1212 - 3.443814039, !- N1213 - 3.569433212, !- N1214 - 3.693234444, !- N1215 - 3.826505184, !- N1216 - 3.958516836, !- N1217 - 3.364982843, !- N1218 - 3.48544693, !- N1219 - 3.611217976, !- N1220 - 3.730961084, !- N1221 - 3.858362436, !- N1222 - 3.287377834, !- N1223 - 3.401325941, !- N1224 - 3.521437883, !- N1225 - 3.641806602, !- N1226 - 3.764061451, !- N1227 - 3.207520008, !- N1228 - 3.316485167, !- N1229 - 3.43198061, !- N1230 - 3.548186064, !- N1231 - 3.663763523, !- N1232 - 3.149424076, !- N1233 - 3.246051311, !- N1234 - 3.355411291, !- N1235 - 3.459404469, !- N1236 - 3.568409204, !- N1237 - 0.100000001, !- N1238 - 115, !- N1239 - 38.900001526, !- N1240 - 4.795506477, !- N1241 - 4.967991829, !- N1242 - 5.139030933, !- N1243 - 5.325824738, !- N1244 - 5.537942886, !- N1245 - 4.682466507, !- N1246 - 4.850346565, !- N1247 - 5.020451069, !- N1248 - 5.19331646, !- N1249 - 5.369692326, !- N1250 - 4.571524143, !- N1251 - 4.73725605, !- N1252 - 4.902056694, !- N1253 - 5.069809437, !- N1254 - 5.240264416, !- N1255 - 4.469242573, !- N1256 - 4.626205444, !- N1257 - 4.784678459, !- N1258 - 4.944638729, !- N1259 - 5.106239319, !- N1260 - 4.367332458, !- N1261 - 4.512448311, !- N1262 - 4.662125587, !- N1263 - 4.816768646, !- N1264 - 4.973769665, !- N1265 - 4.252896786, !- N1266 - 4.39799118, !- N1267 - 4.542633533, !- N1268 - 4.68547678, !- N1269 - 4.831119537, !- N1270 - 0.199999988, !- N1271 - 115, !- N1272 - 38.900001526, !- N1273 - 4.379165173, !- N1274 - 4.537815094, !- N1275 - 4.694672585, !- N1276 - 4.863941669, !- N1277 - 5.030898571, !- N1278 - 4.279997349, !- N1279 - 4.429395199, !- N1280 - 4.585656643, !- N1281 - 4.744600773, !- N1282 - 4.906162739, !- N1283 - 4.178440094, !- N1284 - 4.326724529, !- N1285 - 4.47728157, !- N1286 - 4.632334709, !- N1287 - 4.788365364, !- N1288 - 4.082480907, !- N1289 - 4.226610661, !- N1290 - 4.370663643, !- N1291 - 4.517953873, !- N1292 - 4.666257381, !- N1293 - 3.987135887, !- N1294 - 4.12247324, !- N1295 - 4.261363029, !- N1296 - 4.400531769, !- N1297 - 4.544614315, !- N1298 - 3.889457464, !- N1299 - 4.02077961, !- N1300 - 4.148842812, !- N1301 - 4.284040451, !- N1302 - 4.418254375, !- N1303 - 0.299999982, !- N1304 - 115, !- N1305 - 38.900001526, !- N1306 - 4.046626568, !- N1307 - 4.193892479, !- N1308 - 4.343548298, !- N1309 - 4.491932392, !- N1310 - 4.651689529, !- N1311 - 3.95154953, !- N1312 - 4.097333431, !- N1313 - 4.242412567, !- N1314 - 4.385854721, !- N1315 - 4.535798073, !- N1316 - 3.867507219, !- N1317 - 3.998401403, !- N1318 - 4.138268948, !- N1319 - 4.280905724, !- N1320 - 4.427577496, !- N1321 - 3.77234149, !- N1322 - 3.904481888, !- N1323 - 4.040813923, !- N1324 - 4.176886559, !- N1325 - 4.315496922, !- N1326 - 3.680396795, !- N1327 - 3.809316635, !- N1328 - 3.93926096, !- N1329 - 4.069732666, !- N1330 - 4.201843739, !- N1331 - 3.602622032, !- N1332 - 3.718833685, !- N1333 - 3.838255882, !- N1334 - 3.963798761, !- N1335 - 4.087574482, !- N1336 - 0.399999976, !- N1337 - 115, !- N1338 - 38.900001526, !- N1339 - 3.773223162, !- N1340 - 3.911310434, !- N1341 - 4.051672935, !- N1342 - 4.19040966, !- N1343 - 4.340476513, !- N1344 - 3.684253693, !- N1345 - 3.817579508, !- N1346 - 3.957106829, !- N1347 - 4.095319748, !- N1348 - 4.236000538, !- N1349 - 3.604022503, !- N1350 - 3.733906269, !- N1351 - 3.859795809, !- N1352 - 3.993319273, !- N1353 - 4.129092216, !- N1354 - 3.520467758, !- N1355 - 3.641252518, !- N1356 - 3.769021749, !- N1357 - 3.897285938, !- N1358 - 4.0268116, !- N1359 - 3.432062864, !- N1360 - 3.552544355, !- N1361 - 3.674516439, !- N1362 - 3.79695344, !- N1363 - 3.920437813, !- N1364 - 3.36199379, !- N1365 - 3.47157979, !- N1366 - 3.583178043, !- N1367 - 3.699356556, !- N1368 - 3.815665007, !- N1369 - 0.49999997, !- N1370 - 115, !- N1371 - 38.900001526, !- N1372 - 3.543877363, !- N1373 - 3.674151182, !- N1374 - 3.806744576, !- N1375 - 3.941725731, !- N1376 - 4.079491615, !- N1377 - 3.462814331, !- N1378 - 3.585751772, !- N1379 - 3.714024544, !- N1380 - 3.848193169, !- N1381 - 3.981164455, !- N1382 - 3.383302927, !- N1383 - 3.504762411, !- N1384 - 3.631300211, !- N1385 - 3.751971722, !- N1386 - 3.880251408, !- N1387 - 3.305186987, !- N1388 - 3.41962719, !- N1389 - 3.540932417, !- N1390 - 3.662034273, !- N1391 - 3.785277605, !- N1392 - 3.225223541, !- N1393 - 3.337544203, !- N1394 - 3.450650454, !- N1395 - 3.567762852, !- N1396 - 3.68524456, !- N1397 - 3.164888382, !- N1398 - 3.264980793, !- N1399 - 3.370674133, !- N1400 - 3.477819204, !- N1401 - 3.587766171, !- N1402 - 0.599999964, !- N1403 - 115, !- N1404 - 38.900001526, !- N1405 - 3.347181559, !- N1406 - 3.471241713, !- N1407 - 3.597339869, !- N1408 - 3.725689173, !- N1409 - 3.852596998, !- N1410 - 3.273642063, !- N1411 - 3.390737295, !- N1412 - 3.512812138, !- N1413 - 3.636956692, !- N1414 - 3.763408184, !- N1415 - 3.195384979, !- N1416 - 3.310755253, !- N1417 - 3.4281075, !- N1418 - 3.550463915, !- N1419 - 3.667455912, !- N1420 - 3.121171951, !- N1421 - 3.230427027, !- N1422 - 3.345760345, !- N1423 - 3.460776329, !- N1424 - 3.574449539, !- N1425 - 3.045976877, !- N1426 - 3.154997826, !- N1427 - 3.25771904, !- N1428 - 3.370491505, !- N1429 - 3.48341012, !- N1430 - 3.000915051, !- N1431 - 3.09926343, !- N1432 - 3.186673403, !- N1433 - 3.288674355, !- N1434 - 3.392398119, !- N1435 - 0.699999988, !- N1436 - 115, !- N1437 - 38.900001526, !- N1438 - 3.176667452, !- N1439 - 3.295194387, !- N1440 - 3.415434122, !- N1441 - 3.537672758, !- N1442 - 3.658605337, !- N1443 - 3.106608629, !- N1444 - 3.218400002, !- N1445 - 3.335004568, !- N1446 - 3.453538418, !- N1447 - 3.57403183, !- N1448 - 3.032178879, !- N1449 - 3.142996073, !- N1450 - 3.254061699, !- N1451 - 3.368885279, !- N1452 - 3.486968756, !- N1453 - 2.961471796, !- N1454 - 3.065936804, !- N1455 - 3.176185846, !- N1456 - 3.28625679, !- N1457 - 3.394574881, !- N1458 - 2.890764713, !- N1459 - 2.99669385, !- N1460 - 3.093227386, !- N1461 - 3.196953773, !- N1462 - 3.308069468, !- N1463 - 2.855482101, !- N1464 - 2.945691824, !- N1465 - 3.036231041, !- N1466 - 3.124284029, !- N1467 - 3.226423979, !- N1468 - 0.799999952, !- N1469 - 115, !- N1470 - 38.900001526, !- N1471 - 3.026700258, !- N1472 - 3.140242815, !- N1473 - 3.255634069, !- N1474 - 3.373034, !- N1475 - 3.492646456, !- N1476 - 2.959598303, !- N1477 - 3.066935539, !- N1478 - 3.178555489, !- N1479 - 3.292290688, !- N1480 - 3.407998323, !- N1481 - 2.88924408, !- N1482 - 2.99483943, !- N1483 - 3.10266614, !- N1484 - 3.213477373, !- N1485 - 3.321787357, !- N1486 - 2.821158648, !- N1487 - 2.921641588, !- N1488 - 3.025346041, !- N1489 - 3.132569313, !- N1490 - 3.23631072, !- N1491 - 2.755269766, !- N1492 - 2.85426116, !- N1493 - 2.950181723, !- N1494 - 3.048103809, !- N1495 - 3.152718306, !- N1496 - 2.724778652, !- N1497 - 2.813699484, !- N1498 - 2.899749756, !- N1499 - 2.986849308, !- N1500 - 3.077438831, !- N1501 - 0.899999976, !- N1502 - 115, !- N1503 - 38.900001526, !- N1504 - 2.896623611, !- N1505 - 3.003277779, !- N1506 - 3.114252567, !- N1507 - 3.227175713, !- N1508 - 3.342195511, !- N1509 - 2.827304125, !- N1510 - 2.932736158, !- N1511 - 3.040383101, !- N1512 - 3.149653912, !- N1513 - 3.260942221, !- N1514 - 2.764928102, !- N1515 - 2.866711378, !- N1516 - 2.967506886, !- N1517 - 3.074157715, !- N1518 - 3.181578398, !- N1519 - 2.697119474, !- N1520 - 2.793930292, !- N1521 - 2.893359184, !- N1522 - 2.996702909, !- N1523 - 3.09642005, !- N1524 - 2.634537935, !- N1525 - 2.72969985, !- N1526 - 2.823709965, !- N1527 - 2.91713047, !- N1528 - 3.013827324, !- N1529 - 2.611109972, !- N1530 - 2.696688414, !- N1531 - 2.782607079, !- N1532 - 2.863797903, !- N1533 - 2.951459169, !- N1534 - 0.100000001, !- N1535 - 75, !- N1536 - 58.299999237, !- N1537 - 6.614890575, !- N1538 - 6.810268402, !- N1539 - 7.013449669, !- N1540 - 7.250644684, !- N1541 - 7.463451862, !- N1542 - 6.46959734, !- N1543 - 6.658178806, !- N1544 - 6.849824429, !- N1545 - 7.052212715, !- N1546 - 7.253409386, !- N1547 - 6.344264507, !- N1548 - 6.522658348, !- N1549 - 6.708246231, !- N1550 - 6.89793396, !- N1551 - 7.091972828, !- N1552 - 6.212648392, !- N1553 - 6.387226105, !- N1554 - 6.561947823, !- N1555 - 6.744252205, !- N1556 - 6.930411816, !- N1557 - 6.090908051, !- N1558 - 6.256607056, !- N1559 - 6.426496983, !- N1560 - 6.596893787, !- N1561 - 6.773152351, !- N1562 - 5.977621078, !- N1563 - 6.121460438, !- N1564 - 6.280433655, !- N1565 - 6.443144321, !- N1566 - 6.608690739, !- N1567 - 0.199999988, !- N1568 - 75, !- N1569 - 58.299999237, !- N1570 - 6.437195778, !- N1571 - 6.625999451, !- N1572 - 6.845403194, !- N1573 - 7.047512531, !- N1574 - 7.252279758, !- N1575 - 6.300640583, !- N1576 - 6.481092453, !- N1577 - 6.666503429, !- N1578 - 6.854986668, !- N1579 - 7.052266121, !- N1580 - 6.177239418, !- N1581 - 6.351890087, !- N1582 - 6.529346466, !- N1583 - 6.714089394, !- N1584 - 6.898213387, !- N1585 - 6.056131363, !- N1586 - 6.220650673, !- N1587 - 6.389541149, !- N1588 - 6.564785957, !- N1589 - 6.743075371, !- N1590 - 5.935261726, !- N1591 - 6.095316887, !- N1592 - 6.258352757, !- N1593 - 6.42339325, !- N1594 - 6.593661785, !- N1595 - 5.827745914, !- N1596 - 5.964964867, !- N1597 - 6.115698338, !- N1598 - 6.275013924, !- N1599 - 6.434765339, !- N1600 - 0.299999982, !- N1601 - 75, !- N1602 - 58.299999237, !- N1603 - 6.272996902, !- N1604 - 6.456026077, !- N1605 - 6.665751934, !- N1606 - 6.861422062, !- N1607 - 7.05819273, !- N1608 - 6.140730858, !- N1609 - 6.315301895, !- N1610 - 6.493605614, !- N1611 - 6.675853252, !- N1612 - 6.864450455, !- N1613 - 6.023365498, !- N1614 - 6.190094471, !- N1615 - 6.362260342, !- N1616 - 6.538141727, !- N1617 - 6.716826439, !- N1618 - 5.904573917, !- N1619 - 6.06146574, !- N1620 - 6.226971149, !- N1621 - 6.395552158, !- N1622 - 6.567961693, !- N1623 - 5.788144112, !- N1624 - 5.942730427, !- N1625 - 6.099964619, !- N1626 - 6.260389328, !- N1627 - 6.424003601, !- N1628 - 5.67568779, !- N1629 - 5.817724228, !- N1630 - 5.965429306, !- N1631 - 6.116866589, !- N1632 - 6.271291256, !- N1633 - 0.399999976, !- N1634 - 75, !- N1635 - 58.299999237, !- N1636 - 6.115934372, !- N1637 - 6.296797276, !- N1638 - 6.497159004, !- N1639 - 6.683243275, !- N1640 - 6.876799107, !- N1641 - 5.9902668, !- N1642 - 6.159377098, !- N1643 - 6.33133173, !- N1644 - 6.50703764, !- N1645 - 6.690601349, !- N1646 - 5.876889229, !- N1647 - 6.039663792, !- N1648 - 6.204627037, !- N1649 - 6.374321461, !- N1650 - 6.547197819, !- N1651 - 5.761773109, !- N1652 - 5.917528152, !- N1653 - 6.073550701, !- N1654 - 6.236245155, !- N1655 - 6.402959824, !- N1656 - 5.649316311, !- N1657 - 5.799838066, !- N1658 - 5.951397419, !- N1659 - 6.106398582, !- N1660 - 6.26442337, !- N1661 - 5.540472031, !- N1662 - 5.678174019, !- N1663 - 5.821099758, !- N1664 - 5.967467308, !- N1665 - 6.118630886, !- N1666 - 0.49999997, !- N1667 - 75, !- N1668 - 58.299999237, !- N1669 - 5.964260578, !- N1670 - 6.143978596, !- N1671 - 6.323215485, !- N1672 - 6.5181427, !- N1673 - 6.702101231, !- N1674 - 5.848473549, !- N1675 - 6.012340069, !- N1676 - 6.179885387, !- N1677 - 6.349714279, !- N1678 - 6.528713226, !- N1679 - 5.736573219, !- N1680 - 5.896039486, !- N1681 - 6.057255745, !- N1682 - 6.221218109, !- N1683 - 6.388646603, !- N1684 - 5.627822399, !- N1685 - 5.779146671, !- N1686 - 5.929581165, !- N1687 - 6.088517666, !- N1688 - 6.249155045, !- N1689 - 5.517734528, !- N1690 - 5.662953377, !- N1691 - 5.810193539, !- N1692 - 5.961737156, !- N1693 - 6.115994453, !- N1694 - 5.413061142, !- N1695 - 5.546539783, !- N1696 - 5.685180187, !- N1697 - 5.826014519, !- N1698 - 5.973212242, !- N1699 - 0.599999964, !- N1700 - 75, !- N1701 - 58.299999237, !- N1702 - 5.827105999, !- N1703 - 5.996510983, !- N1704 - 6.171720982, !- N1705 - 6.363539696, !- N1706 - 6.541901112, !- N1707 - 5.714367867, !- N1708 - 5.87405014, !- N1709 - 6.035767555, !- N1710 - 6.199849606, !- N1711 - 6.365886211, !- N1712 - 5.607739449, !- N1713 - 5.761077404, !- N1714 - 5.916110516, !- N1715 - 6.075847626, !- N1716 - 6.237580776, !- N1717 - 5.500931263, !- N1718 - 5.646841049, !- N1719 - 5.792086601, !- N1720 - 5.946479797, !- N1721 - 6.102530003, !- N1722 - 5.393327713, !- N1723 - 5.53463459, !- N1724 - 5.678385258, !- N1725 - 5.824723721, !- N1726 - 5.972952843, !- N1727 - 5.287734985, !- N1728 - 5.422757626, !- N1729 - 5.557792664, !- N1730 - 5.694126129, !- N1731 - 5.837879658, !- N1732 - 0.699999988, !- N1733 - 75, !- N1734 - 58.299999237, !- N1735 - 5.697559834, !- N1736 - 5.863407612, !- N1737 - 6.032904625, !- N1738 - 6.219405651, !- N1739 - 6.391744614, !- N1740 - 5.58830595, !- N1741 - 5.743122101, !- N1742 - 5.900133133, !- N1743 - 6.059448242, !- N1744 - 6.220281124, !- N1745 - 5.484051704, !- N1746 - 5.633965492, !- N1747 - 5.78500843, !- N1748 - 5.938997746, !- N1749 - 6.096254826, !- N1750 - 5.379985809, !- N1751 - 5.522183418, !- N1752 - 5.667860031, !- N1753 - 5.813575268, !- N1754 - 5.963943481, !- N1755 - 5.275744915, !- N1756 - 5.413354397, !- N1757 - 5.553740501, !- N1758 - 5.695723057, !- N1759 - 5.840014458, !- N1760 - 5.173496246, !- N1761 - 5.304619789, !- N1762 - 5.436291695, !- N1763 - 5.569237709, !- N1764 - 5.707314014, !- N1765 - 0.799999952, !- N1766 - 75, !- N1767 - 58.299999237, !- N1768 - 5.576480865, !- N1769 - 5.751817226, !- N1770 - 5.898470879, !- N1771 - 6.064816952, !- N1772 - 6.249140263, !- N1773 - 5.469569683, !- N1774 - 5.62063694, !- N1775 - 5.772529125, !- N1776 - 5.926271439, !- N1777 - 6.083116531, !- N1778 - 5.367290497, !- N1779 - 5.512750149, !- N1780 - 5.661391258, !- N1781 - 5.810192108, !- N1782 - 5.962996006, !- N1783 - 5.26732111, !- N1784 - 5.405645847, !- N1785 - 5.546125412, !- N1786 - 5.687580109, !- N1787 - 5.835635662, !- N1788 - 5.165346146, !- N1789 - 5.298895836, !- N1790 - 5.435143471, !- N1791 - 5.572319031, !- N1792 - 5.714118958, !- N1793 - 5.069275856, !- N1794 - 5.193670273, !- N1795 - 5.322333813, !- N1796 - 5.450856686, !- N1797 - 5.586402893, !- N1798 - 0.899999976, !- N1799 - 75, !- N1800 - 58.299999237, !- N1801 - 5.459722996, !- N1802 - 5.611019611, !- N1803 - 5.773139954, !- N1804 - 5.933947563, !- N1805 - 6.114164829, !- N1806 - 5.355599403, !- N1807 - 5.503640175, !- N1808 - 5.651360989, !- N1809 - 5.802900314, !- N1810 - 5.954594135, !- N1811 - 5.257732391, !- N1812 - 5.399222851, !- N1813 - 5.543371201, !- N1814 - 5.6875844, !- N1815 - 5.837213039, !- N1816 - 5.15892601, !- N1817 - 5.293806076, !- N1818 - 5.432742596, !- N1819 - 5.572489738, !- N1820 - 5.713088989, !- N1821 - 5.059987068, !- N1822 - 5.190657139, !- N1823 - 5.32484293, !- N1824 - 5.458418369, !- N1825 - 5.595515251, !- N1826 - 4.966988564, !- N1827 - 5.089081764, !- N1828 - 5.214026928, !- N1829 - 5.341033459, !- N1830 - 5.470568657, !- N1831 - 0.100000001, !- N1832 - 85, !- N1833 - 58.299999237, !- N1834 - 6.035402775, !- N1835 - 6.215676785, !- N1836 - 6.399796963, !- N1837 - 6.579901218, !- N1838 - 6.791829109, !- N1839 - 5.919128418, !- N1840 - 6.085827827, !- N1841 - 6.255727768, !- N1842 - 6.427909851, !- N1843 - 6.605566978, !- N1844 - 5.805907726, !- N1845 - 5.967883587, !- N1846 - 6.129475117, !- N1847 - 6.297213554, !- N1848 - 6.467256069, !- N1849 - 5.690873146, !- N1850 - 5.848649025, !- N1851 - 6.003612041, !- N1852 - 6.162600994, !- N1853 - 6.326006413, !- N1854 - 5.583977222, !- N1855 - 5.730550289, !- N1856 - 5.881637096, !- N1857 - 6.034423351, !- N1858 - 6.190331936, !- N1859 - 5.47699213, !- N1860 - 5.613017082, !- N1861 - 5.75585413, !- N1862 - 5.898340225, !- N1863 - 6.046777725, !- N1864 - 0.199999988, !- N1865 - 85, !- N1866 - 58.299999237, !- N1867 - 5.821050167, !- N1868 - 5.989904404, !- N1869 - 6.163610935, !- N1870 - 6.338941097, !- N1871 - 6.516568184, !- N1872 - 5.710094929, !- N1873 - 5.87045002, !- N1874 - 6.033119202, !- N1875 - 6.196250916, !- N1876 - 6.364649296, !- N1877 - 5.602632999, !- N1878 - 5.757025242, !- N1879 - 5.912101746, !- N1880 - 6.070334911, !- N1881 - 6.232855797, !- N1882 - 5.497219563, !- N1883 - 5.642930031, !- N1884 - 5.789280415, !- N1885 - 5.942960262, !- N1886 - 6.099105835, !- N1887 - 5.390059471, !- N1888 - 5.531700134, !- N1889 - 5.675274849, !- N1890 - 5.821051598, !- N1891 - 5.970066071, !- N1892 - 5.288182259, !- N1893 - 5.418835163, !- N1894 - 5.555021286, !- N1895 - 5.691256523, !- N1896 - 5.833468437, !- N1897 - 0.299999982, !- N1898 - 85, !- N1899 - 58.299999237, !- N1900 - 5.626654625, !- N1901 - 5.782708645, !- N1902 - 5.950288773, !- N1903 - 6.120654106, !- N1904 - 6.286509037, !- N1905 - 5.519384861, !- N1906 - 5.671489716, !- N1907 - 5.827038765, !- N1908 - 5.983567238, !- N1909 - 6.144618034, !- N1910 - 5.415048599, !- N1911 - 5.563240528, !- N1912 - 5.713195324, !- N1913 - 5.865626335, !- N1914 - 6.017868042, !- N1915 - 5.314382076, !- N1916 - 5.455280781, !- N1917 - 5.59935379, !- N1918 - 5.741503716, !- N1919 - 5.890703678, !- N1920 - 5.213568211, !- N1921 - 5.347342968, !- N1922 - 5.485461235, !- N1923 - 5.62668705, !- N1924 - 5.768281937, !- N1925 - 5.115583897, !- N1926 - 5.241176128, !- N1927 - 5.370445728, !- N1928 - 5.504060745, !- N1929 - 5.637518406, !- N1930 - 0.399999976, !- N1931 - 85, !- N1932 - 58.299999237, !- N1933 - 5.441658497, !- N1934 - 5.597455978, !- N1935 - 5.753883362, !- N1936 - 5.915019989, !- N1937 - 6.077554226, !- N1938 - 5.342590809, !- N1939 - 5.488831997, !- N1940 - 5.638632774, !- N1941 - 5.790908337, !- N1942 - 5.943113804, !- N1943 - 5.243341446, !- N1944 - 5.386150837, !- N1945 - 5.529651642, !- N1946 - 5.675825596, !- N1947 - 5.822843075, !- N1948 - 5.145504475, !- N1949 - 5.282684803, !- N1950 - 5.419732094, !- N1951 - 5.559288025, !- N1952 - 5.699913502, !- N1953 - 5.049658298, !- N1954 - 5.178739071, !- N1955 - 5.311344147, !- N1956 - 5.445790768, !- N1957 - 5.582251549, !- N1958 - 4.954899788, !- N1959 - 5.076574802, !- N1960 - 5.202059269, !- N1961 - 5.32981348, !- N1962 - 5.458990574, !- N1963 - 0.49999997, !- N1964 - 85, !- N1965 - 58.299999237, !- N1966 - 5.270390034, !- N1967 - 5.425292492, !- N1968 - 5.59109211, !- N1969 - 5.728784561, !- N1970 - 5.888763905, !- N1971 - 5.17994833, !- N1972 - 5.321340084, !- N1973 - 5.465774536, !- N1974 - 5.612274647, !- N1975 - 5.759010792, !- N1976 - 5.084234238, !- N1977 - 5.223321438, !- N1978 - 5.360546589, !- N1979 - 5.501731873, !- N1980 - 5.642362118, !- N1981 - 4.991046906, !- N1982 - 5.122609138, !- N1983 - 5.256457806, !- N1984 - 5.389475346, !- N1985 - 5.524308681, !- N1986 - 4.898374557, !- N1987 - 5.02261734, !- N1988 - 5.150495529, !- N1989 - 5.280981064, !- N1990 - 5.412129402, !- N1991 - 4.80510807, !- N1992 - 4.924659252, !- N1993 - 5.045931816, !- N1994 - 5.167368889, !- N1995 - 5.2934618, !- N1996 - 0.599999964, !- N1997 - 85, !- N1998 - 58.299999237, !- N1999 - 5.118095875, !- N2000 - 5.261785507, !- N2001 - 5.407487392, !- N2002 - 5.575722694, !- N2003 - 5.709294319, !- N2004 - 5.030347347, !- N2005 - 5.166612148, !- N2006 - 5.304997921, !- N2007 - 5.447424412, !- N2008 - 5.586746216, !- N2009 - 4.938645363, !- N2010 - 5.071573257, !- N2011 - 5.205302238, !- N2012 - 5.340401173, !- N2013 - 5.476398945, !- N2014 - 4.846477985, !- N2015 - 4.975328922, !- N2016 - 5.101285934, !- N2017 - 5.233515263, !- N2018 - 5.365790844, !- N2019 - 4.757647991, !- N2020 - 4.87944603, !- N2021 - 5.003041744, !- N2022 - 5.128049374, !- N2023 - 5.254741192, !- N2024 - 4.67312336, !- N2025 - 4.784769535, !- N2026 - 4.902111053, !- N2027 - 5.02056694, !- N2028 - 5.141088486, !- N2029 - 0.699999988, !- N2030 - 85, !- N2031 - 58.299999237, !- N2032 - 4.975697041, !- N2033 - 5.11336422, !- N2034 - 5.256854534, !- N2035 - 5.415294647, !- N2036 - 5.556859016, !- N2037 - 4.891887188, !- N2038 - 5.023264408, !- N2039 - 5.158555984, !- N2040 - 5.293369293, !- N2041 - 5.429458141, !- N2042 - 4.802292824, !- N2043 - 4.930915356, !- N2044 - 5.061599255, !- N2045 - 5.191950798, !- N2046 - 5.322807312, !- N2047 - 4.715676785, !- N2048 - 4.837822437, !- N2049 - 4.96146965, !- N2050 - 5.089176178, !- N2051 - 5.216177464, !- N2052 - 4.627378464, !- N2053 - 4.745872021, !- N2054 - 4.864442825, !- N2055 - 4.985915661, !- N2056 - 5.108726978, !- N2057 - 4.542742252, !- N2058 - 4.654483795, !- N2059 - 4.76789093, !- N2060 - 4.883265495, !- N2061 - 4.999247551, !- N2062 - 0.799999952, !- N2063 - 85, !- N2064 - 58.299999237, !- N2065 - 4.845118999, !- N2066 - 4.977121353, !- N2067 - 5.114276886, !- N2068 - 5.252412319, !- N2069 - 5.40933609, !- N2070 - 4.76287365, !- N2071 - 4.891179562, !- N2072 - 5.02177906, !- N2073 - 5.151800156, !- N2074 - 5.284872532, !- N2075 - 4.675914764, !- N2076 - 4.802259922, !- N2077 - 4.927602291, !- N2078 - 5.053623676, !- N2079 - 5.180578232, !- N2080 - 4.591048241, !- N2081 - 4.71054697, !- N2082 - 4.83143425, !- N2083 - 4.953225136, !- N2084 - 5.077535629, !- N2085 - 4.50705862, !- N2086 - 4.621417046, !- N2087 - 4.737654686, !- N2088 - 4.85451889, !- N2089 - 4.974004269, !- N2090 - 4.423262119, !- N2091 - 4.533410549, !- N2092 - 4.644570351, !- N2093 - 4.754851818, !- N2094 - 4.866945267, !- N2095 - 0.899999976, !- N2096 - 85, !- N2097 - 58.299999237, !- N2098 - 4.722049713, !- N2099 - 4.85033226, !- N2100 - 4.980817318, !- N2101 - 5.118879795, !- N2102 - 5.254069805, !- N2103 - 4.642199039, !- N2104 - 4.767061234, !- N2105 - 4.893881798, !- N2106 - 5.021631241, !- N2107 - 5.148960114, !- N2108 - 4.557866573, !- N2109 - 4.680134773, !- N2110 - 4.802395821, !- N2111 - 4.924877167, !- N2112 - 5.049587727, !- N2113 - 4.475465298, !- N2114 - 4.59236145, !- N2115 - 4.709136486, !- N2116 - 4.827679157, !- N2117 - 4.948237419, !- N2118 - 4.39392519, !- N2119 - 4.506555557, !- N2120 - 4.618322849, !- N2121 - 4.731986046, !- N2122 - 4.847842693, !- N2123 - 4.313993931, !- N2124 - 4.420815468, !- N2125 - 4.528480053, !- N2126 - 4.636391163, !- N2127 - 4.746408939, !- N2128 - 0.100000001, !- N2129 - 95, !- N2130 - 58.299999237, !- N2131 - 5.487927914, !- N2132 - 5.642860413, !- N2133 - 5.798964977, !- N2134 - 5.960851669, !- N2135 - 6.149898529, !- N2136 - 5.388586044, !- N2137 - 5.537911892, !- N2138 - 5.690798759, !- N2139 - 5.844200134, !- N2140 - 5.99945879, !- N2141 - 5.287981987, !- N2142 - 5.431830883, !- N2143 - 5.577692986, !- N2144 - 5.730578423, !- N2145 - 5.884419441, !- N2146 - 5.193953514, !- N2147 - 5.331958294, !- N2148 - 5.471730709, !- N2149 - 5.611553192, !- N2150 - 5.75773716, !- N2151 - 5.094443798, !- N2152 - 5.227858067, !- N2153 - 5.363395214, !- N2154 - 5.499602795, !- N2155 - 5.638093948, !- N2156 - 4.999321938, !- N2157 - 5.123147964, !- N2158 - 5.250985146, !- N2159 - 5.381668568, !- N2160 - 5.512525082, !- N2161 - 0.199999988, !- N2162 - 95, !- N2163 - 58.299999237, !- N2164 - 5.232323647, !- N2165 - 5.382132053, !- N2166 - 5.52832365, !- N2167 - 5.679924488, !- N2168 - 5.852448463, !- N2169 - 5.141625404, !- N2170 - 5.282531261, !- N2171 - 5.427262783, !- N2172 - 5.572304249, !- N2173 - 5.718806744, !- N2174 - 5.045829296, !- N2175 - 5.18253088, !- N2176 - 5.320215225, !- N2177 - 5.459527493, !- N2178 - 5.610488415, !- N2179 - 4.955916405, !- N2180 - 5.088325977, !- N2181 - 5.221038342, !- N2182 - 5.355476856, !- N2183 - 5.489861488, !- N2184 - 4.863385201, !- N2185 - 4.990301132, !- N2186 - 5.118272781, !- N2187 - 5.247378349, !- N2188 - 5.381688595, !- N2189 - 4.774666786, !- N2190 - 4.892100334, !- N2191 - 5.013357639, !- N2192 - 5.137402534, !- N2193 - 5.260118008, !- N2194 - 0.299999982, !- N2195 - 95, !- N2196 - 58.299999237, !- N2197 - 5.007820129, !- N2198 - 5.14894104, !- N2199 - 5.28978014, !- N2200 - 5.429224968, !- N2201 - 5.57609129, !- N2202 - 4.92141819, !- N2203 - 5.055762768, !- N2204 - 5.191711903, !- N2205 - 5.330193996, !- N2206 - 5.469635487, !- N2207 - 4.83084631, !- N2208 - 4.960540295, !- N2209 - 5.091709137, !- N2210 - 5.228606224, !- N2211 - 5.366895676, !- N2212 - 4.745734215, !- N2213 - 4.871196747, !- N2214 - 4.998585701, !- N2215 - 5.125581264, !- N2216 - 5.252283096, !- N2217 - 4.653966904, !- N2218 - 4.778232098, !- N2219 - 4.900776386, !- N2220 - 5.023360729, !- N2221 - 5.148485661, !- N2222 - 4.574736118, !- N2223 - 4.686445236, !- N2224 - 4.802161694, !- N2225 - 4.919339657, !- N2226 - 5.036231995, !- N2227 - 0.399999976, !- N2228 - 95, !- N2229 - 58.299999237, !- N2230 - 4.807190418, !- N2231 - 4.941989899, !- N2232 - 5.076850891, !- N2233 - 5.20963192, !- N2234 - 5.346198559, !- N2235 - 4.724722862, !- N2236 - 4.853143215, !- N2237 - 4.982690811, !- N2238 - 5.115265369, !- N2239 - 5.24660778, !- N2240 - 4.638192654, !- N2241 - 4.762283802, !- N2242 - 4.887605667, !- N2243 - 5.018881321, !- N2244 - 5.147677898, !- N2245 - 4.557390213, !- N2246 - 4.677456379, !- N2247 - 4.79918766, !- N2248 - 4.921954632, !- N2249 - 5.044197083, !- N2250 - 4.470071793, !- N2251 - 4.588573456, !- N2252 - 4.705975056, !- N2253 - 4.823027134, !- N2254 - 4.944842815, !- N2255 - 4.391927242, !- N2256 - 4.502099991, !- N2257 - 4.612606525, !- N2258 - 4.724680901, !- N2259 - 4.838133812, !- N2260 - 0.49999997, !- N2261 - 95, !- N2262 - 58.299999237, !- N2263 - 4.626783371, !- N2264 - 4.75610733, !- N2265 - 4.885150909, !- N2266 - 5.012045383, !- N2267 - 5.142550945, !- N2268 - 4.547863483, !- N2269 - 4.6708951, !- N2270 - 4.795166492, !- N2271 - 4.921880722, !- N2272 - 5.047430038, !- N2273 - 4.464698315, !- N2274 - 4.583920956, !- N2275 - 4.703958988, !- N2276 - 4.829933643, !- N2277 - 4.953141689, !- N2278 - 4.383663177, !- N2279 - 4.502892017, !- N2280 - 4.619640827, !- N2281 - 4.737299919, !- N2282 - 4.855941296, !- N2283 - 4.304298401, !- N2284 - 4.414020538, !- N2285 - 4.530632496, !- N2286 - 4.643774986, !- N2287 - 4.757191658, !- N2288 - 4.229625702, !- N2289 - 4.335733891, !- N2290 - 4.442311764, !- N2291 - 4.549467564, !- N2292 - 4.658334255, !- N2293 - 0.599999964, !- N2294 - 95, !- N2295 - 58.299999237, !- N2296 - 4.463489532, !- N2297 - 4.588046074, !- N2298 - 4.712088108, !- N2299 - 4.833668232, !- N2300 - 4.957357407, !- N2301 - 4.387747765, !- N2302 - 4.506156445, !- N2303 - 4.625563145, !- N2304 - 4.74734211, !- N2305 - 4.867711544, !- N2306 - 4.307724476, !- N2307 - 4.42257309, !- N2308 - 4.537991524, !- N2309 - 4.659260273, !- N2310 - 4.77755022, !- N2311 - 4.230091095, !- N2312 - 4.345058918, !- N2313 - 4.45698595, !- N2314 - 4.570482254, !- N2315 - 4.684392452, !- N2316 - 4.154481888, !- N2317 - 4.259934902, !- N2318 - 4.371480942, !- N2319 - 4.480884075, !- N2320 - 4.589886189, !- N2321 - 4.083983421, !- N2322 - 4.185217857, !- N2323 - 4.287743092, !- N2324 - 4.391180038, !- N2325 - 4.495141983, !- N2326 - 0.699999988, !- N2327 - 95, !- N2328 - 58.299999237, !- N2329 - 4.315114021, !- N2330 - 4.435134888, !- N2331 - 4.554670334, !- N2332 - 4.671873093, !- N2333 - 4.790678024, !- N2334 - 4.241845131, !- N2335 - 4.356169701, !- N2336 - 4.471357346, !- N2337 - 4.58867979, !- N2338 - 4.704517841, !- N2339 - 4.165188789, !- N2340 - 4.275683403, !- N2341 - 4.391186237, !- N2342 - 4.504190922, !- N2343 - 4.618098259, !- N2344 - 4.090209007, !- N2345 - 4.200871944, !- N2346 - 4.309335709, !- N2347 - 4.418723583, !- N2348 - 4.528567791, !- N2349 - 4.017769814, !- N2350 - 4.119766235, !- N2351 - 4.226928711, !- N2352 - 4.33268261, !- N2353 - 4.437765598, !- N2354 - 3.95044136, !- N2355 - 4.048425198, !- N2356 - 4.147320747, !- N2357 - 4.246908665, !- N2358 - 4.347802162, !- N2359 - 0.799999952, !- N2360 - 95, !- N2361 - 58.299999237, !- N2362 - 4.17910099, !- N2363 - 4.296833992, !- N2364 - 4.410723209, !- N2365 - 4.524978161, !- N2366 - 4.638459682, !- N2367 - 4.108288288, !- N2368 - 4.218849182, !- N2369 - 4.330227852, !- N2370 - 4.442162514, !- N2371 - 4.555315495, !- N2372 - 4.034177303, !- N2373 - 4.141543865, !- N2374 - 4.253102303, !- N2375 - 4.362112045, !- N2376 - 4.472169876, !- N2377 - 3.961931705, !- N2378 - 4.06912756, !- N2379 - 4.17411375, !- N2380 - 4.279769421, !- N2381 - 4.386049271, !- N2382 - 3.892168045, !- N2383 - 3.991228104, !- N2384 - 4.094691753, !- N2385 - 4.196826935, !- N2386 - 4.2984972, !- N2387 - 3.829097748, !- N2388 - 3.923006058, !- N2389 - 4.018646717, !- N2390 - 4.114741325, !- N2391 - 4.212297916, !- N2392 - 0.899999976, !- N2393 - 95, !- N2394 - 58.299999237, !- N2395 - 4.054514885, !- N2396 - 4.168607712, !- N2397 - 4.279270172, !- N2398 - 4.389719963, !- N2399 - 4.499501705, !- N2400 - 3.98589468, !- N2401 - 4.09318018, !- N2402 - 4.201250553, !- N2403 - 4.309693336, !- N2404 - 4.42343998, !- N2405 - 3.914147854, !- N2406 - 4.018187523, !- N2407 - 4.122880936, !- N2408 - 4.232377052, !- N2409 - 4.338852406, !- N2410 - 3.844367981, !- N2411 - 3.9483881, !- N2412 - 4.049954414, !- N2413 - 4.15252018, !- N2414 - 4.255734921, !- N2415 - 3.777657986, !- N2416 - 3.873054743, !- N2417 - 3.970090866, !- N2418 - 4.072500706, !- N2419 - 4.171607018, !- N2420 - 3.716623068, !- N2421 - 3.808047771, !- N2422 - 3.900614977, !- N2423 - 3.993982792, !- N2424 - 4.088237286, !- N2425 - 0.100000001, !- N2426 - 105, !- N2427 - 58.299999237, !- N2428 - 4.957024574, !- N2429 - 5.096623898, !- N2430 - 5.236547947, !- N2431 - 5.373332024, !- N2432 - 5.517992496, !- N2433 - 4.871440411, !- N2434 - 5.004393578, !- N2435 - 5.138714314, !- N2436 - 5.276421547, !- N2437 - 5.413926125, !- N2438 - 4.782605171, !- N2439 - 4.910242081, !- N2440 - 5.040062428, !- N2441 - 5.175903797, !- N2442 - 5.312035084, !- N2443 - 4.698727131, !- N2444 - 4.821814537, !- N2445 - 4.948050976, !- N2446 - 5.074018955, !- N2447 - 5.20215559, !- N2448 - 4.607835293, !- N2449 - 4.730983734, !- N2450 - 4.851247787, !- N2451 - 4.972860813, !- N2452 - 5.099308491, !- N2453 - 4.529986858, !- N2454 - 4.640068531, !- N2455 - 4.754805088, !- N2456 - 4.869659901, !- N2457 - 4.985126019, !- N2458 - 0.199999988, !- N2459 - 105, !- N2460 - 58.299999237, !- N2461 - 4.66875124, !- N2462 - 4.802227497, !- N2463 - 4.93082571, !- N2464 - 5.059146881, !- N2465 - 5.191219807, !- N2466 - 4.589283466, !- N2467 - 4.713427544, !- N2468 - 4.839844704, !- N2469 - 4.968054771, !- N2470 - 5.095014572, !- N2471 - 4.505195618, !- N2472 - 4.625598431, !- N2473 - 4.746862411, !- N2474 - 4.874894142, !- N2475 - 4.999397278, !- N2476 - 4.423122883, !- N2477 - 4.543682098, !- N2478 - 4.66115284, !- N2479 - 4.781403065, !- N2480 - 4.90073061, !- N2481 - 4.343052864, !- N2482 - 4.453740597, !- N2483 - 4.571639538, !- N2484 - 4.68581152, !- N2485 - 4.803839684, !- N2486 - 4.266988754, !- N2487 - 4.374536514, !- N2488 - 4.481939316, !- N2489 - 4.589905262, !- N2490 - 4.700374603, !- N2491 - 0.299999982, !- N2492 - 105, !- N2493 - 58.299999237, !- N2494 - 4.421822548, !- N2495 - 4.545287609, !- N2496 - 4.668195724, !- N2497 - 4.788751602, !- N2498 - 4.911129475, !- N2499 - 4.346750736, !- N2500 - 4.464244843, !- N2501 - 4.582497597, !- N2502 - 4.703119278, !- N2503 - 4.822359085, !- N2504 - 4.267882824, !- N2505 - 4.381216049, !- N2506 - 4.499984741, !- N2507 - 4.61589098, !- N2508 - 4.733228207, !- N2509 - 4.190729618, !- N2510 - 4.304688454, !- N2511 - 4.415481091, !- N2512 - 4.528050423, !- N2513 - 4.640956879, !- N2514 - 4.115947247, !- N2515 - 4.220407009, !- N2516 - 4.330955982, !- N2517 - 4.439368248, !- N2518 - 4.547296047, !- N2519 - 4.046103001, !- N2520 - 4.146707058, !- N2521 - 4.248055935, !- N2522 - 4.350585461, !- N2523 - 4.454191685, !- N2524 - 0.399999976, !- N2525 - 105, !- N2526 - 58.299999237, !- N2527 - 4.206876278, !- N2528 - 4.321431637, !- N2529 - 4.440407753, !- N2530 - 4.555666447, !- N2531 - 4.670117855, !- N2532 - 4.135492802, !- N2533 - 4.246842861, !- N2534 - 4.359245777, !- N2535 - 4.47206068, !- N2536 - 4.586258888, !- N2537 - 4.060804844, !- N2538 - 4.168990135, !- N2539 - 4.281350136, !- N2540 - 4.391343594, !- N2541 - 4.502279758, !- N2542 - 3.987950563, !- N2543 - 4.095942497, !- N2544 - 4.20174408, !- N2545 - 4.308263779, !- N2546 - 4.415286541, !- N2547 - 3.917137384, !- N2548 - 4.017260075, !- N2549 - 4.121622086, !- N2550 - 4.224592686, !- N2551 - 4.32703495, !- N2552 - 3.853337526, !- N2553 - 3.948281765, !- N2554 - 4.044469357, !- N2555 - 4.141622066, !- N2556 - 4.240265369, !- N2557 - 0.49999997, !- N2558 - 105, !- N2559 - 58.299999237, !- N2560 - 4.01793766, !- N2561 - 4.131142616, !- N2562 - 4.240682125, !- N2563 - 4.35021019, !- N2564 - 4.459012985, !- N2565 - 3.949881792, !- N2566 - 4.056292057, !- N2567 - 4.163374424, !- N2568 - 4.270777702, !- N2569 - 4.383692741, !- N2570 - 3.878722191, !- N2571 - 3.9819417, !- N2572 - 4.085928917, !- N2573 - 4.194205761, !- N2574 - 4.299785614, !- N2575 - 3.809622526, !- N2576 - 3.912805557, !- N2577 - 4.013590813, !- N2578 - 4.115396023, !- N2579 - 4.217382908, !- N2580 - 3.743564606, !- N2581 - 3.838251114, !- N2582 - 3.934475899, !- N2583 - 4.036098003, !- N2584 - 4.134304523, !- N2585 - 3.683333635, !- N2586 - 3.77401042, !- N2587 - 3.865805149, !- N2588 - 3.958500147, !- N2589 - 4.051796436, !- N2590 - 0.599999964, !- N2591 - 105, !- N2592 - 58.299999237, !- N2593 - 3.850387335, !- N2594 - 3.954945326, !- N2595 - 4.063608646, !- N2596 - 4.168386936, !- N2597 - 4.272239208, !- N2598 - 3.785199404, !- N2599 - 3.88706398, !- N2600 - 3.989630222, !- N2601 - 4.092403412, !- N2602 - 4.200609684, !- N2603 - 3.717064142, !- N2604 - 3.816104889, !- N2605 - 3.915759325, !- N2606 - 4.015416622, !- N2607 - 4.119870186, !- N2608 - 3.651733637, !- N2609 - 3.750336885, !- N2610 - 3.846765995, !- N2611 - 3.944792509, !- N2612 - 4.042029381, !- N2613 - 3.588845491, !- N2614 - 3.680245399, !- N2615 - 3.771435976, !- N2616 - 3.864407539, !- N2617 - 3.963193178, !- N2618 - 3.534864187, !- N2619 - 3.619703054, !- N2620 - 3.706410646, !- N2621 - 3.795963526, !- N2622 - 3.885314226, !- N2623 - 0.699999988, !- N2624 - 105, !- N2625 - 58.299999237, !- N2626 - 3.703943253, !- N2627 - 3.800546408, !- N2628 - 3.904876471, !- N2629 - 4.005362034, !- N2630 - 4.105903149, !- N2631 - 3.637578249, !- N2632 - 3.735409975, !- N2633 - 3.833901405, !- N2634 - 3.932480812, !- N2635 - 4.031095982, !- N2636 - 3.572322607, !- N2637 - 3.667176008, !- N2638 - 3.762970924, !- N2639 - 3.858791113, !- N2640 - 3.959079504, !- N2641 - 3.509460688, !- N2642 - 3.60133481, !- N2643 - 3.697365761, !- N2644 - 3.791439056, !- N2645 - 3.885087967, !- N2646 - 3.451619387, !- N2647 - 3.538154364, !- N2648 - 3.626332998, !- N2649 - 3.718320608, !- N2650 - 3.809180975, !- N2651 - 3.400571823, !- N2652 - 3.481964827, !- N2653 - 3.565042257, !- N2654 - 3.649593115, !- N2655 - 3.736445904, !- N2656 - 0.799999952, !- N2657 - 105, !- N2658 - 58.299999237, !- N2659 - 3.569216013, !- N2660 - 3.662858486, !- N2661 - 3.763027191, !- N2662 - 3.859755039, !- N2663 - 3.956446648, !- N2664 - 3.505066156, !- N2665 - 3.599837542, !- N2666 - 3.694655418, !- N2667 - 3.789647102, !- N2668 - 3.884470224, !- N2669 - 3.448462963, !- N2670 - 3.533828735, !- N2671 - 3.626407146, !- N2672 - 3.722590208, !- N2673 - 3.815413475, !- N2674 - 3.38223505, !- N2675 - 3.470417976, !- N2676 - 3.563070536, !- N2677 - 3.653936863, !- N2678 - 3.744590998, !- N2679 - 3.327729702, !- N2680 - 3.410133362, !- N2681 - 3.495568037, !- N2682 - 3.580934763, !- N2683 - 3.671747684, !- N2684 - 3.280770779, !- N2685 - 3.35656476, !- N2686 - 3.436962605, !- N2687 - 3.519353867, !- N2688 - 3.601330996, !- N2689 - 0.899999976, !- N2690 - 105, !- N2691 - 58.299999237, !- N2692 - 3.446807861, !- N2693 - 3.53661871, !- N2694 - 3.63360858, !- N2695 - 3.727164507, !- N2696 - 3.820527554, !- N2697 - 3.38542223, !- N2698 - 3.476547241, !- N2699 - 3.56762886, !- N2700 - 3.659549475, !- N2701 - 3.751011848, !- N2702 - 3.329627991, !- N2703 - 3.419174433, !- N2704 - 3.501956224, !- N2705 - 3.591130972, !- N2706 - 3.684755802, !- N2707 - 3.266721487, !- N2708 - 3.35236454, !- N2709 - 3.441581726, !- N2710 - 3.528435707, !- N2711 - 3.616210699, !- N2712 - 3.213448763, !- N2713 - 3.295887232, !- N2714 - 3.377073288, !- N2715 - 3.459924936, !- N2716 - 3.546308994, !- N2717 - 3.176591158, !- N2718 - 3.247481823, !- N2719 - 3.323341846, !- N2720 - 3.401257277, !- N2721 - 3.480300426, !- N2722 - 0.100000001, !- N2723 - 115, !- N2724 - 58.299999237, !- N2725 - 4.460855007, !- N2726 - 4.585332394, !- N2727 - 4.70954752, !- N2728 - 4.831313133, !- N2729 - 4.955133438, !- N2730 - 4.384663105, !- N2731 - 4.50335741, !- N2732 - 4.622905254, !- N2733 - 4.744850159, !- N2734 - 4.865392208, !- N2735 - 4.30469656, !- N2736 - 4.419706821, !- N2737 - 4.535254478, !- N2738 - 4.656619072, !- N2739 - 4.775087357, !- N2740 - 4.226997375, !- N2741 - 4.341928005, !- N2742 - 4.454235077, !- N2743 - 4.567765713, !- N2744 - 4.681788445, !- N2745 - 4.151290417, !- N2746 - 4.256874084, !- N2747 - 4.368354797, !- N2748 - 4.477987766, !- N2749 - 4.587171078, !- N2750 - 4.080477238, !- N2751 - 4.182036877, !- N2752 - 4.2847085, !- N2753 - 4.388213158, !- N2754 - 4.492309093, !- N2755 - 0.199999988, !- N2756 - 115, !- N2757 - 58.299999237, !- N2758 - 4.141300201, !- N2759 - 4.258165359, !- N2760 - 4.371217728, !- N2761 - 4.484603882, !- N2762 - 4.597279072, !- N2763 - 4.070995331, !- N2764 - 4.180844784, !- N2765 - 4.291338444, !- N2766 - 4.402402878, !- N2767 - 4.51474905, !- N2768 - 3.99749136, !- N2769 - 4.103945255, !- N2770 - 4.214802742, !- N2771 - 4.323048592, !- N2772 - 4.432274342, !- N2773 - 3.925898314, !- N2774 - 4.032236099, !- N2775 - 4.136296272, !- N2776 - 4.24135828, !- N2777 - 4.346870899, !- N2778 - 3.856354952, !- N2779 - 3.955104351, !- N2780 - 4.053944111, !- N2781 - 4.159054756, !- N2782 - 4.260761261, !- N2783 - 3.793963909, !- N2784 - 3.887492895, !- N2785 - 3.982269287, !- N2786 - 4.078569889, !- N2787 - 4.174734592, !- N2788 - 0.299999982, !- N2789 - 115, !- N2790 - 58.299999237, !- N2791 - 3.876779318, !- N2792 - 3.982169867, !- N2793 - 4.091721058, !- N2794 - 4.197297573, !- N2795 - 4.301459312, !- N2796 - 3.811079264, !- N2797 - 3.913727522, !- N2798 - 4.017100811, !- N2799 - 4.1207757, !- N2800 - 4.230053902, !- N2801 - 3.742474318, !- N2802 - 3.842166185, !- N2803 - 3.942623854, !- N2804 - 4.043078899, !- N2805 - 4.149192333, !- N2806 - 3.676090479, !- N2807 - 3.775779247, !- N2808 - 3.872962952, !- N2809 - 3.971735954, !- N2810 - 4.069765568, !- N2811 - 3.612916708, !- N2812 - 3.704997778, !- N2813 - 3.796836376, !- N2814 - 3.890637636, !- N2815 - 3.990009546, !- N2816 - 3.558807611, !- N2817 - 3.643677473, !- N2818 - 3.731016636, !- N2819 - 3.82177496, !- N2820 - 3.911710501, !- N2821 - 0.399999976, !- N2822 - 115, !- N2823 - 58.299999237, !- N2824 - 3.657182693, !- N2825 - 3.752252579, !- N2826 - 3.855612278, !- N2827 - 3.954930544, !- N2828 - 4.054257393, !- N2829 - 3.592070103, !- N2830 - 3.688347816, !- N2831 - 3.785125494, !- N2832 - 3.882921457, !- N2833 - 3.980341673, !- N2834 - 3.533327818, !- N2835 - 3.621060133, !- N2836 - 3.715607166, !- N2837 - 3.80984664, !- N2838 - 3.909278393, !- N2839 - 3.465097904, !- N2840 - 3.55559063, !- N2841 - 3.650814056, !- N2842 - 3.743732929, !- N2843 - 3.835963011, !- N2844 - 3.407375097, !- N2845 - 3.493364573, !- N2846 - 3.580856323, !- N2847 - 3.67199254, !- N2848 - 3.761761189, !- N2849 - 3.357495546, !- N2850 - 3.44119215, !- N2851 - 3.519597292, !- N2852 - 3.603796005, !- N2853 - 3.689723015, !- N2854 - 0.49999997, !- N2855 - 115, !- N2856 - 58.299999237, !- N2857 - 3.465313196, !- N2858 - 3.555579662, !- N2859 - 3.653928518, !- N2860 - 3.747934818, !- N2861 - 3.84198308, !- N2862 - 3.403489828, !- N2863 - 3.495268345, !- N2864 - 3.587454796, !- N2865 - 3.679810524, !- N2866 - 3.771945, !- N2867 - 3.347298861, !- N2868 - 3.437404156, !- N2869 - 3.520670176, !- N2870 - 3.614867926, !- N2871 - 3.705056429, !- N2872 - 3.283938885, !- N2873 - 3.370134115, !- N2874 - 3.459958553, !- N2875 - 3.547214985, !- N2876 - 3.636529922, !- N2877 - 3.230689764, !- N2878 - 3.31317997, !- N2879 - 3.394925117, !- N2880 - 3.478220463, !- N2881 - 3.565139771, !- N2882 - 3.191438675, !- N2883 - 3.261447668, !- N2884 - 3.34129858, !- N2885 - 3.418901682, !- N2886 - 3.498242617, !- N2887 - 0.599999964, !- N2888 - 115, !- N2889 - 58.299999237, !- N2890 - 3.298300505, !- N2891 - 3.38773632, !- N2892 - 3.474177837, !- N2893 - 3.566943884, !- N2894 - 3.655979872, !- N2895 - 3.238316774, !- N2896 - 3.326630116, !- N2897 - 3.414466143, !- N2898 - 3.501969814, !- N2899 - 3.589229107, !- N2900 - 3.185648441, !- N2901 - 3.270263672, !- N2902 - 3.357322931, !- N2903 - 3.436857224, !- N2904 - 3.526371956, !- N2905 - 3.126179457, !- N2906 - 3.208326101, !- N2907 - 3.290561438, !- N2908 - 3.377085686, !- N2909 - 3.461460829, !- N2910 - 3.075015545, !- N2911 - 3.155661106, !- N2912 - 3.234322786, !- N2913 - 3.312305927, !- N2914 - 3.391895056, !- N2915 - 3.044783115, !- N2916 - 3.117329121, !- N2917 - 3.185958147, !- N2918 - 3.259939194, !- N2919 - 3.33368516, !- N2920 - 0.699999988, !- N2921 - 115, !- N2922 - 58.299999237, !- N2923 - 3.15116787, !- N2924 - 3.23756361, !- N2925 - 3.320027351, !- N2926 - 3.408847809, !- N2927 - 3.494282246, !- N2928 - 3.094303131, !- N2929 - 3.17808795, !- N2930 - 3.262979031, !- N2931 - 3.347122431, !- N2932 - 3.430588007, !- N2933 - 3.043186903, !- N2934 - 3.124871969, !- N2935 - 3.20659852, !- N2936 - 3.290448904, !- N2937 - 3.370334625, !- N2938 - 2.986647606, !- N2939 - 3.06540823, !- N2940 - 3.144641876, !- N2941 - 3.227889776, !- N2942 - 3.307798862, !- N2943 - 2.940667868, !- N2944 - 3.014415264, !- N2945 - 3.089119911, !- N2946 - 3.167710304, !- N2947 - 3.244073153, !- N2948 - 2.915406227, !- N2949 - 2.980991602, !- N2950 - 3.050520658, !- N2951 - 3.118648291, !- N2952 - 3.190841913, !- N2953 - 0.799999952, !- N2954 - 115, !- N2955 - 58.299999237, !- N2956 - 3.020508289, !- N2957 - 3.102938652, !- N2958 - 3.182062626, !- N2959 - 3.267274857, !- N2960 - 3.349242687, !- N2961 - 2.965867043, !- N2962 - 3.04640317, !- N2963 - 3.127121687, !- N2964 - 3.208091497, !- N2965 - 3.288571358, !- N2966 - 2.917077065, !- N2967 - 2.995556593, !- N2968 - 3.073635817, !- N2969 - 3.156931639, !- N2970 - 3.232934713, !- N2971 - 2.863228798, !- N2972 - 2.938800097, !- N2973 - 3.014897585, !- N2974 - 3.094262123, !- N2975 - 3.170980453, !- N2976 - 2.817813873, !- N2977 - 2.890356779, !- N2978 - 2.96462059, !- N2979 - 3.037699461, !- N2980 - 3.111128807, !- N2981 - 2.799231052, !- N2982 - 2.862735987, !- N2983 - 2.928508759, !- N2984 - 2.995723724, !- N2985 - 3.06073308, !- N2986 - 0.899999976, !- N2987 - 115, !- N2988 - 58.299999237, !- N2989 - 2.902925014, !- N2990 - 2.982273579, !- N2991 - 3.061761856, !- N2992 - 3.137973547, !- N2993 - 3.219460249, !- N2994 - 2.850191832, !- N2995 - 2.92774868, !- N2996 - 3.005531549, !- N2997 - 3.083178043, !- N2998 - 3.16118741, !- N2999 - 2.803539753, !- N3000 - 2.879143476, !- N3001 - 2.955021381, !- N3002 - 3.029503345, !- N3003 - 3.108935118, !- N3004 - 2.75210166, !- N3005 - 2.824911833, !- N3006 - 2.898008823, !- N3007 - 2.974530458, !- N3008 - 3.04834938, !- N3009 - 2.708879948, !- N3010 - 2.779573679, !- N3011 - 2.849396944, !- N3012 - 2.921314955, !- N3013 - 2.991593361, !- N3014 - 2.693839312, !- N3015 - 2.756402969, !- N3016 - 2.824288845, !- N3017 - 2.883990526, !- N3018 - 2.949110746; !- N3019 - diff --git a/tests/testthat/helper-transition.R b/tests/testthat/helper-transition.R index 7bd26bd61..6bcfbb3aa 100644 --- a/tests/testthat/helper-transition.R +++ b/tests/testthat/helper-transition.R @@ -2,447 +2,11 @@ temp_idf <- function (ver, ...) { idf <- empty_idf(ver) - l <- list(...) + l <- tryCatch(list(...), error = function (e) 1L) + if (length(l)) with_option(list(validate_level = "draft"), idf$add(...)) idf$save(tempfile(fileext = ".idf")) idf } # }}} - -prefix <- function (idf) tools::file_path_sans_ext(basename(idf$path())) - -content <- function (idf) idf$to_string(header = FALSE, comment = FALSE) - -# build_trans_test_idf {{{ -build_trans_test_idf <- function (ver, ..., .exclude = NULL, .report_vars = TRUE) { - verbose <- eplusr_option("verbose_info") - level <- eplusr_option("validate_level") - comp <- eplusr_option("autocomplete") - - eplusr_option(validate_level = "draft", verbose_info = FALSE, autocomplete = FALSE) - on.exit(eplusr_option(validate_level = level, verbose_info = verbose, autocomplete = comp), add = TRUE) - - ver <- standardize_ver(ver) - # For 8.2. Otherwise IDFVersionUpdater will fail - if (ver == 8.2) { - # use a defined file - idf <- read_idf("files/v8.2.idf") - idf$save(tempfile(fileext = ".idf")) - # For 8.8. Otherwise IDFVersionUpdater will fail - } else if (ver == 8.8) { - # use a defined file - idf <- read_idf("files/v8.8.idf") - idf$save(tempfile(fileext = ".idf")) - } else if (ver == 9.1) { - # use a defined file - idf <- read_idf("files/v9.1.idf") - idf$save(tempfile(fileext = ".idf")) - } else { - idf <- temp_idf(ver, ...) - if (!length(list(...)) && !is.character(.report_vars)) { - cls <- CLASS_UPDATED[[as.character(ver[, 1:2])]] - - lst <- rep(list(list()), length(cls)) - names(lst) <- cls - idf$add(lst, .default = TRUE, .all = TRUE) - - idf$save(overwrite = TRUE) - } - - # for 8.5 - if (ver == 8.5) { - # add a material to test moisture penetration depth - prop <- idf$objects_in_class("MaterialProperty:MoisturePenetrationDepth:Settings")[[1L]] - prop$set(name = "GP01", 0.004, 0.07, 0.39, 0.01, 11.71) - idf$add(Material = list(name = "GP01", "MediumSmooth", 0.013, 0.16, 801, 837, 0.9, 0.75, 0.75)) - idf$save(overwrite = TRUE) - # for 8.9 - } else if (ver == 8.9) { - if (idf$is_valid_class("RunPeriod")) { - # add necessary input for the RunPeriod object - rp <- idf$objects_in_class("RunPeriod")[[1L]] - rp$set("name", 1, 2, 3, 4, .default = FALSE) - idf$save(overwrite = TRUE) - } - } - } - - # report variable {{{ - if (isTRUE(.report_vars) || is.character(.report_vars)) { - # add output variables - f <- as.double(as.character(idf$version()[, 1:2])) - rep_vars <- REPORTVAR_RULES[J(f), on = "from", nomatch = 0L] - - if (nrow(rep_vars)) { - rep_vars[, id := .I] - data.table::setnames(rep_vars, "old", "value") - - if (length(.exclude$report_var)) rep_vars <- rep_vars[!J(.exclude$report_var), on = "value"] - - position <- list( - list(class = "Output:Variable", index = 2L), - list(class = "Output:Meter", index = 1L), - list(class = "Output:Meter:MeterFileOnly", index = 1L), - list(class = "Output:Meter:Cumulative", index = 1L), - list(class = "Output:Meter:Cumulative:MeteringFileOnly", index = 1L), - list(class = "Output:Table:TimeBins", index = 2L), - list(class = "ExternalInterface:FunctionalMockupUnitImport:From:Variable", index = 2L), - list(class = "ExternalInterface:FunctionalMockupUnitExport:From:Variable", index = 2L), - list(class = "EnergyManagementSystem:Sensor", index = 3L), - list(class = "Output:Table:Monthly", index = 3L), - list(class = "Meter:Custom", index = 4L), - list(class = "Meter:CustomDecrement", index = 3L) - ) - position <- rbindlist(position)[idf$is_valid_class(class, all = TRUE)] - - if (is.character(.report_vars)) position <- position[J(.report_vars), on = "class"] - - dt <- rbindlist(apply2(position$class, position$index, more_args = list(rep_vars = rep_vars), - function (rep_vars, class, index) { - set(copy(rep_vars), NULL, c("class", "index"), list(class, index)) - } - )) - - idf$load(dt) - idf$save(overwrite = TRUE) - } - } - # }}} - - if (!is.null(.exclude$class)) { - cls <- .exclude$class[idf$is_valid_class(.exclude$class)] - if (length(cls)) { - idf$del(idf$object_id(cls, simplify = TRUE)) - idf$save(overwrite = TRUE) - } - } - - idf -} -# }}} - -# get_both_trans {{{ -get_both_trans <- function (from, to, ..., .exclude = NULL, .report_vars = TRUE) { - verbose <- eplusr_option("verbose_info") - level <- eplusr_option("validate_level") - comp <- eplusr_option("autocomplete") - - eplusr_option(validate_level = "draft", verbose_info = FALSE, autocomplete = FALSE) - on.exit(eplusr_option(validate_level = level, verbose_info = verbose, autocomplete = comp), add = TRUE) - - # build test idf - idf <- suppressWarnings(build_trans_test_idf(from, ..., .exclude = .exclude, .report_vars = .report_vars)) - - # eplusr transition - eplusr <- suppressWarnings(transition(idf, to, save = TRUE, dir = file.path(tempdir(), "eplusr"))) - - # EnergyPlus preprocessor IDFVersionUpdater - ep <- version_updater(idf, to, dir = file.path(tempdir(), "ep")) - ep$`Output:PreprocessorMessage` <- NULL - - if (!is.null(.exclude$post_class)) { - cls <- .exclude$post_class[eplusr$is_valid_class(.exclude$post_class)] - if (length(cls)) { - eplusr$del(eplusr$object_id(cls, simplify = TRUE)) - eplusr$save(overwrite = TRUE) - } - - cls <- .exclude$post_class[ep$is_valid_class(.exclude$post_class)] - if (length(cls)) { - ep$del(ep$object_id(cls, simplify = TRUE)) - ep$save(overwrite = TRUE) - } - } - - list(eplusr = eplusr, energyplus = ep) -} -# }}} - -# expect_identical_transition {{{ -expect_identical_transition <- function (from, to, ..., .exclude = NULL, .report_vars = TRUE, - .ignore_field = NULL, .ignore_case = NULL, - .less_length = NULL, .tolerance = 1e-6) { - trans <- get_both_trans(from, to, ..., .exclude = .exclude, .report_vars = .report_vars) - - # check output version - expect_equal(trans$eplusr$version(), trans$energyplus$version(), - label = "eplusr transition output version", - expected.label = "IDFVersionUpdater output", - info = paste0("Transition ", from, " --> ", to) - ) - - # check output class - expect_equal(trans$eplusr$class_name(), trans$energyplus$class_name(), - label = "eplusr transition output classes", - expected.label = "IDFVersionUpdater output", - info = paste0("Transition ", from, " --> ", to) - ) - - # check object contents - for (cls in trans$eplusr$class_name()) { - val_eplusr <- lapply(trans$eplusr$objects_in_class(cls), function (obj) obj$value()) - val_energyplus <- lapply(trans$energyplus$objects_in_class(cls), function (obj) obj$value()) - - expect_equal(length(val_eplusr), length(val_energyplus), - label = paste0("eplusr transition output objects of class ", surround(cls)), - expected.label = paste0("IDFVersionUpdater transition output"), - info = paste0("Transition ", from, " --> ", to) - ) - - # if all named - if (!anyNA(names(val_eplusr))) { - expect_equal(sort(names(val_eplusr)), sort(names(val_energyplus)), - label = paste0("eplusr transition output object names of class ", surround(cls)), - expected.label = paste0("IDFVersionUpdater transition output"), - info = paste0("Transition ", from, " --> ", to) - ) - # make sure the same order - val_energyplus <- val_energyplus[names(val_eplusr)] - } - - for (i in seq_along(val_eplusr)) { - if (length(val_eplusr[[i]]) < length(val_energyplus[[i]])) - val_energyplus[[i]] <- val_energyplus[[i]][seq_along(val_eplusr[[i]])] - - if (cls %in% .less_length) { - if (length(val_eplusr[[i]]) > length(val_energyplus[[i]])) - val_eplusr[[i]] <- val_eplusr[[i]][seq_along(val_energyplus[[i]])] - } - - if (cls %in% names(.ignore_case)) { - if (any(idx <- length(val_eplusr[[i]]) >= .ignore_case[[cls]])) { - for (index in .ignore_case[[cls]][idx]) { - val_eplusr[[i]][index] <- tolower(val_eplusr[[i]][index]) - } - } - if (any(idx <- length(val_energyplus[[i]]) >= .ignore_case[[cls]])) { - for (index in .ignore_case[[cls]][idx]) { - val_energyplus[[i]][index] <- tolower(val_energyplus[[i]][index]) - } - } - } - - if (cls %in% names(.ignore_field)) { - if (any(idx <- length(val_eplusr[[i]]) >= .ignore_field[[cls]])) { - val_eplusr[[i]][idx] <- NULL - } - if (any(idx <- length(val_energyplus[[i]]) >= .ignore_field[[cls]])) { - val_energyplus[[i]][idx] <- NULL - } - } - } - - expect_equal(unname(val_eplusr), unname(val_energyplus), - label = paste0("eplusr transition output objects of class ", surround(cls)), - expected.label = paste0("IDFVersionUpdater transition output"), - info = paste0("Transition ", from, " --> ", to), - tolerance = .tolerance - ) - } -} -# }}} - -# CLASS_UPDATED {{{ -CLASS_UPDATED <- list( - `7.2` = c( - "ShadowCalculation", # 1 - "Coil:Heating:DX:MultiSpeed", # 2 - "EnergyManagementSystem:OutputVariable", # 3 - "EnergyManagementSystem:MeteredOutputVariable", # 4 - "Branch", # 5 - "PlantEquipmentList", # 6 - "CondenserEquipmentList", # 7 - "HeatExchanger:WatersideEconomizer", # 8 - "HeatExchanger:Hydronic", # 9 - "HeatExchanger:Plate", # 10 - "BuildingSurface:Detailed", # 11 - "Wall:Detailed", # 12 - "RoofCeiling:Detailed", # 13 - "Floor:Detailed", # 14 - "FenestrationSurface:Detailed", # 15 - "Shading:Site:Detailed", # 16 - "Shading:Building:Detailed", # 17 - "Shading:Zone:Detailed", # 18 - "AirflowNetwork:Distribution:Component:ConstantVolumeFan", # 19 - "ZoneHVAC:HighTemperatureRadiant", # 20 - "AirConditioner:VariableRefrigerantFlow", # 21 - "ZoneHVAC:WaterToAirHeatPump", # 22 - "AirLoopHVAC:UnitaryHeatPump:WaterToAir", # 23 - "Boiler:HotWater", # 24 - "Chiller:Electric", # 25 - "Chiller:ConstantCOP", # 26 - "Chiller:EngineDriven", # 27 - "Chiller:CombustionTurbine", # 28 - "Chiller:Electric:EIR", # 29 - "Chiller:Electric:ReformulatedEIR", # 30 - "Chiller:Absorption", # 31 - "Chiller:Absorption:Indirect" # 32 - ), - - `8.0` = c( - "People", # 1 - "CoolingTower:SingleSpeed", # 2 - "CoolingTower:TwoSpeed", # 3 - "EvaporativeFluidCooler:SingleSpeed", # 4 - "EvaporativeFluidCooler:TwoSpeed", # 5 - "FluidCooler:TwoSpeed", # 6 - "HeatPump:WaterToWater:EquationFit:Heating", # 7 - "HeatPump:WaterToWater:EquationFit:Cooling", # 8 - "HeatPump:WaterToWater:ParameterEstimation:Heating", # 9 - "HeatPump:WaterToWater:ParameterEstimation:Cooling", # 10 - "HVACTemplate:Zone:PTAC", # 11 - "HVACTemplate:Zone:PTHP", # 12 - "HVACTemplate:Zone:WaterToAirHeatPump", # 13 - "HVACTemplate:System:Unitary", # 14 - "HVACTemplate:System:UnitaryHeatPump:AirToAir" # 15 - ), - - `8.1` = c( - "ZoneHVAC:UnitVentilator", # 1 - "ZoneHVAC:UnitHeater", # 2 - "PlantLoop", # 3 - "CondenserLoop", # 4 - "HVACTemplate:Plant:ChilledWaterLoop", # 5 - "HVACTemplate:Plant:HotWaterLoop", # 6 - "HVACTemplate:Plant:MixedWaterLoop", # 7 - "Sizing:System", # 8 - "ZoneHVAC:Baseboard:RadiantConvective:Water", # 9 - "ZoneHVAC:HighTemperatureRadiant", # 10 - "ZoneHVAC:Baseboard:RadiantConvective:Steam", # 11 - "ZoneHVAC:Baseboard:RadiantConvective:Electric", # 12 - "ZoneHVAC:Baseboard:Convective:Water", # 13 - "ZoneHVAC:Baseboard:Convective:Electric", # 14 - "ZoneHVAC:LowTemperatureRadiant:VariableFlow", # 15 - "ZoneHVAC:LowTemperatureRadiant:Electric" # 16 - ), - - `8.2` = c( - "Chiller:Electric:ReformulatedEIR", # 1 - "Site:GroundDomain", # 2 - "GroundHeatExchanger:Vertical", # 3 - "EvaporativeCooler:Indirect:ResearchSpecial", # 4 - "EvaporativeCooler:Direct:ResearchSpecial" # 5 - ), - - `8.3` = c( - "Coil:WaterHeating:AirToWaterHeatPump", # 1 - "WaterHeater:Stratified", # 2 - "WaterHeater:HeatPump", # 3 - "Branch", # 4 - "ZoneHVAC:EquipmentList", # 5 - "PlantEquipmentList", # 6 - "EvaporativeCooler:Direct:ResearchSpecial", # 7 - "Controller:MechanicalVentilation", # 8 - "Site:GroundDomain:Slab", # 9 - "Site:GroundDomain:Basement", # 10 - "PipingSystem:Underground:Domain", # 11 - "Pipe:Underground", # 12 - "GroundHeatExchanger:HorizontalTrench", # 13 - "GroundHeatExchanger:Slinky", # 14 - "HVACTemplate:Plant:ChilledWaterLoop", # 15 - "HVACTemplate:Plant:HotWaterLoop", # 16 - "HVACTemplate:Plant:MixedWaterLoop", # 17 - "ZoneAirMassFlowConservation" # 18 - ), - - `8.4` = c( - "EnergyManagementSystem:Actuator" # 1 - ), - - `8.5` = c( - "Exterior:FuelEquipment", # 1 - "HVACTemplate:System:UnitarySystem", # 2 - "HVACTemplate:System:Unitary", # 3 - "ChillerHeater:Absorption:DirectFired", # 4 - "SetpointManager:SingleZone:Humidity:Minimum", # 5 - "SetpointManager:SingleZone:Humidity:Maximum", # 6 - "AirTerminal:SingleDuct:VAV:Reheat", # 7 - "Branch", # 8 - "AirTerminal:SingleDuct:InletSideMixer", # 9 - "AirTerminal:SingleDuct:SupplySideMixer", # 10 - "ZoneHVAC:AirDistributionUnit", # 11 - "OtherEquipment", # 12 - "Coil:Heating:Gas", # 13 - "Daylighting:Controls", # 14 - "Daylighting:DELight:ReferencePoint", # 15 - "Daylighting:DELight:Controls", # 16 - "MaterialProperty:MoisturePenetrationDepth:Settings", # 17 - "EnergyManagementSystem:Actuator" # 18 - ), - - `8.6` = c( - "Coil:Cooling:DX:MultiSpeed", # 1 - "Coil:Heating:DX:MultiSpeed", # 2 - "CoolingTower:SingleSpeed", # 3 - "CoolingTower:TwoSpeed", # 4 - "CoolingTower:VariableSpeed:Merkel", # 5 - "AirflowNetwork:SimulationControl", # 6 - "ZoneCapacitanceMultiplier:ResearchSpecial", # 7 - "WaterHeater:HeatPump:WrappedCondenser", # 8 - "AirflowNetwork:Distribution:Component:Duct" # 9 - ), - - `8.7` = c( - "Output:Surfaces:List", # 1 - "Table:TwoIndependentVariables", # 2 - # Only used to check corresponding perimeter object - "BuildingSurface:Detailed", # 3 - # Only used to check corresponding perimeter object - "Floor:Detailed", # 4 - "SurfaceProperty:ExposedFoundationPerimeter", # 5 - "Foundation:Kiva:Settings", # 6 - "UnitarySystemPerformance:Multispeed", # 7 - "Coil:Cooling:DX:SingleSpeed", # 8 - "Coil:Cooling:DX:TwoSpeed", # 9 - "Coil:Cooling:DX:MultiSpeed", # 10 - "Coil:Cooling:DX:VariableSpeed", # 11 - "Coil:Cooling:DX:TwoStageWithHumidityControlMode",# 12 - "ZoneHVAC:PackagedTerminalHeatPump", # 13 - "ZoneHVAC:IdealLoadsAirSystem", # 14 - "ZoneControl:ContaminantController", # 15 - "AvailabilityManager:NightCycle" # 16 - ), - - `8.8` = c( - "ZoneHVAC:EquipmentList", # 1 - "GroundHeatExchanger:Vertical", # 2 - "Branch", # 3 - "CondenserEquipmentList", # 4 - "ElectricEquipment:ITE:AirCooled", # 5 - "Schedule:Day:Interval", # 6 - "Schedule:Day:List", # 7 - "Schedule:Compact" # 8 - ), - - `8.9` = c( - "AirflowNetwork:Distribution:Component:OutdoorAirFlow", # 1 - "AirflowNetwork:Distribution:Component:ReliefAirFlow", # 2 - "Boiler:HotWater", # 3 - "FenestrationSurface:Detailed", # 4 - "GlazedDoor", # 5 - "RunPeriod:CustomRange", # 6 - "RunPeriod", # 7 - "Table:OneIndependentVariable", # 8 - "WindowMaterial:ComplexShade", # 9 - "Window", # 10 - "WindowProperty:ShadingControl" # 11 - ), - - `9.0` = c( - "HybridModel:Zone", # 1 - "ZoneHVAC:EquipmentList" # 2 - ), - - `9.1` = c( - "Foundation:Kiva", # 1 - "RunPeriod", # 2 - "Schedule:File", # 3 - "Table:OneIndependentVariable", # 4 - "Table:TwoIndependentVariables", # 5 - "Table:MultiVariableLookup", # 6 - "ThermalStorage:Ice:Detailed", # 7 - "ZoneHVAC:EquipmentList" # 8 - ) -) -# }}} diff --git a/tests/testthat/test-transition.R b/tests/testthat/test-transition.R new file mode 100644 index 000000000..73019d7fc --- /dev/null +++ b/tests/testthat/test-transition.R @@ -0,0 +1,1745 @@ +context("Transition") + +# HELPER {{{ +test_that("Transition Helper", { + eplusr_option(verbose_info = FALSE) + idf <- read_idf(example(), use_idd(8.8, "auto")) + + # transition action {{{ + expect_equivalent( + trans_action(idf, "Construction", + offset = list(2L, 4L), + add = list(2L:3L, "No") + ), + data.table( + id = rep(15:17, each = 4L), + name = rep(c("R13WALL", "FLOOR", "ROOF31"), each = 4L), + class = rep("Construction", 12L), + index = rep(c(1:4), 3L), + field = rep(c("Name", NA_character_, NA_character_, "Outside Layer"), 3L), + value = c( + "R13WALL", "No", "No", "R13LAYER", + "FLOOR", "No", "No", "C5 - 4 IN HW CONCRETE", + "ROOF31", "No", "No", "R31LAYER" + ) + ) + ) + + # can insert new extensible fields + expect_equivalent( + trans_action(idf, "Construction", + insert = list(2:3, NA, step = 1) + ), + data.table( + id = rep(15:17, each = 6L), + name = rep(c("R13WALL", "FLOOR", "ROOF31"), each = 6L), + class = rep("Construction", 18L), + index = rep(c(1:6), 3L), + field = rep(c("Name", NA_character_, NA_character_, "Outside Layer", NA_character_, NA_character_), 3L), + value = c( + "R13WALL", NA_character_, NA_character_, "R13LAYER", NA_character_, NA_character_, + "FLOOR", NA_character_, NA_character_, "C5 - 4 IN HW CONCRETE", NA_character_, NA_character_, + "ROOF31", NA_character_, NA_character_, "R31LAYER", NA_character_, NA_character_ + ) + ) + ) + + # can insert multiple times + expect_equivalent( + trans_action(idf, "RunPeriod", + insert = list(c(`Start Year` = 4)), + insert = list(c(`End Year` = 7)) + ), + data.table( + id = rep(8L, 13), + name = rep(NA_character_, 13), + class = rep("RunPeriod", 13), + index = 1:13, + field = c("Name", "Begin Month", "Begin Day of Month", "Start Year", + "End Month", "End Day of Month", "End Year", + "Day of Week for Start Day", "Use Weather File Holidays and Special Days", + "Use Weather File Daylight Saving Period", "Apply Weekend Holiday Rule", + "Use Weather File Rain Indicators", "Use Weather File Snow Indicators" + ), + value = c(NA_character_, "1", "1", NA_character_, "12", "31", NA_character_, + "Tuesday", "Yes", "Yes", "No", "Yes", "Yes" + ) + ) + ) + # }}} + + # preprocess {{{ + expect_silent(new_idf <- trans_preprocess(idf, 8.9, "Construction")) + expect_equivalent(new_idf$version(), numeric_version("8.9.0")) + expect_false(new_idf$is_valid_class("Construction")) + expect_false(get_priv_env(new_idf)$m_log$uuid == get_priv_env(idf)$m_log$uuid) + # }}} + + # versions {{{ + expect_equivalent(trans_upper_versions(idf, 9.1, patch = TRUE), + numeric_version(c("8.8.0", "8.9.0", "9.0.0", "9.0.1", "9.1.0")) + ) + expect_equivalent(trans_upper_versions(idf, 9.1), + numeric_version(c("8.8.0", "8.9.0", "9.0.0", "9.1.0")) + ) + # }}} + + # transition functions {{{ + expect_equivalent( + trans_fun_names(c("8.8.0", "8.9.0", "9.0.1", "9.1.0")), + c("f880t890", "f890t900", "f900t910") + ) + # }}} +}) +# }}} + +# v7.2 --> v8.0 {{{ +test_that("Transition v7.2 --> v8.0", { + skip_on_cran() + from <- 7.2; to <- 8.0 + expect_is(class = "Idf", + idfOri <- temp_idf(7.2, + ShadowCalculation = list(), + "Coil:Heating:DX:MultiSpeed" = list("Coil"), + "EnergyManagementSystem:OutputVariable" = list("Variable [m]"), + "EnergyManagementSystem:MeteredOutputVariable" = list("Variable [m]"), + "Branch" = list("Branch", ..4 = "HeatExchanger:WatersideEconomizer"), + "PlantEquipmentList" = list("PlantEquip", ..2 = "HeatExchanger:WatersideEconomizer"), + "CondenserEquipmentList" = list("CondenserEquip", ..2 = "HeatExchanger:WatersideEconomizer"), + "HeatExchanger:WatersideEconomizer" = list("HE1", ..2 = "PlateFrame"), + "HeatExchanger:Hydronic" = list("HE2", ..8 = "UFactorTimesAreaEffectiveness"), + "HeatExchanger:Plate" = list("HE3", ..8 = "UFactorTimesAreaEffectiveness"), + "BuildingSurface:Detailed" = list("Surf"), + "Wall:Detailed" = list("Wall"), + "RoofCeiling:Detailed" = list("Roof"), + "Floor:Detailed" = list("Floor"), + "FenestrationSurface:Detailed" = list("Fene"), + "Shading:Site:Detailed" = list("SiteShade"), + "Shading:Building:Detailed" = list("BldgShade"), + "Shading:Zone:Detailed" = list("ZoneShade"), + "AirflowNetwork:Distribution:Component:ConstantVolumeFan" = list("Fan"), + "ZoneHVAC:HighTemperatureRadiant" := list(c("Rad1", "Rad2"), ..5 = c("Electric", "Gas")), + "AirConditioner:VariableRefrigerantFlow" = list("VRF", ..48 = 0, ..67 = "Electric"), + "ZoneHVAC:WaterToAirHeatPump" = list("HP"), + "AirLoopHVAC:UnitaryHeatPump:WaterToAir" = list("UHP"), + "Boiler:HotWater" = list("Boiler", ..15 = "VariableFlow"), + "Chiller:Electric" = list("Chiller1", ..27 = "VariableFlow"), + "Chiller:ConstantCOP" = list("Chiller2", ..11 = "VariableFlow"), + "Chiller:EngineDriven" = list("Chiller3", ..41 = "VariableFlow"), + "Chiller:CombustionTurbine" = list("Chiller4", ..54 = "VariableFlow"), + "Chiller:Electric:EIR" = list("Chiller5", ..23 = "VariableFlow"), + "Chiller:Absorption" = list("Chiller6", ..23 = "VariableFlow"), + "Chiller:Absorption:Indirect" = list("Chiller7", ..16 = "VariableFlow"), + .all = TRUE + ) + ) + + expect_is(idfVU <- version_updater(idfOri, to), "Idf") + expect_warning(idfTR <- transition(idfOri, to)) + + expect_equal( + idfVU$"Coil:Heating:DX:MultiSpeed"$Coil$value()[1:40], + idfTR$"Coil:Heating:DX:MultiSpeed"$Coil$value() + ) + + expect_equal( + idfVU$"EnergyManagementSystem:OutputVariable"$Variable$value(), + idfTR$"EnergyManagementSystem:OutputVariable"$Variable$value() + ) + + expect_equal( + idfVU$"EnergyManagementSystem:MeteredOutputVariable"$Variable$value(), + idfTR$"EnergyManagementSystem:MeteredOutputVariable"$Variable$value() + ) + + expect_equal( + idfVU$"Branch"$Branch$value()[1:8], + idfTR$"Branch"$Branch$value() + ) + + expect_equal( + idfVU$"PlantEquipmentList"$PlantEquip$value()[1:2], + idfTR$"PlantEquipmentList"$PlantEquip$value() + ) + + expect_equal( + idfVU$"CondenserEquipmentList"$CondenserEquip$value()[1:2], + idfTR$"CondenserEquipmentList"$CondenserEquip$value() + ) + + expect_equal( + idfVU$"HeatExchanger:FluidToFluid"$HE1$value(), + idfTR$"HeatExchanger:FluidToFluid"$HE1$value() + ) + + expect_equal( + idfVU$"HeatExchanger:FluidToFluid"$HE2$value(), + idfTR$"HeatExchanger:FluidToFluid"$HE2$value() + ) + expect_equal( + idfVU$"SetpointManager:Scheduled"$HE2$value()[-1], + idfTR$"SetpointManager:Scheduled"$'HE2 Setpoint Manager'$value()[-1] + ) + + expect_equal( + idfVU$"HeatExchanger:FluidToFluid"$HE3$value()[1:14], + idfTR$"HeatExchanger:FluidToFluid"$HE3$value() + ) + + expect_equal( + # VersionUpdater failed to change '11: Vertex 1 X-coordinate' to '0.0' + idfVU$"BuildingSurface:Detailed"$Surf$value()[-11], + idfTR$"BuildingSurface:Detailed"$Surf$value()[-11] + ) + + expect_equal( + idfVU$"Wall:Detailed"$Wall$value(), + idfTR$"Wall:Detailed"$Wall$value() + ) + + expect_equal( + idfVU$"RoofCeiling:Detailed"$Roof$value(), + idfTR$"RoofCeiling:Detailed"$Roof$value() + ) + + expect_equal( + idfVU$"Floor:Detailed"$Floor$value(), + idfTR$"Floor:Detailed"$Floor$value() + ) + + expect_equal( + idfVU$"FenestrationSurface:Detailed"$Fene$value(), + idfTR$"FenestrationSurface:Detailed"$Fene$value() + ) + + expect_equal( + idfVU$"Shading:Site:Detailed"$SiteShade$value(), + idfTR$"Shading:Site:Detailed"$SiteShade$value() + ) + + expect_equal( + idfVU$"Shading:Building:Detailed"$BldgShade$value(), + idfTR$"Shading:Building:Detailed"$BldgShade$value() + ) + + expect_equal( + idfVU$"Shading:Zone:Detailed"$ZoneShade$value(), + idfTR$"Shading:Zone:Detailed"$ZoneShade$value() + ) + + expect_equal( + idfVU$"AirflowNetwork:Distribution:Component:Fan"[[1]]$value(), + idfTR$"AirflowNetwork:Distribution:Component:Fan"[[1]]$value() + ) + + expect_equal( + idfVU$"ZoneHVAC:HighTemperatureRadiant"$Rad1$value()[1:11], + idfTR$"ZoneHVAC:HighTemperatureRadiant"$Rad1$value() + ) + + expect_equal( + idfVU$"ZoneHVAC:HighTemperatureRadiant"$Rad2$value()[1:11], + idfTR$"ZoneHVAC:HighTemperatureRadiant"$Rad2$value() + ) + + expect_equal( + idfVU$"AirConditioner:VariableRefrigerantFlow"[[1]]$value(), + idfTR$"AirConditioner:VariableRefrigerantFlow"[[1]]$value() + ) + + expect_equal( + idfVU$"ZoneHVAC:WaterToAirHeatPump"$HP$value()[1:28], + idfTR$"ZoneHVAC:WaterToAirHeatPump"$HP$value() + ) + + expect_equal( + idfVU$"AirLoopHVAC:UnitaryHeatPump:WaterToAir"$UHP$value(), + idfTR$"AirLoopHVAC:UnitaryHeatPump:WaterToAir"$UHP$value() + ) + + expect_equal( + idfVU$"Boiler:HotWater"$Boiler$value(), + idfTR$"Boiler:HotWater"$Boiler$value() + ) + + expect_equal( + idfVU$"Chiller:Electric"$Chiller1$value()[1:33], + idfTR$"Chiller:Electric"$Chiller1$value() + ) + + expect_equal( + idfVU$"Chiller:ConstantCOP"$Chiller2$value()[1:14], + idfTR$"Chiller:ConstantCOP"$Chiller2$value() + ) + + expect_equal( + idfVU$"Chiller:EngineDriven"$Chiller3$value()[1:45], + idfTR$"Chiller:EngineDriven"$Chiller3$value() + ) + + expect_equal( + idfVU$"Chiller:CombustionTurbine"$Chiller4$value()[1:59], + idfTR$"Chiller:CombustionTurbine"$Chiller4$value() + ) + + expect_equal( + idfVU$"Chiller:Electric:EIR"$Chiller5$value()[1:29], + idfTR$"Chiller:Electric:EIR"$Chiller5$value() + ) + + expect_equal( + idfVU$"Chiller:Absorption"$Chiller6$value(), + idfTR$"Chiller:Absorption"$Chiller6$value() + ) + + expect_equal( + idfVU$"Chiller:Absorption:Indirect"$Chiller7$value(), + idfTR$"Chiller:Absorption:Indirect"$Chiller7$value() + ) + + # can handle forkeq variables + expect_is(class = "Idf", + idfOri <- temp_idf(7.2, + "Chiller:Electric:EIR" := list(paste0("Chiller", 1:2)), + "ChillerHeater:Absorption:DirectFired" := list(paste0("Heater", 1:2)), + "Output:Variable" := list("*", + c("Chiller Diesel Consumption", + "CondFD Nodal Temperature") + ) + ) + ) + + # can handle forkeq variables + expect_is(class = "Idf", + idfOri <- temp_idf(7.2, + "Chiller:Electric:EIR" := list(paste0("Chiller", 1:2)), + "ChillerHeater:Absorption:DirectFired" := list(paste0("Heater", 1:2)), + "Output:Variable" := list("*", c( + "Chiller Diesel Consumption", + "Chiller Diesel Consumption Rate", + "CondFD Nodal Temperature", + "Inside Surface Relative Humidity" + )) + ) + ) + + # VersionUpdater does not create "Diesel" output variables for both Chiller + # and ChillerHeater + expect_warning(idfTR <- transition(idfOri, 8), "Default values") + expect_equal(idfTR$to_table(class = "Output:Variable")[index == 2, sort(value)], + c("Chiller Diesel Energy", + "Chiller Diesel Rate", + "Chiller Heater Diesel Energy", + "Chiller Heater Diesel Rate", + "CondFD Surface Temperature Node 1", + "CondFD Surface Temperature Node 10", + "CondFD Surface Temperature Node 2", + "CondFD Surface Temperature Node 3", + "CondFD Surface Temperature Node 4", + "CondFD Surface Temperature Node 5", + "CondFD Surface Temperature Node 6", + "CondFD Surface Temperature Node 7", + "CondFD Surface Temperature Node 8", + "CondFD Surface Temperature Node 9", + "EMPD Surface Inside Face Relative Humidity", + "HAMT Surface Inside Face Relative Humidity" + ) + ) +}) +# }}} +# v8.0 --> v8.1 {{{ +test_that("Transition v8.0 --> v8.1", { + skip_on_cran() + from <- 8.0; to <- 8.1 + expect_is(class = "Idf", + idfOri <- temp_idf(from, + "People" = list("People"), + "CoolingTower:SingleSpeed" = list("CT1", ..8 = "autosize", ..9 = "autosize"), + "CoolingTower:TwoSpeed" = list("CT2", ..8 = "autosize", ..9 = "autosize", ..11 = "autosize", ..12 = "autosize"), + "EvaporativeFluidCooler:SingleSpeed" = list("EFC1"), + "EvaporativeFluidCooler:TwoSpeed" = list("EFC2", ..6 = "autosize", ..7 = "autosize", ..14 = "autosize"), + "FluidCooler:TwoSpeed" = list("FluidCooler", ..6 = "autosize", ..15 = "autosize", ..16 = "autosize"), + "HeatPump:WaterToWater:EquationFit:Heating" = list("HP1"), + "HeatPump:WaterToWater:EquationFit:Cooling" = list("HP2"), + "HeatPump:WaterToWater:ParameterEstimation:Heating" = list("HP3"), + "HeatPump:WaterToWater:ParameterEstimation:Cooling" = list("HP4"), + "HVACTemplate:Zone:PTAC" = list(..13 = "Cycling"), + "HVACTemplate:Zone:PTAC" = list(..13 = "Continuous"), + "HVACTemplate:Zone:PTHP" = list(..13 = "Cycling"), + "HVACTemplate:Zone:PTHP" = list(..13 = "Continuous"), + "HVACTemplate:Zone:WaterToAirHeatPump" = list(..13 = "Cycling"), + "HVACTemplate:Zone:WaterToAirHeatPump" = list(..13 = "Continuous"), + "HVACTemplate:System:Unitary" = list("Sys1", ..5 = "Cycling"), + "HVACTemplate:System:Unitary" = list("Sys2", ..5 = "Continuous"), + "HVACTemplate:System:UnitaryHeatPump:AirToAir" = list("Sys3", ..7 = "Cycling"), + "HVACTemplate:System:UnitaryHeatPump:AirToAir" = list("Sys4", ..7 = "Continuous"), + .all = TRUE + ) + ) + + expect_is(idfVU <- version_updater(idfOri, to), "Idf") + expect_is(idfTR <- transition(idfOri, to), "Idf") + + expect_equal( + idfVU$"People"[[1]]$value()[1:16], + idfTR$"People"[[1]]$value() + ) + + # VersionUpdater gives "autocalculate" instead of "Autocalculate" + lower_autocal <- function (l) lapply(l, function (x) if (identical(x, "Autocalculate")) "autocalculate" else x) + + expect_equal( + idfVU$"CoolingTower:SingleSpeed"$CT1$value(), + lower_autocal(idfTR$"CoolingTower:SingleSpeed"$CT1$value()) + ) + + expect_equal( + idfVU$"CoolingTower:TwoSpeed"$CT2$value(), + lower_autocal(idfTR$"CoolingTower:TwoSpeed"$CT2$value()) + ) + + expect_equal( + idfVU$"EvaporativeFluidCooler:SingleSpeed"$EFC1$value()[1:23], + idfTR$"EvaporativeFluidCooler:SingleSpeed"$EFC1$value() + ) + + expect_equal( + idfVU$"EvaporativeFluidCooler:TwoSpeed"$EFC2$value()[1:32], + lower_autocal(idfTR$"EvaporativeFluidCooler:TwoSpeed"$EFC2$value()) + ) + + expect_equal( + idfVU$"FluidCooler:TwoSpeed"$FluidCooler$value()[1:20], + lower_autocal(idfTR$"FluidCooler:TwoSpeed"$FluidCooler$value()) + ) + + expect_equal( + idfVU$"HeatPump:WaterToWater:EquationFit:Heating"$HP1$value(), + idfTR$"HeatPump:WaterToWater:EquationFit:Heating"$HP1$value() + ) + + expect_equal( + idfVU$"HeatPump:WaterToWater:EquationFit:Cooling"$HP2$value(), + idfTR$"HeatPump:WaterToWater:EquationFit:Cooling"$HP2$value() + ) + + expect_equal( + idfVU$"HeatPump:WaterToWater:ParameterEstimation:Heating"$HP3$value(), + idfTR$"HeatPump:WaterToWater:ParameterEstimation:Heating"$HP3$value() + ) + + expect_equal( + idfVU$"HeatPump:WaterToWater:ParameterEstimation:Cooling"$HP4$value(), + idfTR$"HeatPump:WaterToWater:ParameterEstimation:Cooling"$HP4$value() + ) + + # NOTE: VersionUpdater adds one "ScheduleTypeLimits" for each HVACTemplate + expect_equal(idfTR$"ScheduleTypeLimits"$"Any Number"$Name, "Any Number") + + expect_equal( + idfVU$"HVACTemplate:Zone:PTAC"[[1]]$value(), + idfTR$"HVACTemplate:Zone:PTAC"[[1]]$value(1:36) + ) + expect_equal( + idfVU$"HVACTemplate:Zone:PTAC"[[2]]$value(), + idfTR$"HVACTemplate:Zone:PTAC"[[2]]$value(1:36) + ) + + expect_equal( + idfVU$"HVACTemplate:Zone:PTHP"[[1]]$value(), + idfTR$"HVACTemplate:Zone:PTHP"[[1]]$value(1:46) + ) + expect_equal( + idfVU$"HVACTemplate:Zone:PTHP"[[2]]$value(), + idfTR$"HVACTemplate:Zone:PTHP"[[2]]$value(1:46) + ) + + expect_equal( + idfVU$"HVACTemplate:Zone:WaterToAirHeatPump"[[1]]$value(), + idfTR$"HVACTemplate:Zone:WaterToAirHeatPump"[[1]]$value(1:41) + ) + expect_equal( + idfVU$"HVACTemplate:Zone:WaterToAirHeatPump"[[2]]$value(), + idfTR$"HVACTemplate:Zone:WaterToAirHeatPump"[[2]]$value(1:41) + ) + + expect_equal( + idfVU$"HVACTemplate:System:Unitary"$Sys1$value(), + idfTR$"HVACTemplate:System:Unitary"$Sys1$value(1:47) + ) + expect_equal( + idfVU$"HVACTemplate:System:Unitary"$Sys2$value(), + idfTR$"HVACTemplate:System:Unitary"$Sys2$value(1:47) + ) + + expect_equal( + idfVU$"HVACTemplate:System:UnitaryHeatPump:AirToAir"$Sys3$value(), + idfTR$"HVACTemplate:System:UnitaryHeatPump:AirToAir"$Sys3$value(1:56) + ) + expect_equal( + idfVU$"HVACTemplate:System:UnitaryHeatPump:AirToAir"$Sys4$value(), + idfTR$"HVACTemplate:System:UnitaryHeatPump:AirToAir"$Sys4$value(1:56) + ) +}) +# }}} +# v8.1 --> v8.2 {{{ +test_that("Transition v8.1 --> v8.2", { + skip_on_cran() + from <- 8.1; to <- 8.2 + expect_is(class = "Idf", + idfOri <- temp_idf(from, + "ZoneHVAC:UnitVentilator" = list("UV"), + "ZoneHVAC:UnitHeater" := list(paste0("UH", 1:2), ..8 = c("onoff", "continuous")), + "PlantLoop" := list(paste0("PL", 1:2), ..19 = c("Sequential", "Uniform")), + "CondenserLoop" = list("CL", ..19 = "Sequential"), + "HVACTemplate:Plant:ChilledWaterLoop" := list(paste0("CWL", 1:2), ..32 = c("Sequential", "Uniform"), ..33 = c("Sequential", "Uniform")), + "HVACTemplate:Plant:HotWaterLoop" := list(paste0("HWL", 1:2), ..21 = c("Sequential", "Uniform")), + "HVACTemplate:Plant:MixedWaterLoop" := list(paste0("MWL", 1:2), ..17 = c("Sequential", "Uniform")), + "Sizing:System" = list(), + "ZoneHVAC:Baseboard:RadiantConvective:Water" = list(), + "ZoneHVAC:HighTemperatureRadiant" = list(), + "ZoneHVAC:Baseboard:RadiantConvective:Steam" = list(), + "ZoneHVAC:Baseboard:RadiantConvective:Electric" = list(), + "ZoneHVAC:Baseboard:Convective:Water" = list(), + "ZoneHVAC:Baseboard:Convective:Electric" = list(), + "ZoneHVAC:LowTemperatureRadiant:VariableFlow" = list(), + "ZoneHVAC:LowTemperatureRadiant:Electric" = list(), + .all = TRUE + ) + ) + + expect_is(idfVU <- version_updater(idfOri, to), "Idf") + expect_is(idfTR <- transition(idfOri, to), "Idf") + + expect_equal( + idfVU$"ZoneHVAC:UnitVentilator"$UV$value(1:23), + idfTR$"ZoneHVAC:UnitVentilator"$UV$value() + ) + + expect_equal( + idfVU$"ZoneHVAC:UnitHeater"$UH1$value(1:14), + idfTR$"ZoneHVAC:UnitHeater"$UH1$value() + ) + expect_equal( + idfVU$"ZoneHVAC:UnitHeater"$UH2$value(1:14), + idfTR$"ZoneHVAC:UnitHeater"$UH2$value() + ) + + expect_equal( + idfVU$"PlantLoop"$PL1$value(), + idfTR$"PlantLoop"$PL1$value() + ) + + expect_equal( + idfVU$"CondenserLoop"$CL$value(), + idfTR$"CondenserLoop"$CL$value() + ) + + expect_equal( + idfVU$object("CWL1", "HVACTemplate:Plant:ChilledWaterLoop")$value(), + idfTR$object("CWL1", "HVACTemplate:Plant:ChilledWaterLoop")$value() + ) + expect_equal( + idfVU$object("CWL2", "HVACTemplate:Plant:ChilledWaterLoop")$value(), + idfTR$object("CWL2", "HVACTemplate:Plant:ChilledWaterLoop")$value() + ) + + expect_equal( + idfVU$object("HWL1", "HVACTemplate:Plant:HotWaterLoop")$value(), + idfTR$object("HWL1", "HVACTemplate:Plant:HotWaterLoop")$value() + ) + expect_equal( + idfVU$object("HWL2", "HVACTemplate:Plant:HotWaterLoop")$value(), + idfTR$object("HWL2", "HVACTemplate:Plant:HotWaterLoop")$value() + ) + + expect_equal( + idfVU$object("MWL1", "HVACTemplate:Plant:MixedWaterLoop")$value(), + idfTR$object("MWL1", "HVACTemplate:Plant:MixedWaterLoop")$value() + ) + expect_equal( + idfVU$object("MWL2", "HVACTemplate:Plant:MixedWaterLoop")$value(), + idfTR$object("MWL2", "HVACTemplate:Plant:MixedWaterLoop")$value() + ) + + expect_equal( + idfVU$"Sizing:System"[[1]]$value(), + idfTR$"Sizing:System"[[1]]$value() + ) + + expect_equal( + idfVU$"ZoneHVAC:Baseboard:RadiantConvective:Water"[[1]]$value(1:14), + idfTR$"ZoneHVAC:Baseboard:RadiantConvective:Water"[[1]]$value() + ) + + expect_equal( + idfVU$"ZoneHVAC:HighTemperatureRadiant"[[1]]$value(1:14), + idfTR$"ZoneHVAC:HighTemperatureRadiant"[[1]]$value() + ) + + expect_equal( + idfVU$"ZoneHVAC:Baseboard:RadiantConvective:Steam"[[1]]$value(1:13), + idfTR$"ZoneHVAC:Baseboard:RadiantConvective:Steam"[[1]]$value() + ) + + expect_equal( + idfVU$"ZoneHVAC:Baseboard:RadiantConvective:Electric"[[1]]$value(1:9), + idfTR$"ZoneHVAC:Baseboard:RadiantConvective:Electric"[[1]]$value() + ) + + expect_equal( + idfVU$"ZoneHVAC:Baseboard:Convective:Water"[[1]]$value(), + idfTR$"ZoneHVAC:Baseboard:Convective:Water"[[1]]$value() + ) + + expect_equal( + idfVU$"ZoneHVAC:Baseboard:Convective:Electric"[[1]]$value(), + idfTR$"ZoneHVAC:Baseboard:Convective:Electric"[[1]]$value() + ) + + expect_equal( + idfVU$"ZoneHVAC:LowTemperatureRadiant:VariableFlow"[[1]]$value(), + idfTR$"ZoneHVAC:LowTemperatureRadiant:VariableFlow"[[1]]$value() + ) + + expect_equal( + idfVU$"ZoneHVAC:LowTemperatureRadiant:Electric"[[1]]$value(1:10), + idfTR$"ZoneHVAC:LowTemperatureRadiant:Electric"[[1]]$value() + ) +}) +# }}} +# v8.2 --> v8.3 {{{ +test_that("Transition v8.2 --> v8.3", { + skip_on_cran() + from <- 8.2; to <- 8.3 + expect_is(class = "Idf", + idfOri <- temp_idf(from, + "Chiller:Electric:ReformulatedEIR" = list(), + "Site:GroundDomain" = list(), + "GroundHeatExchanger:Vertical" = list(), + "EvaporativeCooler:Indirect:ResearchSpecial" = list( + ..3 = 0.75, ..4 = 0.5, ..5 = 30.0, ..6 = "autosize", + ..7 = 0.8, ..8 = 1000, ..12 = 0.9, ..17 = 0.2, ..18 = 3 + ), + "EvaporativeCooler:Direct:ResearchSpecial" = list( + ..3 = 0.7, ..4 = 30.0, ..9 = 0.0, ..10 = 3 + ), + .all = TRUE + ) + ) + + expect_is(idfVU <- version_updater(idfOri, to), "Idf") + expect_is(idfTR <- transition(idfOri, to), "Idf") + + expect_equal( + idfVU$"Chiller:Electric:ReformulatedEIR"[[1]]$value(1:26), + idfTR$"Chiller:Electric:ReformulatedEIR"[[1]]$value() + ) + + expect_equal( + idfVU$"Site:GroundDomain:Slab"[[1]]$value(), + idfTR$"Site:GroundDomain:Slab"[[1]]$value() + ) + + expect_equal( + idfVU$"EvaporativeCooler:Indirect:ResearchSpecial"[[1]]$value(), + idfTR$"EvaporativeCooler:Indirect:ResearchSpecial"[[1]]$value() + ) + + expect_equal( + idfVU$"EvaporativeCooler:Direct:ResearchSpecial"[[1]]$value(), + idfTR$"EvaporativeCooler:Direct:ResearchSpecial"[[1]]$value() + ) +}) +# }}} +# v8.3 --> v8.4 {{{ +test_that("Transition v8.3 --> v8.4", { + skip_on_cran() + from <- 8.3; to <- 8.4 + expect_is(class = "Idf", + idfOri <- temp_idf(from, + "Coil:WaterHeating:AirToWaterHeatPump" = list(), + "WaterHeater:Stratified" := list(paste0("Stratified", 1:2)), + "WaterHeater:HeatPump" := list(paste0("HP", 1:2), + ..17 = "WaterHeater:Stratified", + ..18 = paste0("Stratified", 1:2), + ..21 = "Coil:WaterHeating:AirToWaterHeatPump", + ..35 = c("HEATER1", "HEATER2") + ), + "Branch" = list(..4 = "WaterHeater:HeatPump", ..9 = "WaterHeater:HeatPump"), + "ZoneHVAC:EquipmentList" = list(..2 = "WaterHeater:HeatPump", ..6 = "WaterHeater:HeatPump"), + "PlantEquipmentList" = list(..2 = "WaterHeater:HeatPump", ..4 = "WaterHeater:HeatPump"), + "EvaporativeCooler:Direct:ResearchSpecial" = list(), + "Controller:MechanicalVentilation" = list(..4 = "ProportionalControl"), + "Site:GroundDomain:Slab" := list(paste0("Slab", 1:2)), + "Site:GroundDomain:Basement" := list(paste0("Base", 1:2)), + "PipingSystem:Underground:Domain" := list(paste0("PipeSys", 1:2)), + "Pipe:Underground" := list(paste0("Pipe", 1:2)), + "GroundHeatExchanger:HorizontalTrench" := list(paste0("HEH", 1:2)), + "GroundHeatExchanger:Slinky" := list(paste0("HES", 1:2)), + "HVACTemplate:Plant:ChilledWaterLoop" := list( + ..32 = c("Sequential", "Uniform"), + ..33 = c("Sequential", "Uniform") + ), + "HVACTemplate:Plant:HotWaterLoop" := list(..21 = c("Sequential", "Uniform")), + "HVACTemplate:Plant:MixedWaterLoop" := list(..17 = c("Sequential", "Uniform")), + "ZoneAirMassFlowConservation" = list("No"), + .all = TRUE + ) + ) + + expect_is(idfVU <- version_updater(idfOri, to), "Idf") + expect_is(idfTR <- transition(idfOri, to), "Idf") + + expect_equal( + idfVU$"Coil:WaterHeating:AirToWaterHeatPump:Pumped"[[1]]$value(1:21), + idfTR$"Coil:WaterHeating:AirToWaterHeatPump:Pumped"[[1]]$value() + ) + + expect_equal( + idfVU$"WaterHeater:Stratified"$Stratified1$value(1:66), + idfTR$"WaterHeater:Stratified"$Stratified1$value() + ) + expect_equal( + idfVU$"WaterHeater:Stratified"$Stratified2$value(1:66), + idfTR$"WaterHeater:Stratified"$Stratified2$value() + ) + + expect_equal( + idfVU$"WaterHeater:HeatPump:PumpedCondenser"$HP1$value(1:32), + { + val <- idfTR$"WaterHeater:HeatPump:PumpedCondenser"$HP1$value() + val[[21]] <- toupper(val[[21]]) + val + } + ) + expect_equal( + idfVU$"WaterHeater:HeatPump:PumpedCondenser"$HP2$value(1:32), + { + val <- idfTR$"WaterHeater:HeatPump:PumpedCondenser"$HP2$value() + val[[21]] <- toupper(val[[21]]) + val + } + ) + + expect_equal( + idfVU$"Branch"[[1]]$value(1:13), + idfTR$"Branch"[[1]]$value() + ) + + expect_equal( + idfVU$"ZoneHVAC:EquipmentList"[[1]]$value(1:9), + idfTR$"ZoneHVAC:EquipmentList"[[1]]$value() + ) + + expect_equal( + idfVU$"PlantEquipmentList"[[1]]$value(1:4), + idfTR$"PlantEquipmentList"[[1]]$value() + ) + + expect_equal( + idfVU$"EvaporativeCooler:Direct:ResearchSpecial"[[1]]$value(1:11), + idfTR$"EvaporativeCooler:Direct:ResearchSpecial"[[1]]$value() + ) + + expect_equal( + idfVU$"Controller:MechanicalVentilation"[[1]]$value(1:8), + idfTR$"Controller:MechanicalVentilation"[[1]]$value() + ) + + expect_equal( + idfVU$"Site:GroundDomain:Slab"$Slab1$value(1:23), + idfTR$"Site:GroundDomain:Slab"$Slab1$value() + ) + expect_equal( + idfVU$"Site:GroundDomain:Slab"$Slab2$value(1:23), + idfTR$"Site:GroundDomain:Slab"$Slab2$value() + ) + + expect_equal( + idfVU$"Site:GroundDomain:Basement"$Base1$value(), + idfTR$"Site:GroundDomain:Basement"$Base1$value() + ) + expect_equal( + idfVU$"Site:GroundDomain:Basement"$Base2$value(), + idfTR$"Site:GroundDomain:Basement"$Base2$value() + ) + + # VersionUpdater does not follow the actual class order + expect_equal( + idfVU$"PipingSystem:Underground:Domain"$PipeSys1$value(1:36)[-20], + idfTR$"PipingSystem:Underground:Domain"$PipeSys1$value()[-20] + ) + expect_equal( + idfVU$"PipingSystem:Underground:Domain"$PipeSys2$value(1:36)[-20], + idfTR$"PipingSystem:Underground:Domain"$PipeSys2$value()[-20] + ) + expect_equal( + idfTR$"PipingSystem:Underground:Domain"$PipeSys1$value("Undisturbed Ground Temperature Model Name")[[1]], + "KATemp 5" + ) + expect_equal( + idfTR$"PipingSystem:Underground:Domain"$PipeSys2$value("Undisturbed Ground Temperature Model Name")[[1]], + "KATemp 6" + ) + + expect_equal( + idfVU$"Pipe:Underground"$Pipe1$value()[-10], + idfTR$"Pipe:Underground"$Pipe1$value()[-10] + ) + expect_equal( + idfVU$"Pipe:Underground"$Pipe2$value()[-10], + idfTR$"Pipe:Underground"$Pipe2$value()[-10] + ) + expect_equal(idfTR$"Pipe:Underground"$Pipe1$value(10)[[1]], "KATemp 7") + expect_equal(idfTR$"Pipe:Underground"$Pipe2$value(10)[[1]], "KATemp 8") + + expect_equal( + idfVU$"GroundHeatExchanger:HorizontalTrench"$HEH1$value()[-20], + idfTR$"GroundHeatExchanger:HorizontalTrench"$HEH1$value()[-20] + ) + expect_equal( + idfVU$"GroundHeatExchanger:HorizontalTrench"$HEH2$value()[-20], + idfTR$"GroundHeatExchanger:HorizontalTrench"$HEH2$value()[-20] + ) + expect_equal(idfTR$"GroundHeatExchanger:HorizontalTrench"$HEH1$value(20)[[1]], "KATemp 9") + expect_equal(idfTR$"GroundHeatExchanger:HorizontalTrench"$HEH2$value(20)[[1]], "KATemp 10") + + expect_equal( + idfVU$"GroundHeatExchanger:Slinky"$HES1$value()[-21], + idfTR$"GroundHeatExchanger:Slinky"$HES1$value()[-21] + ) + expect_equal( + idfVU$"GroundHeatExchanger:Slinky"$HES2$value()[-21], + idfTR$"GroundHeatExchanger:Slinky"$HES2$value()[-21] + ) + expect_equal(idfTR$"GroundHeatExchanger:Slinky"$HES1$value(21)[[1]], "KATemp 11") + expect_equal(idfTR$"GroundHeatExchanger:Slinky"$HES2$value(21)[[1]], "KATemp 12") + + expect_equal(idfVU$object(11)$value(), idfTR$object(108)$value()) + expect_equal(idfVU$object(12)$value(), idfTR$object(109)$value()) + + expect_equal(idfVU$object(13)$value(), idfTR$object(110)$value()) + expect_equal(idfVU$object(14)$value(), idfTR$object(111)$value()) + + expect_equal(idfVU$object(15)$value(), idfTR$object(112)$value()) + expect_equal(idfVU$object(16)$value(), idfTR$object(113)$value()) + + expect_equal( + idfVU$"ZoneAirMassFlowConservation"$value(), + idfTR$"ZoneAirMassFlowConservation"$value() + ) +}) +# }}} +# v8.4 --> v8.5 {{{ +test_that("Transition v8.4 --> v8.5", { + skip_on_cran() + from <- 8.4; to <- 8.5 + expect_is(class = "Idf", + idfOri <- temp_idf(from, + "EnergyManagementSystem:Actuator" := list( + ..4 = sprintf("outdoor air %sblub temperature", c("dry", "wet")) + ), + .all = TRUE + ) + ) + + expect_is(idfVU <- version_updater(idfOri, to), "Idf") + expect_is(idfTR <- transition(idfOri, to), "Idf") + + expect_equal( + idfVU$"EnergyManagementSystem:Actuator"[[1]]$value(), + idfTR$"EnergyManagementSystem:Actuator"[[1]]$value() + ) + expect_equal( + idfVU$"EnergyManagementSystem:Actuator"[[2]]$value(), + idfTR$"EnergyManagementSystem:Actuator"[[2]]$value() + ) +}) +# }}} +# v8.5 --> v8.6 {{{ +test_that("Transition v8.5 --> v8.6", { + skip_on_cran() + from <- 8.5; to <- 8.6 + expect_is(class = "Idf", + idfOri <- temp_idf(from, + "Building" = list(), + "GlobalGeometryRules" = list("UpperLeftCorner", "Counterclockwise", "Relative", "Relative", "Relative"), + "Exterior:FuelEquipment" = list("Equip"), + "HVACTemplate:System:UnitarySystem" = list("Uni"), + "HVACTemplate:System:Unitary" = list("Sys", "On", "Zone1", ..16 = "Gas"), + "ChillerHeater:Absorption:DirectFired" = list("Chiller", "Autosize", + ..8 = "In", ..9 = "Out", ..10 = "CInlet", ..11 = "COut", + ..12 = "HIn", ..13 = "Hout", ..20 = "Autosize"), + "SetpointManager:SingleZone:Humidity:Minimum" = list("SP1", ..4 = "Node", ..5 = "Zone1"), + "SetpointManager:SingleZone:Humidity:Maximum" = list("SP2", ..4 = "Node", ..5 = "Zone1"), + "AirTerminal:SingleDuct:VAV:Reheat" = list("VAV", + ..3 = "Damper", ..4 = "Inlet", ..5 = "Autosize", ..6 = "Constant", + ..10 = "Coil:Heating:Gas", ..11 = "HtgCoil", + ..14 = "Outlet", ..16 = "Reverse", ..17 = "Autocalculate", + ..18 = "Autocalculate" + ), + "Branch" = list("Branch", "autosize", NULL, "Type", "Name", "In", "Out", "Passive"), + "AirTerminal:SingleDuct:InletSideMixer" = list("Term1", "ZoneHVAC:FourPipeFanCoil", "FanCoil", "Outlet", "Primary", "Second"), + "AirTerminal:SingleDuct:SupplySideMixer" = list("Term2", "ZoneHVAC:FourPipeFanCoil", "FanCoil", "Outlet", "Primary", "Second"), + "OtherEquipment" = list("Equip", "Zone1", "On"), + "Coil:Heating:Gas" = list("Coil", ..5 = "Inlet", ..6 = "Outlet"), + "Zone" := list(paste0("Zone", 1:2)), + "Daylighting:Controls" := list(paste0("Zone", 1:3), + c(1:2, 2), 1:3, 1:3, 4:6, 4:6, 4:6, ..11 = 300, ..12 = 500, ..13 = 1:3, ..14 = 90 + ), + "Daylighting:DELight:Controls" := list( + paste0("DELight", 1:3), paste0("Zone", 1:3), + 1:3, 0.3, 0.2, 2, 1.0, 0.5 + ), + "Daylighting:DELight:ReferencePoint" := list( + paste0("RefPt", 1:2), paste0("DELight", 1:2), 1:2, 1:2, 1:2, 0.5, 400 + ), + "MaterialProperty:MoisturePenetrationDepth:Settings" := list( + "Mat1", 0.004, 0.07, 0.40, 0.07, 10.0 + ), + "Material" = list("Mat1", "Rough", 0.12, 0.16, 800, 800, 0.9, 0.6, 0.6), + "EnergyManagementSystem:Actuator" := list(c("Act1", "Act2"), "Name", "Type", + ..4 = sprintf("outdoor air %sblub temperature", c("dry", "wet")) + ), + "Output:Variable" := list( + paste0("Zone", 1:3), "Daylighting Reference Point 1 Illuminance" + ), + "Output:Variable" := list( + paste0("Zone", 1:3), "Daylighting Lighting Power Multiplier" + ), + .all = TRUE + ) + ) + + expect_is(idfVU <- version_updater(idfOri, to), "Idf") + expect_is(idfTR <- transition(idfOri, to), "Idf") + + use_idd(8.5)$"Daylighting:DELight:Controls" + use_idd(8.6)$"Daylighting:Controls" + + use_idd(8.5)$"Daylighting:DELight:ReferencePoint" + use_idd(8.6)$"Daylighting:DELight:ReferencePoint" + + expect_equal( + idfVU$"Building"$value(), + idfTR$"Building"$value() + ) + expect_equal( + idfVU$"GlobalGeometryRules"$value(), + idfTR$"GlobalGeometryRules"$value() + ) + + expect_equal( + idfVU$"Exterior:FuelEquipment"[[1]]$value(), + idfTR$"Exterior:FuelEquipment"[[1]]$value() + ) + + expect_equal( + idfVU$"HVACTemplate:System:UnitarySystem"[[1]]$value(), + idfTR$"HVACTemplate:System:UnitarySystem"[[1]]$value() + ) + + expect_equal( + idfVU$"HVACTemplate:System:Unitary"[[1]]$value(), + idfTR$"HVACTemplate:System:Unitary"[[1]]$value() + ) + + expect_equal( + idfVU$"ChillerHeater:Absorption:DirectFired"[[1]]$value(), + idfTR$"ChillerHeater:Absorption:DirectFired"[[1]]$value() + ) + + expect_equal( + idfVU$"SetpointManager:SingleZone:Humidity:Minimum"[[1]]$value(), + idfTR$"SetpointManager:SingleZone:Humidity:Minimum"[[1]]$value() + ) + + expect_equal( + idfVU$"SetpointManager:SingleZone:Humidity:Maximum"[[1]]$value(), + idfTR$"SetpointManager:SingleZone:Humidity:Maximum"[[1]]$value() + ) + + expect_equal( + idfVU$"AirTerminal:SingleDuct:VAV:Reheat"[[1]]$value(1:18), + idfTR$"AirTerminal:SingleDuct:VAV:Reheat"[[1]]$value() + ) + + expect_equal( + idfVU$"Branch"[[1]]$value(1:6), + idfTR$"Branch"[[1]]$value() + ) + + expect_equal( + idfVU$"AirTerminal:SingleDuct:Mixer"$Term1$value(), + idfTR$"AirTerminal:SingleDuct:Mixer"$Term1$value() + ) + + expect_equal( + idfVU$"AirTerminal:SingleDuct:Mixer"$Term2$value(), + idfTR$"AirTerminal:SingleDuct:Mixer"$Term2$value() + ) + + expect_equal( + idfVU$"OtherEquipment"[[1]]$value(), + idfTR$"OtherEquipment"[[1]]$value() + ) + + expect_equal( + idfVU$"Coil:Heating:Fuel"[[1]]$value(1:7), + idfTR$"Coil:Heating:Fuel"[[1]]$value() + ) + + expect_equal( + idfVU$"Daylighting:Controls"$Zone1_DaylCtrl$value(), + idfTR$"Daylighting:Controls"$Zone1_DaylCtrl$value() + ) + expect_equal( + idfVU$"Daylighting:Controls"$Zone2_DaylCtrl$value(), + idfTR$"Daylighting:Controls"$Zone2_DaylCtrl$value() + ) + expect_equal( + idfVU$"Daylighting:Controls"$Zone3_DaylCtrl$value(), + idfTR$"Daylighting:Controls"$Zone3_DaylCtrl$value() + ) + expect_equal( + idfVU$"Daylighting:Controls"$DELight1$value(), + idfTR$"Daylighting:Controls"$DELight1$value() + ) + expect_equal( + # NOTE: VersionUpdater failed to update `Lighting Control Type` and always + # returned "Continuous" + idfVU$"Daylighting:Controls"$DELight2$value()[-5], + idfTR$"Daylighting:Controls"$DELight2$value()[-5] + ) + expect_equal( + idfTR$"Daylighting:Controls"$DELight2$value("Lighting Control Type")[[1]], + "Stepped" + ) + expect_equal( + # NOTE: VersionUpdater failed to update `Lighting Control Type` and always + # returned "Continuous" + idfVU$"Daylighting:Controls"$DELight3$value()[-5], + idfTR$"Daylighting:Controls"$DELight3$value(1:13)[-5] + ) + expect_equal( + idfTR$"Daylighting:Controls"$DELight3$value("Lighting Control Type")[[1]], + "ContinuousOff" + ) + + expect_equal( + idfVU$"Daylighting:ReferencePoint"$Zone1_DaylRefPt1$value(), + idfTR$"Daylighting:ReferencePoint"$Zone1_DaylRefPt1$value() + ) + expect_equal( + idfVU$"Daylighting:ReferencePoint"$Zone2_DaylRefPt1$value(), + idfTR$"Daylighting:ReferencePoint"$Zone2_DaylRefPt1$value() + ) + expect_equal( + idfVU$"Daylighting:ReferencePoint"$Zone2_DaylRefPt2$value(), + idfTR$"Daylighting:ReferencePoint"$Zone2_DaylRefPt2$value() + ) + expect_equal( + idfVU$"Daylighting:ReferencePoint"$Zone3_DaylRefPt1$value(), + idfTR$"Daylighting:ReferencePoint"$Zone3_DaylRefPt1$value() + ) + expect_equal( + idfVU$"Daylighting:ReferencePoint"$Zone3_DaylRefPt2$value(), + idfTR$"Daylighting:ReferencePoint"$Zone3_DaylRefPt2$value() + ) + expect_equal( + idfVU$"Daylighting:ReferencePoint"$RefPt1$value(), + idfTR$"Daylighting:ReferencePoint"$RefPt1$value() + ) + expect_equal( + idfVU$"Daylighting:ReferencePoint"$RefPt2$value(), + idfTR$"Daylighting:ReferencePoint"$RefPt2$value() + ) + + expect_equal( + idfVU$"EnergyManagementSystem:Actuator"[[1]]$value(), + idfTR$"EnergyManagementSystem:Actuator"[[1]]$value() + ) + + expect_equal(tolerance = 1e-4, + idfVU$"MaterialProperty:MoisturePenetrationDepth:Settings"[[1]]$value(), + idfTR$"MaterialProperty:MoisturePenetrationDepth:Settings"[[1]]$value() + ) + + # NOTE: VersionUpdater will crash if no matched material found for + # "MaterialProperty:MoisturePenetrationDepth:Settings" + expect_is(class = "Idf", + idfOri <- temp_idf(from, + "MaterialProperty:MoisturePenetrationDepth:Settings" := list( + paste0("Mat", 1:2), 0.004, 0.07, 0.40, 0.07, 10.0 + ), + "Material" = list("Mat1", "Rough", 0.12, 0.16, 800, 800, 0.9, 0.6, 0.6), + .all = TRUE + ) + ) + expect_warning(idfTR <- transition(idfOri, to), "Material match issue") +}) +# }}} +# v8.6 --> v8.7 {{{ +test_that("Transition v8.6 --> v8.7", { + skip_on_cran() + from <- 8.6; to <- 8.7 + expect_is(class = "Idf", + idfOri <- temp_idf(from, + "Coil:Cooling:DX:MultiSpeed" = list("ClgCoil1", ..16 = NULL), + "Coil:Cooling:DX:MultiSpeed" = list("ClgCoil2", ..16 = "PropaneGas"), + "Coil:Heating:DX:MultiSpeed" = list("HtgCoil1", ..16 = NULL), + "Coil:Heating:DX:MultiSpeed" = list("HtgCoil2", ..16 = "PropaneGas"), + "CoolingTower:SingleSpeed" = list("Tower1"), + "CoolingTower:TwoSpeed" = list("Tower2"), + "CoolingTower:VariableSpeed:Merkel" = list("Tower3"), + "AirflowNetwork:SimulationControl" = list("Ctrl"), + "ZoneCapacitanceMultiplier:ResearchSpecial" = list(), + "WaterHeater:HeatPump:WrappedCondenser" = list("HP", ..35 = "MutuallyExlcusive"), + "AirflowNetwork:Distribution:Component:Duct" = list("Duct", ..7 = 0.772, ..8 = 0.0001), + .all = TRUE + ) + ) + + expect_is(idfVU <- version_updater(idfOri, to), "Idf") + expect_is(idfTR <- transition(idfOri, to), "Idf") + + expect_equal( + idfVU$"Coil:Cooling:DX:MultiSpeed"$ClgCoil1$value(1:91), + idfTR$"Coil:Cooling:DX:MultiSpeed"$ClgCoil1$value() + ) + expect_equal( + idfVU$"Coil:Cooling:DX:MultiSpeed"$ClgCoil2$value(1:91), + idfTR$"Coil:Cooling:DX:MultiSpeed"$ClgCoil2$value() + ) + + expect_equal( + idfVU$"Coil:Heating:DX:MultiSpeed"$HtgCoil1$value(1:80), + idfTR$"Coil:Heating:DX:MultiSpeed"$HtgCoil1$value() + ) + expect_equal( + idfVU$"Coil:Heating:DX:MultiSpeed"$HtgCoil2$value(1:80), + idfTR$"Coil:Heating:DX:MultiSpeed"$HtgCoil2$value() + ) + + expect_equal( + idfVU$"CoolingTower:SingleSpeed"$Tower1$value(), + idfTR$"CoolingTower:SingleSpeed"$Tower1$value() + ) + + expect_equal( + idfVU$"CoolingTower:TwoSpeed"$Tower2$value(), + idfTR$"CoolingTower:TwoSpeed"$Tower2$value() + ) + + expect_equal( + idfVU$"CoolingTower:VariableSpeed:Merkel"$Tower3$value(), + idfTR$"CoolingTower:VariableSpeed:Merkel"$Tower3$value() + ) + + expect_equal( + idfVU$"AirflowNetwork:SimulationControl"$value(), + idfTR$"AirflowNetwork:SimulationControl"$value() + ) + + expect_equal( + idfVU$"ZoneCapacitanceMultiplier:ResearchSpecial"[[1]]$value(), + idfTR$"ZoneCapacitanceMultiplier:ResearchSpecial"[[1]]$value() + ) + + expect_equal( + idfVU$"WaterHeater:HeatPump:WrappedCondenser"[[1]]$value(1:37), + idfTR$"WaterHeater:HeatPump:WrappedCondenser"[[1]]$value() + ) + + expect_equal( + idfVU$"AirflowNetwork:Distribution:Component:Duct"$Duct$value(), + idfTR$"AirflowNetwork:Distribution:Component:Duct"$Duct$value() + ) +}) +# }}} +# v8.7 --> v8.8 {{{ +test_that("Transition v8.7 --> v8.8", { + skip_on_cran() + from <- 8.7; to <- 8.8 + expect_is(class = "Idf", + idfOri <- temp_idf(from, + "Output:Surfaces:List" = list("DecayCurvesfromZoneComponentLoads"), + "Table:TwoIndependentVariables" = list("Table"), + "BuildingSurface:Detailed" = list("Surf1", "Floor", "Const", "Zone", + "Foundation", "Slab Foundation", "NoSun", "NoWind", "AutoCalculate", + 4, + 45, 28, 0, + 45, 4, 0, + 4, 4, 0, + 4, 28, 0 + ), + "Floor:Detailed" = list("Surf2", "Const", "Zone", + "Foundation", "Slab Foundation", "NoSun", "NoWind", "AutoCalculate", + 4, + 45, 28, 0, + 45, 4, 0, + 4, 4, 0, + 4, 28, 0 + + ), + "UnitarySystemPerformance:Multispeed" = list("Unitary"), + "Coil:Cooling:DX:SingleSpeed" = list("Coil1"), + "Coil:Cooling:DX:TwoSpeed" = list("Coil2"), + "Coil:Cooling:DX:MultiSpeed" = list("Coil3"), + "Coil:Cooling:DX:VariableSpeed" = list("Coil4"), + "Coil:Cooling:DX:TwoStageWithHumidityControlMode" = list("Coil5"), + "ZoneHVAC:PackagedTerminalHeatPump" = list("HP"), + "ZoneHVAC:IdealLoadsAirSystem" = list("Ideal"), + "ZoneControl:ContaminantController" = list("Cont"), + "AvailabilityManager:NightCycle" = list("Night"), + .all = TRUE + ) + ) + + expect_is(idfVU <- version_updater(idfOri, to), "Idf") + expect_warning(idfTR <- transition(idfOri, to), "'SurfaceProperty:ExposedFoundationPerimeter'") + + expect_equal( + idfVU$"Output:Surfaces:List"[[1]]$value(1), + idfTR$"Output:Surfaces:List"[[1]]$value() + ) + + expect_equal( + idfVU$"Table:TwoIndependentVariables"$Table$value(1:14), + idfTR$"Table:TwoIndependentVariables"$Table$value() + ) + + expect_equal( + idfVU$"BuildingSurface:Detailed"$Surf1$value(), + idfTR$"BuildingSurface:Detailed"$Surf1$value(1:22) + ) + + expect_equal( + idfVU$"Floor:Detailed"$Surf2$value(), + idfTR$"Floor:Detailed"$Surf2$value(1:21) + ) + + expect_equal( + idfVU$"SurfaceProperty:ExposedFoundationPerimeter"[[1]]$value(1:14), + idfTR$"SurfaceProperty:ExposedFoundationPerimeter"[[1]]$value(1:14) + ) + expect_equal( + idfVU$"SurfaceProperty:ExposedFoundationPerimeter"[[2]]$value(1:14), + idfTR$"SurfaceProperty:ExposedFoundationPerimeter"[[2]]$value(1:14) + ) + + expect_equal( + idfVU$"UnitarySystemPerformance:Multispeed"$Unitary$value(1:7), + idfTR$"UnitarySystemPerformance:Multispeed"$Unitary$value() + ) + + expect_equal( + idfVU$"Coil:Cooling:DX:SingleSpeed"$Coil1$value(1:34), + idfTR$"Coil:Cooling:DX:SingleSpeed"$Coil1$value() + ) + + expect_equal( + idfVU$"Coil:Cooling:DX:TwoSpeed"$Coil2$value(1:33), + idfTR$"Coil:Cooling:DX:TwoSpeed"$Coil2$value() + ) + + expect_equal( + idfVU$"Coil:Cooling:DX:MultiSpeed"$Coil3$value(1:92), + idfTR$"Coil:Cooling:DX:MultiSpeed"$Coil3$value() + ) + + expect_equal( + idfVU$"Coil:Cooling:DX:VariableSpeed"$Coil4$value(1:31), + idfTR$"Coil:Cooling:DX:VariableSpeed"$Coil4$value() + ) + + expect_equal( + idfVU$"Coil:Cooling:DX:TwoStageWithHumidityControlMode"$Coil5$value(1:21), + idfTR$"Coil:Cooling:DX:TwoStageWithHumidityControlMode"$Coil5$value() + ) + + expect_equal( + idfVU$"ZoneHVAC:PackagedTerminalHeatPump"$HP$value(1:26), + idfTR$"ZoneHVAC:PackagedTerminalHeatPump"$HP$value() + ) + + expect_equal( + idfVU$"ZoneHVAC:IdealLoadsAirSystem"$Ideal$value(1:27), + idfTR$"ZoneHVAC:IdealLoadsAirSystem"$Ideal$value() + ) + + expect_equal( + idfVU$"ZoneControl:ContaminantController"$Cont$value(1:4), + idfTR$"ZoneControl:ContaminantController"$Cont$value() + ) + + expect_equal( + idfVU$"AvailabilityManager:NightCycle"$Night$value(1:7), + idfTR$"AvailabilityManager:NightCycle"$Night$value() + ) +}) +# }}} +# v8.8 --> v8.9 {{{ +test_that("Transition v8.8 --> v8.9", { + skip_on_cran() + from <- 8.8; to <- 8.9 + expect_is(class = "Idf", + idfOri <- temp_idf(from, + "ZoneHVAC:EquipmentList" = list("Equip"), + "GroundHeatExchanger:Vertical" = list("GHP", "Inlet", "Outlet", + 3.3e-4, 24, + 76.2, 0.06, 0.70, 2.34e6, 13.40, 0.70, + 0.39, 0.03, 0.02, 0.002, 2, 0.0005, + 3, -15.2996, -0.348322, -14.201, 0.022208, -13.2202, 0.412345), + "Branch" = list("Branch", NULL, "GroundHeatExchanger:Vertical", "GHP", "Inlet", "Outlet"), + "CondenserEquipmentList" = list("CondEquip", "GroundHeatExchanger:Vertical", "GHP"), + "ElectricEquipment:ITE:AirCooled" = list(), + "Schedule:Day:Interval" = list(..3 = "yes"), + "Schedule:Day:List" = list(..3 = "yes"), + "Schedule:Compact" = list(..3 = "Interpolate: yes"), + .all = TRUE + ) + ) + + expect_is(idfVU <- version_updater(idfOri, to), "Idf") + expect_is(idfTR <- transition(idfOri, to), "Idf") + + expect_equal( + idfVU$"ZoneHVAC:EquipmentList"[[1]]$value(1:6), + idfTR$"ZoneHVAC:EquipmentList"[[1]]$value() + ) + + expect_equal( + idfVU$"GroundHeatExchanger:System"[[1]]$value(), + idfTR$"GroundHeatExchanger:System"[[1]]$value() + ) + + expect_equal(tolerance = 1e-5, + idfVU$"GroundHeatExchanger:Vertical:Properties"[[1]]$value(), + idfTR$"GroundHeatExchanger:Vertical:Properties"[[1]]$value() + ) + expect_equal(tolerance = 1e-5, + idfVU$"GroundHeatExchanger:ResponseFactors"[[1]]$value(1:74), + idfTR$"GroundHeatExchanger:ResponseFactors"[[1]]$value(1:74) + ) + + expect_equal( + idfVU$"Branch"[[1]]$value(1:6), + idfTR$"Branch"[[1]]$value() + ) + + expect_equal( + idfVU$"CondenserEquipmentList"[[1]]$value(1:3), + idfTR$"CondenserEquipmentList"[[1]]$value() + ) + + expect_equal( + idfVU$"ElectricEquipment:ITE:AirCooled"[[1]]$value(), + idfTR$"ElectricEquipment:ITE:AirCooled"[[1]]$value() + ) + + expect_equal( + idfVU$"Schedule:Day:Interval"[[1]]$value(1:5), + idfTR$"Schedule:Day:Interval"[[1]]$value() + ) + + expect_equal( + idfVU$"Schedule:Day:List"[[1]]$value(1:5), + idfTR$"Schedule:Day:List"[[1]]$value() + ) + + expect_equal( + idfVU$"Schedule:Compact"[[1]]$value(1:5), + idfTR$"Schedule:Compact"[[1]]$value() + ) +}) +# }}} +# v8.9 --> v9.0 {{{ +test_that("Transition v8.9 --> v9.0", { + skip_on_cran() + from <- 8.9; to <- 9.0 + expect_is(class = "Idf", + idfOri <- temp_idf(from, + "OutdoorAir:Mixer" = list("OAMixer"), + "AirflowNetwork:Distribution:Component:OutdoorAirFlow" = list("OA"), + "AirflowNetwork:Distribution:Component:ReliefAirFlow" = list("RA"), + "Boiler:HotWater" = list("Boiler"), + "GlazedDoor" = list("GD"), + "RunPeriod:CustomRange" = list("RP1", 1, 1, 2020, 1, 2, 2020, "UseWeatherFile"), + "RunPeriod" = list("RP2", 1, 1, 1, 2, "UseWeatherFile", ..12 = 3, ..14 = 2020), + "RunPeriod" = list("RP3", 1, 1, 1, 2, "UseWeatherFile", ..12 = 3), + "RunPeriod" = list("RP4", 1, 1, 1, 2, "Monday", ..12 = 2), + "RunPeriod" = list("RP5", 1, 1, 1, 2, "Sunday", ..12 = 2), + "Table:OneIndependentVariable" = list("Table", "Exponent"), + "WindowMaterial:ComplexShade" = list("Mat", "Venetian"), + "FenestrationSurface:Detailed" = list("Fene", "Window", "ConstNoShade", "Surf", ..7 = "Ctrl"), + "BuildingSurface:Detailed" = list("Surf", "Wall", "Wall", "Zone", "Outdoors"), + "Zone" = list("Zone"), + "Window" = list("Win"), + "WindowProperty:ShadingControl" = list("Ctrl", "ExteriorScreen", + "Const", "OnIfScheduleAllows", "ScreenSchedule", 20, "Yes", "No" + ), + .all = TRUE + ) + ) + + expect_is(idfVU <- version_updater(idfOri, to), "Idf") + expect_warning(idfTR <- transition(idfOri, to), "UseWeatherFile") + + expect_equal( + idfVU$"AirflowNetwork:Distribution:Component:OutdoorAirFlow"[[1]]$value(1:4), + idfTR$"AirflowNetwork:Distribution:Component:OutdoorAirFlow"[[1]]$value() + ) + + expect_equal( + idfVU$"AirflowNetwork:Distribution:Component:ReliefAirFlow"[[1]]$value(1:4), + idfTR$"AirflowNetwork:Distribution:Component:ReliefAirFlow"[[1]]$value() + ) + + expect_equal( + idfVU$"Boiler:HotWater"[[1]]$value(), + idfTR$"Boiler:HotWater"[[1]]$value() + ) + + expect_equal( + idfVU$"FenestrationSurface:Detailed"[[1]]$value(1:18), + idfTR$"FenestrationSurface:Detailed"[[1]]$value() + ) + + expect_equal( + idfVU$"GlazedDoor"[[1]]$value(1:5), + idfTR$"GlazedDoor"[[1]]$value() + ) + + expect_equal( + idfVU$"RunPeriod"$RP1$value(1:13), + idfTR$"RunPeriod"$RP1$value() + ) + expect_equal( + idfVU$"RunPeriod"$RP2$value(1:13), + idfTR$"RunPeriod"$RP2$value() + ) + expect_equal( + idfVU$"RunPeriod"$RP3$value(1:13), + idfTR$"RunPeriod"$RP3$value() + ) + expect_equal( + idfVU$"RunPeriod"$RP4$value(1:13), + idfTR$"RunPeriod"$RP4$value() + ) + expect_equal( + idfVU$"RunPeriod"$RP5$value(1:13), + idfTR$"RunPeriod"$RP5$value() + ) + + expect_equal( + idfVU$"Table:OneIndependentVariable"[[1]]$value(1:14), + idfTR$"Table:OneIndependentVariable"[[1]]$value() + ) + + expect_equal( + idfVU$"WindowMaterial:ComplexShade"[[1]]$value(), + idfTR$"WindowMaterial:ComplexShade"[[1]]$value() + ) + + expect_equal( + idfVU$"Window"[[1]]$value(1:5), + idfTR$"Window"[[1]]$value() + ) + + expect_equal( + idfVU$"WindowShadingControl"[[1]]$value(), + idfTR$"WindowShadingControl"[[1]]$value() + ) +}) +# }}} +# v9.0 --> v9.1 {{{ +test_that("Transition v9.0 --> v9.1", { + skip_on_cran() + from <- 9.0; to <- 9.1 + expect_is(class = "Idf", + idfOri <- temp_idf(from, + "HybridModel:Zone" = list("HM", "Zone", "no", "no", "sch", 1, 1, 12, 31), + "ZoneHVAC:EquipmentList" = list("EquipList", NULL, "ZoneHVAC:IdealLoadsAirSystem", "Ideal", 1, 1 + ), + .all = TRUE + ) + ) + + expect_is(idfVU <- version_updater(idfOri, to), "Idf") + expect_is(idfTR <- transition(idfOri, to), "Idf") + + expect_equal( + idfVU$"HybridModel:Zone"[[1]]$value(), + idfTR$"HybridModel:Zone"[[1]]$value() + ) + + expect_equal( + idfVU$"ZoneHVAC:EquipmentList"[[1]]$value(1:8), + idfTR$"ZoneHVAC:EquipmentList"[[1]]$value() + ) +}) +# }}} +# v9.1 --> v9.2 {{{ +test_that("Transition v9.1 --> v9.2", { + skip_on_cran() + from <- 9.1; to <- 9.2 + f <- tempfile(fileext = ".csv") + writeLines("", f) + expect_is(class = "Idf", + idfOri <- temp_idf(from, + "Foundation:Kiva" = list(), + "RunPeriod" := list(c(paste0("runperiod", c("", 1:5), "rp"))), + "RunPeriod" := list(..2 = rep(1:5)), + "Schedule:File" = list(..3 = f, ..7 = "fixed"), + "Table:OneIndependentVariable" = list( + "One", "Quadratic", "EvaluateCurveToLimits", 0.0, 1.0, 0.85, + 1.0, "Dimensionless", "Dimensionless", NULL, 0.0, 0.85, 0.5, + 0.925, 1.0, 1.0 + ), + "Table:TwoIndependentVariables" = list( + "Two1", "BiQuadratic", "LagrangeInterpolationLinearExtrapolation", + 12, 24, 18, 47, 0, 40000, "Temperature", "Temperature", + "Dimensionless", 25000, NULL, + 12.77778, 36, 19524.15032, + 12.77778, 41, 18178.81244, + 12.77778, 46.11111, 16810.36004, + 15, 18, 25997.3589, + 15, 30, 22716.4017, + 12.77778, 30, 21147.21662, + 12.77778, 35, 19794.00525, + 15, 24, 24352.1562, + 12.77778, 18, 24421.69383, + 12.77778, 24, 22779.73113, + 15, 35, 21360.49033, + 15, 36, 21090.0954, + 15, 41, 19742.05753, + 15, 46.11111, 18370.84513, + 18, 18, 28392.31868, + 23.88889, 41, 27683.36592, + 23.88889, 46.11111, 26301.11353, + 18, 24, 26742.74198, + 18, 30, 25102.61348, + 23.88889, 35, 29314.75872, + 23.88889, 36, 29042.2038, + 19.44448943, 24, 28003.546, + 19.44448943, 30, 26361.31143, + 18, 35, 23743.0571, + 18, 36, 23471.93318, + 18, 41, 22120.2503, + 18, 46.11111, 20745.3119, + 21, 18, 31094.97495, + 21, 24, 29441.02425, + 19.44448943, 18, 29655.22876, + 21, 30, 27796.52175, + 21, 35, 26433.32038, + 21, 36, 26161.46745, + 21, 41, 24806.13958, + 21, 46.11111, 23427.47518, + 23.88889, 18, 33988.3473, + 23.88889, 24, 32330.1846, + 23.88889, 30, 30681.4701, + 19.44448943, 35, 25000, + 19.44448943, 36, 24728.52506, + 19.44448943, 41, 23375.08713, + 19.44448943, 46.11111, 21998.35468 + ), + "Table:TwoIndependentVariables" = list( + "Two2", "BiQuadratic", "LagrangeinterpolationLinearExtrapolation", + 12, 24, 18, 47, NULL, NULL, "Temperature", "Temperature", + "Dimensionless", NULL, NULL, + 12.77778, 36, 19524.15032, + 12.77778, 41, 18178.81244, + 12.77778, 46.11111, 16810.36004, + 15, 18, 25997.3589, + 15, 30, 22716.4017, + 12.77778, 30, 21147.21662, + 12.77778, 35, 19794.00525, + 15, 24, 24352.1562, + 12.77778, 18, 24421.69383, + 12.77778, 24, 22779.73113, + 15, 35, 21360.49033, + 15, 36, 21090.0954, + 15, 41, 19742.05753, + 15, 46.11111, 18370.84513, + 18, 18, 28392.31868, + 23.88889, 41, 27683.36592, + 23.88889, 46.11111, 26301.11353, + 18, 24, 26742.74198, + 18, 30, 25102.61348, + 23.88889, 35, 29314.75872, + 23.88889, 36, 29042.2038, + 19.44448943, 24, 28003.546, + 19.44448943, 30, 26361.31143, + 18, 35, 23743.0571, + 18, 36, 23471.93318, + 18, 41, 22120.2503, + 18, 46.11111, 20745.3119, + 21, 18, 31094.97495, + 21, 24, 29441.02425, + 19.44448943, 18, 29655.22876, + 21, 30, 27796.52175, + 21, 35, 26433.32038, + 21, 36, 26161.46745, + 21, 41, 24806.13958, + 21, 46.11111, 23427.47518, + 23.88889, 18, 33988.3473, + 23.88889, 24, 32330.1846, + 23.88889, 30, 30681.4701, + 19.44448943, 35, 25000, + 19.44448943, 36, 24728.52506, + 19.44448943, 41, 23375.08713, + 19.44448943, 46.11111, 21998.35468 + ), + "Table:MultiVariableLookup" = list( + "Multi1", "EvaluateCurveToLimits", 3, "Quadratic", + "SingleLineIndependentVariableWithMatrix", NULL, "ASCENDING", + NULL, NULL, 0.5, 1.5, NULL, NULL, NULL, NULL, NULL, NULL, NULL, + NULL, NULL, NULL, 0.8, 1.5, "Dimensionless", NULL, NULL, NULL, + NULL, NULL, "Dimensionless", 1, 3, 0.0, 1.0, 1.5, 0.8, 1.0, 1.1 + ), + "Table:MultiVariableLookup" = list( + "Multi2", "EvaluateCurveToLimits", 3, 'Quadratic', + "SingleLineIndependentVariableWithMatrix", NULL, "ASCENDING", + NULL, NULL, 0.5, 1.5, NULL, NULL, NULL, NULL, NULL, NULL, NULL, + NULL, NULL, NULL, 0.0, 1.5, "Dimensionless", NULL, NULL, NULL, + NULL, NULL, "Dimensionless", 1, 4, 0.0, 0.5, 1.0, 1.5, 1.1552, + 1.0712, 1.0, 0.9416 + ), + "Coil:Cooling:DX:SingleSpeed" = list("Coil", "Sch", "autosize", + "autosize", 3.0, "autosize", NULL, "Inlet", "Outlet", + "Two1", "Multi1", "Two2", "Multi2", "One"), + "ThermalStorage:Ice:Detailed" := list(c("Ice1", "Ice2"), ..6 = c("quadraticlinear", "cubiclinear"), ..8 = c("quadraticlinear", "cubiclinear")), + "ZoneHVAC:EquipmentList" = list("Equip1"), + "ZoneHVAC:EquipmentList" = list("Equip2", NULL, "ZoneHVAC:PackagedTerminalHeatPump", "HP", 1, 1), + "ZoneHVAC:EquipmentList" = list("Equip3", NULL, + "ZoneHVAC:PackagedTerminalHeatPump", "HP1", 1, 1, 1, 1, + "ZoneHVAC:PackagedTerminalHeatPump", "HP2", 1, 1, 1, 1, + "ZoneHVAC:PackagedTerminalHeatPump", "HP3", 1, 1, 1, 1 + ), + .all = FALSE + ) + ) + + idf <- read_idf("/mnt/c/Users/hongy/Desktop/LookupTables_V920.idf") + + expect_is(idfVU <- version_updater(idfOri, to), "Idf") + expect_warning(idfTR <- transition(idfOri, to), "comments") + + expect_equal( + idfVU$"Foundation:Kiva"[[1]]$value(1), + idfTR$"Foundation:Kiva"[[1]]$value() + ) + + expect_equal( + idfVU$"RunPeriod"[[1]]$value(), + idfTR$"RunPeriod"[[1]]$value() + ) + + expect_equal( + idfVU$"Schedule:File"[[1]]$value()[-3], + idfTR$"Schedule:File"[[1]]$value()[-3] + ) + + expect_equal( + idfVU$"Table:IndependentVariable"$One_IndependentVariable1$value(), + idfTR$"Table:IndependentVariable"$One_IndependentVariable1$value() + ) + + expect_equal(tolerance = 1e-5, + idfVU$"Table:IndependentVariable"$Two1_IndependentVariable1$value(), + idfTR$"Table:IndependentVariable"$Two1_IndependentVariable1$value() + ) + expect_equal(tolerance = 1e-5, + idfVU$"Table:IndependentVariable"$Two1_IndependentVariable2$value(), + idfTR$"Table:IndependentVariable"$Two1_IndependentVariable2$value() + ) + expect_equal(tolerance = 1e-5, + idfVU$"Table:IndependentVariable"$Two2_IndependentVariable1$value(), + idfTR$"Table:IndependentVariable"$Two2_IndependentVariable1$value() + ) + expect_equal(tolerance = 1e-5, + idfVU$"Table:IndependentVariable"$Two2_IndependentVariable2$value(), + idfTR$"Table:IndependentVariable"$Two2_IndependentVariable2$value() + ) + expect_equal(tolerance = 1e-5, + idfVU$"Table:IndependentVariable"$Multi1_IndependentVariable1$value(), + idfTR$"Table:IndependentVariable"$Multi1_IndependentVariable1$value() + ) + expect_equal(tolerance = 1e-5, + idfVU$"Table:IndependentVariable"$Multi2_IndependentVariable1$value(), + idfTR$"Table:IndependentVariable"$Multi2_IndependentVariable1$value() + ) + + expect_equal( + idfVU$"Table:IndependentVariableList"$One_IndependentVariableList$value(), + idfTR$"Table:IndependentVariableList"$One_IndependentVariableList$value() + ) + expect_equal( + idfVU$"Table:IndependentVariableList"$Two1_IndependentVariableList$value(), + idfTR$"Table:IndependentVariableList"$Two1_IndependentVariableList$value() + ) + expect_equal( + idfVU$"Table:IndependentVariableList"$Two2_IndependentVariableList$value(), + idfTR$"Table:IndependentVariableList"$Two2_IndependentVariableList$value() + ) + expect_equal( + idfVU$"Table:IndependentVariableList"$Multi1_IndependentVariableList$value(), + idfTR$"Table:IndependentVariableList"$Multi1_IndependentVariableList$value() + ) + expect_equal( + idfVU$"Table:IndependentVariableList"$Multi2_IndependentVariableList$value(), + idfTR$"Table:IndependentVariableList"$Multi2_IndependentVariableList$value() + ) + + expect_equal(tolerance = 1e-5, + idfVU$"Table:Lookup"$One$value(), + idfTR$"Table:Lookup"$One$value() + ) + expect_equal(tolerance = 1e-5, + idfVU$"Table:Lookup"$Two1$value(), + idfTR$"Table:Lookup"$Two1$value() + ) + expect_equal(tolerance = 1e-5, + idfVU$"Table:Lookup"$Two2$value(), + idfTR$"Table:Lookup"$Two2$value() + ) + expect_equal(tolerance = 1e-5, + idfVU$"Table:Lookup"$Multi1$value(), + idfTR$"Table:Lookup"$Multi1$value() + ) + expect_equal(tolerance = 1e-5, + idfVU$"Table:Lookup"$Multi2$value(), + idfTR$"Table:Lookup"$Multi2$value() + ) + + expect_equal( + idfVU$"ZoneHVAC:EquipmentList"$Equip1$value(), + idfTR$"ZoneHVAC:EquipmentList"$Equip1$value() + ) + expect_equal( + idfVU$"ZoneHVAC:EquipmentList"$Equip2$value(), + idfTR$"ZoneHVAC:EquipmentList"$Equip2$value() + ) + expect_equal( + idfVU$"ZoneHVAC:EquipmentList"$Equip3$value(), + idfTR$"ZoneHVAC:EquipmentList"$Equip3$value() + ) + + expect_equal( + idfVU$"ScheduleTypeLimits"[[1]]$value()[-1], + idfTR$"ScheduleTypeLimits"[[1]]$value()[-1] + ) + + expect_equal( + { + dt_vu <- idfVU$to_table(class = "Schedule:Constant", wide = TRUE, string_value = FALSE)[, -"id"] + }, + { + dt_tr <- idfTR$to_table(class = "Schedule:Constant", wide = TRUE, string_value = FALSE)[, -"id"] + dt_tr[J(unique(dt_vu$name)), on = "name"][, `Schedule Type Limits Name` := gsub("Limits", "Limts", `Schedule Type Limits Name`)] + } + ) +}) +# }}} diff --git a/tests/testthat/test_transition.R b/tests/testthat/test_transition.R deleted file mode 100644 index 7b969737c..000000000 --- a/tests/testthat/test_transition.R +++ /dev/null @@ -1,322 +0,0 @@ -context("Transition") - -test_that("Transition Helper", { - eplusr_option(verbose_info = FALSE) - idf <- read_idf(example(), use_idd(8.8, "auto")) - - # transition action {{{ - expect_equivalent( - trans_action(idf, "Construction", - offset = list(2L, 4L), - add = list(2L:3L, "No") - ), - data.table( - id = rep(15:17, each = 4L), - name = rep(c("R13WALL", "FLOOR", "ROOF31"), each = 4L), - class = rep("Construction", 12L), - index = rep(c(1:4), 3L), - field = rep(c("Name", NA_character_, NA_character_, "Outside Layer"), 3L), - value = c( - "R13WALL", "No", "No", "R13LAYER", - "FLOOR", "No", "No", "C5 - 4 IN HW CONCRETE", - "ROOF31", "No", "No", "R31LAYER" - ) - ) - ) - - # can insert new extensible fields - expect_equivalent( - trans_action(idf, "Construction", - insert = list(2:3, NA, step = 1) - ), - data.table( - id = rep(15:17, each = 6L), - name = rep(c("R13WALL", "FLOOR", "ROOF31"), each = 6L), - class = rep("Construction", 18L), - index = rep(c(1:6), 3L), - field = rep(c("Name", NA_character_, NA_character_, "Outside Layer", NA_character_, NA_character_), 3L), - value = c( - "R13WALL", NA_character_, NA_character_, "R13LAYER", NA_character_, NA_character_, - "FLOOR", NA_character_, NA_character_, "C5 - 4 IN HW CONCRETE", NA_character_, NA_character_, - "ROOF31", NA_character_, NA_character_, "R31LAYER", NA_character_, NA_character_ - ) - ) - ) - - # can insert multiple times - expect_equivalent( - trans_action(idf, "RunPeriod", - insert = list(c(`Start Year` = 4)), - insert = list(c(`End Year` = 7)) - ), - data.table( - id = rep(8L, 13), - name = rep(NA_character_, 13), - class = rep("RunPeriod", 13), - index = 1:13, - field = c("Name", "Begin Month", "Begin Day of Month", "Start Year", - "End Month", "End Day of Month", "End Year", - "Day of Week for Start Day", "Use Weather File Holidays and Special Days", - "Use Weather File Daylight Saving Period", "Apply Weekend Holiday Rule", - "Use Weather File Rain Indicators", "Use Weather File Snow Indicators" - ), - value = c(NA_character_, "1", "1", NA_character_, "12", "31", NA_character_, - "Tuesday", "Yes", "Yes", "No", "Yes", "Yes" - ) - ) - ) - # }}} - - # preprocess {{{ - expect_silent(new_idf <- trans_preprocess(idf, 8.9, "Construction")) - expect_equivalent(new_idf$version(), numeric_version("8.9.0")) - expect_false(new_idf$is_valid_class("Construction")) - expect_false(._get_private(new_idf)$m_log$uuid == ._get_private(idf)$m_log$uuid) - # }}} - - # versions {{{ - expect_equivalent(trans_upper_versions(idf, 9.1, patch = TRUE), - numeric_version(c("8.8.0", "8.9.0", "9.0.0", "9.0.1", "9.1.0")) - ) - expect_equivalent(trans_upper_versions(idf, 9.1), - numeric_version(c("8.8.0", "8.9.0", "9.0.0", "9.1.0")) - ) - # }}} - - # transition functions {{{ - expect_equivalent( - trans_fun_names(c("8.8.0", "8.9.0", "9.0.1", "9.1.0")), - c("f880t890", "f890t900", "f900t910") - ) - # }}} -}) - -test_that("Transition", { - skip_on_cran() - # EnergyPlus v9.1 failed to install on Linux - skip_on_travis() - if (!is_avail_eplus(9.2)) install_eplus(9.2) - eplusr_option(verbose_info = FALSE) - - # suppress build tag missing warnings - suppressWarnings(use_idd(7.2)) - suppressWarnings(use_idd(8.0)) - suppressWarnings(use_idd(8.1)) - - # basic workflow {{{ - idf <- temp_idf(7.2) - expect_error(transition(idf, 7.3), class = "error_not_idd_ver") - expect_silent(res <- transition(idf, 8.0)) - expect_silent(res <- transition(idf, 8.0, keep_all = TRUE)) - expect_equal(names(res), c("7.2", "8.0")) - expect_silent(res <- transition(idf, 8.0, save = TRUE, dir = file.path(tempdir(), "eplusr"), keep_all = TRUE)) - expect_equal(sapply(res, function (idf) basename(idf$path())), - c("7.2" = paste0(prefix(idf), "V720.idf"), - "8.0" = paste0(prefix(idf), "V800.idf")) - ) - expect_true(all(file.exists(file.path(tempdir(), "eplusr", paste0(tools::file_path_sans_ext(basename(idf$path())), c("V720.idf", "V800.idf")))))) - expect_silent(res_eplus <- version_updater(idf, 8.0, dir = file.path(tempdir(), "ep"), keep_all = TRUE)) - expect_identical(lapply(res, content), lapply(res_eplus, content)) - - # can handle newly added extensible fields - expect_silent(idf <- temp_idf(7.2, "Refrigeration:CompressorList" = list("a", "b", "c", "d", "e", "f"))) - expect_silent(transition(idf, 8.0)) - - # can handle newly added extensible fields that are added during transition - expect_silent(idf <- temp_idf(7.2)) - expect_silent(without_checking(idf$add(Branch = as.list(seq.int(60)), .all = TRUE))) - expect_silent(idf$save(overwrite = TRUE)) - expect_length(without_checking(transition(idf, 8.0))$Branch$`1`$value(), 63) - - # can preserve object comment - expect_silent(idf <- temp_idf(8.5, - "ZoneHVAC:EquipmentList" = list("a", .comment = "comment"), - "Daylighting:Controls" = list(.comment = "comment2"), - "Output:Variable" = list(.comment = "comment1") - )) - expect_silent(idf <- transition(idf, 8.6)) - expect_equal(lapply(idf$object_id(), function (id) idf$object(id)$comment()), - list( - Version = NULL, - `Daylighting:Controls` = "comment2", - `Daylighting:ReferencePoint` = "comment2", - `ZoneHVAC:EquipmentList` = "comment", - `Output:Variable` = "comment1" - ) - ) - - # can remove empty lines - expect_silent( - idf <- transition(temp_idf(7.2, - Branch = list("a", 0, "a", "a", "a", "a", "a", "a", "a"), - Branch = list("b", 0, "b", "b") - ), 8.0) - ) - expect_equal(nrow(idf$object("a")$to_table()), 13L) - expect_equal(nrow(idf$object("b")$to_table()), 8L) - # }}} - # v7.2 --> v8.0 {{{ - # can handle forkeq variables - expect_warning(idf <- transition(ver = 8, - idf = temp_idf(7.2, - Chiller_Electric_EIR = list("chiller"), - ChillerHeater_Absorption_DirectFired = list("heater"), - Output_Variable = list("*", "Chiller Diesel Consumption") - ) - ), class = "warning_trans_720_800") - expect_equal( - idf$to_table(class = "Output:Variable")[index == 2L, value], - c("Chiller Diesel Energy", "Chiller Heater Diesel Energy") - ) - - # can handle confd nodal temperature from v7.2 to v8.0 - idf <- transition(temp_idf(7.2, Output_Variable = list("*", "condfd nodal temperature")), 8) - expect_equal( - idf$to_table(class = "Output:Variable")[index == 2L, value], - paste("CondFD Surface Temperature Node", 1:10) - ) - - expect_identical_transition(7.2, 8.0, - .exclude = list(class = c( - # IDFVersionUpdater reports one less vertex which is incorrect - "BuildingSurface:Detailed", - # IDFVersionUpdater reports different order if include this - "HeatExchanger:WatersideEconomizer" - )), - .report_vars = FALSE - ) - - expect_identical_transition(7.2, 8.0, - "BuildingSurface:Detailed" = list( - "surf", "wall", "const", "zone", - "outdoors", NULL, "sunexposed", "windexposed", 0.5, - 3, 1, 1, 1, 2, 2, 2, 3, 3, 3 - ), - "HeatExchanger:WatersideEconomizer" = list(), - .report_vars = FALSE - ) - # }}} - # v8.0 --> v8.1 {{{ - expect_identical_transition(8.0, 8.1, - # IDFVersionUpdater will create one `Any Number` schedule type for every - # HVACTemplate:* instead of only creating only once - .exclude = list(post_class = "ScheduleTypeLimits"), - # IDFVersionUpdater only reports fields that meet the \min-fields - # requirement for v8.0 but not v8.1 - .less_length = c( - "HVACTemplate:Zone:PTAC", - "HVACTemplate:Zone:PTHP", - "HVACTemplate:Zone:WaterToAirHeatPump", - "HVACTemplate:System:Unitary", - "HVACTemplate:System:UnitaryHeatPump:AirToAir" - ) - ) - - # can add Any Number ScheduleTypeLimits - trans <- get_both_trans(8.0, 8.1, "HVACTemplate:System:UnitaryHeatPump:AirToAir" = list()) - expect_equal(trans$eplusr$class_name(), trans$energyplus$class_name()) - expect_equal( - trans$eplusr$to_string(class = c("ScheduleTypeLimits", "Schedule:Constant")), - trans$energyplus$to_string(class = c("ScheduleTypeLimits", "Schedule:Constant")) - ) - # }}} - # v8.1 --> v8.2 {{{ - # IDFVersionUpdater fails to update variable names - expect_identical_transition(8.1, 8.2, .report_vars = FALSE) - # }}} - # v8.2 --> v8.3 {{{ - # IDFVersionUpdater truncates number at 5 digits but R round at 5 digits - expect_identical_transition(8.2, 8.3) - - # can hanle min-fields requirement update - expect_silent(idf <- transition(temp_idf(8.2, `Sizing:System` = list()), 8.3)) - expect_length(idf$Sizing_System[[1L]]$value(), use_idd(8.3)$Sizing_System$min_fields()) - # }}} - # v8.3 --> v8.4 {{{ - expect_identical_transition(8.3, 8.4, - .exclude = list( - class = c( - # will change the object order if include this - "PipingSystem:Underground:Domain", - # IDFVersionUpdater fails to update variable names for class - # "Meter:CustomDecrement" - "Meter:CustomDecrement" - ) - ), - .ignore_case = list( - # IDFVersionUpdater changes this field into upper case unnecessarily - "WaterHeater:HeatPump:PumpedCondenser" = 21L - ), - .less_length = list( - # IDFVersionUpdater did not output all fields - "WaterHeater:HeatPump:PumpedCondenser" = 36L - ), - .report_vars = FALSE - ) - # }}} - # v8.4 --> v8.5 {{{ - # IDFVersionUpdater fails to update variable names - expect_identical_transition(8.4, 8.5, .report_vars = FALSE) - # }}} - # v8.5 --> v8.6 {{{ - # IDFVersionUpdater fails to update variable names - expect_identical_transition(8.5, 8.6, - .exclude = list( - # IDFVersionUpdater fails to delete variable names - class = c("Output:Table:Monthly", "Meter:Custom", "Meter:CustomDecrement") - ), - .ignore_field = list( - # IDFVersionUpdater alway adds defaults for `Fraction of Zone - # Controlled by Reference Point 1` and `Illuminance Setpoint at - # Reference Point - # 1 {lux}`, even there is no matched reference point - "Daylighting:Controls" = c(15L, 16L) - ), - .report_vars = FALSE, .tolerance = 1e-5 - ) - expect_silent(idf <- transition(temp_idf(8.5, Branch = list("branch", 0, "curve", "type", "name", "in", "out")), 8.6)) - expect_equivalent(idf$Branch$branch$value(), list("branch", "curve", "type", "name", "in", "out")) - - # can replace all Coil:Heating:Gas to Coil:Heating:Fuel - expect_silent(idf <- transition(temp_idf(8.5, "Branch" = list("branch", 0, "curve", "Coil:Heating:Gas", "gas")), 8.6)) - expect_equal(idf$Branch$branch$value(3, simplify = TRUE), "Coil:Heating:Fuel") - - # can handle 2 ref points - expect_silent(idf <- transition(temp_idf(8.5, "Daylighting:Controls" = list("zone", 2)), 8.6)) - expect_equal(idf$object_num("Daylighting:ReferencePoint"), 2L) - # }}} - # v8.6 --> 8.7{{{ - expect_identical_transition(8.6, 8.7) - # }}} - # v8.7 --> 8.8 {{{ - expect_identical_transition(8.7, 8.8) - # }}} - # v8.7 --> v8.8 {{{ - expect_identical_transition(8.7, 8.8) - # }}} - # v8.8 --> v8.9 {{{ - expect_identical_transition(8.8, 8.9, - # IDFVersionUpdater fails to rename variable names - .report_vars = FALSE - ) - # }}} - # v8.9 --> v9.0 {{{ - # include both `RunPeriod` and `RunPeriod:CustomRange` will change the - # output object order - expect_identical_transition(8.9, 9.0, .exclude = list(class = "RunPeriod:CustomRange")) - expect_identical_transition(8.9, 9.0, "RunPeriod" = list(), .report_vars = FALSE) - # can remove shading control that is not used by any zone - expect_identical_transition(8.9, 9.0, "WindowProperty:ShadingControl" = list(), .report_vars = FALSE) - # }}} - # v9.0 --> v9.1 {{{ - expect_identical_transition(9.0, 9.1) - # }}} - # v9.1 --> v9.2 {{{ - expect_identical_transition(9.1, 9.2, - .ignore_field = list( - # See https://github.com/NREL/EnergyPlus/issues/7560 - "Table:Lookup" = 3L - ) - ) - # }}} -}) From a1f8d2a8249592be1acef90261e90e9e3748f1aa Mon Sep 17 00:00:00 2001 From: Hongyuan Jia Date: Sat, 25 Jul 2020 19:39:17 +0800 Subject: [PATCH 26/43] [refactor] Refactor Epw class --- DESCRIPTION | 14 +- NAMESPACE | 6 + R/assert.R | 305 +++ R/epw.R | 668 ++++-- R/iddobj.R | 2 +- R/idf.R | 2 +- R/idfobj.R | 2 +- R/impl-epw.R | 3578 ++++++++++++-------------------- R/impl-idd.R | 17 +- R/impl-idf.R | 166 +- R/impl.R | 19 +- R/options.R | 1 + R/parse.R | 120 +- R/units.R | 7 +- R/validate.R | 188 +- inst/extdata/epw.idd | 904 ++++++++ man/Epw.Rd | 105 +- man/Idf.Rd | 2 +- man/expand_idf_dots_value.Rd | 9 +- man/get_idf_table.Rd | 104 + man/standardize_idf_value.Rd | 43 + man/validate_objects.Rd | 72 + tests/testthat/test-assert.R | 98 + tests/testthat/test-epw.R | 492 +++++ tests/testthat/test-format.R | 435 ++++ tests/testthat/test-group.R | 183 ++ tests/testthat/test-impl-epw.R | 506 +++++ tests/testthat/test-impl-idf.R | 60 +- tests/testthat/test-install.R | 13 + tests/testthat/test-job.R | 116 ++ tests/testthat/test-param.R | 281 +++ tests/testthat/test-parse.R | 109 + tests/testthat/test-rdd.R | 58 + tests/testthat/test-reload.R | 83 + tests/testthat/test-sql.R | 164 ++ tests/testthat/test-units.R | 124 ++ tests/testthat/test-validate.R | 256 +++ tests/testthat/test_epw.R | 220 -- 38 files changed, 6750 insertions(+), 2782 deletions(-) create mode 100644 R/assert.R create mode 100644 inst/extdata/epw.idd create mode 100644 man/get_idf_table.Rd create mode 100644 man/standardize_idf_value.Rd create mode 100644 man/validate_objects.Rd create mode 100644 tests/testthat/test-assert.R create mode 100644 tests/testthat/test-epw.R create mode 100644 tests/testthat/test-format.R create mode 100644 tests/testthat/test-group.R create mode 100644 tests/testthat/test-impl-epw.R create mode 100644 tests/testthat/test-install.R create mode 100644 tests/testthat/test-job.R create mode 100644 tests/testthat/test-param.R create mode 100644 tests/testthat/test-rdd.R create mode 100644 tests/testthat/test-reload.R create mode 100644 tests/testthat/test-sql.R create mode 100644 tests/testthat/test-units.R create mode 100644 tests/testthat/test-validate.R delete mode 100644 tests/testthat/test_epw.R diff --git a/DESCRIPTION b/DESCRIPTION index f9c6e51f2..8660441da 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -39,7 +39,7 @@ Suggests: pkgdown, rgl, rmarkdown, - testthat + testthat (>= 2.1.0) VignetteBuilder: knitr Encoding: UTF-8 @@ -51,25 +51,25 @@ SystemRequirements: EnergyPlus (>= 8.3, optional) (); udunits2 Collate: 'constants.R' - 'assertions.R' + 'assert.R' 'diagram.R' 'eplusr.R' 'utils.R' 'impl.R' 'parse.R' 'impl-epw.R' + 'impl-idd.R' + 'impl-idf.R' + 'idf.R' + 'idd.R' 'epw.R' 'err.R' 'format.R' 'geometry.R' 'group.R' - 'impl-idd.R' - 'idd.R' 'iddobj.R' - 'impl-idf.R' - 'idf.R' 'impl-idfobj.R' - 'idf_object.R' + 'idfobj.R' 'impl-iddobj.R' 'impl-sql.R' 'install.R' diff --git a/NAMESPACE b/NAMESPACE index 924fb78c4..dcacf42bb 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -48,6 +48,7 @@ S3method(format,Idf) S3method(format,IdfObject) S3method(format,Range) S3method(print,EpwDate) +S3method(print,EpwValidity) S3method(print,ErrFile) S3method(print,IddFieldPossible) S3method(print,IddRelation) @@ -117,6 +118,7 @@ export(get_idd_relation) export(get_idf_node_relation) export(get_idf_object) export(get_idf_relation) +export(get_idf_table) export(get_idf_value) export(get_object_info) export(get_priv_env) @@ -157,10 +159,12 @@ export(rename_idf_object) export(run_idf) export(run_multi) export(set_idf_object) +export(standardize_idf_value) export(transition) export(unique_idf_object) export(use_eplus) export(use_idd) +export(validate_objects) export(version_updater) export(with_option) export(with_silent) @@ -186,6 +190,7 @@ importFrom(checkmate,assert_file) importFrom(checkmate,assert_file_exists) importFrom(checkmate,assert_flag) importFrom(checkmate,assert_function) +importFrom(checkmate,assert_int) importFrom(checkmate,assert_integer) importFrom(checkmate,assert_integerish) importFrom(checkmate,assert_list) @@ -208,6 +213,7 @@ importFrom(checkmate,qtestr) importFrom(checkmate,test_character) importFrom(checkmate,test_choice) importFrom(checkmate,test_class) +importFrom(checkmate,test_count) importFrom(checkmate,test_file_exists) importFrom(checkmate,test_flag) importFrom(checkmate,test_integerish) diff --git a/R/assert.R b/R/assert.R new file mode 100644 index 000000000..10ce43f37 --- /dev/null +++ b/R/assert.R @@ -0,0 +1,305 @@ +#' @importFrom tools file_ext +#' @importFrom checkmate test_class test_r6 +#' @include constants.R +NULL + +# convert_to_ver {{{ +convert_to_eplus_ver <- function (ver, strict = FALSE, all_ver = c(ALL_EPLUS_VER, names(.globals$eplus)), max = TRUE, verbose = FALSE) { + ver <- standardize_ver(ver, strict = strict, complete = FALSE) + res <- lapply(ver, match_minor_ver, all_ver = all_ver, type = "eplus", max = max, verbose = verbose) + if (max) do.call(c, res) else res +} +convert_to_idd_ver <- function (ver, strict = FALSE, all_ver = c(ALL_IDD_VER, names(.globals$idd)), max = TRUE, verbose = FALSE) { + ver <- standardize_ver(ver, strict = strict, complete = FALSE) + res <- lapply(ver, match_minor_ver, all_ver = all_ver, type = "idd", max = max, verbose = verbose) + if (max) do.call(c, res) else res +} +# }}} + +#' Check for Idd, Idf and Epw objects +#' +#' These functions test if input is a valid object of Idd, Idf, Epw and other +#' main classes. +#' +#' `is_eplus_ver()` returns `TRUE` if input is a valid EnergyPlus version. +#' +#' `is_idd_ver()` returns `TRUE` if input is a valid EnergyPlus IDD version. +#' +#' `is_eplus_path()` returns `TRUE` if input path is a valid EnergyPlus path, +#' i.e. a path where there is an `energyplus` executable and an `Energy+.idd` +#' file. +#' +#' `is_idd()` returns `TRUE` if input is an Idd object. +#' +#' `is_idf()` returns `TRUE` if input is an Idf object. +#' +#' `is_iddobject()` returns `TRUE` if input is an IddObject object. +#' +#' `is_idfobject()` returns `TRUE` if input is an IdfObject object. +#' +#' `is_epw()` returns `TRUE` if input is an Epw object. +#' +#' @param ver A character or numeric vector with suitable numeric version +#' strings. +#' @param strict If `FALSE`, `ver` can be a special string "latest" which +#' represents the latest version. +#' @return A logical vector. +#' @rdname assertion +#' @export +#' @examples +#' is_eplus_ver(8.8) +#' is_eplus_ver(8.0) +#' is_eplus_ver("latest", strict = FALSE) +#' +#' is_idd_ver("9.0.1") +#' is_idd_ver("8.0.1") +#' +#' is_eplus_path("C:/EnergyPlusV9-0-0") +#' is_eplus_path("/usr/local/EnergyPlus-9-0-1") +#' +#' is_idd(use_idd(8.8, download = "auto")) +#' +#' idf <- read_idf(system.file("extdata/1ZoneUncontrolled.idf", package = "eplusr"), +#' idd = use_idd(8.8, download = "auto")) +#' is_idf(idf) +#' +#' is_iddobject(idd_object(8.8, "Version")) +#' +#' is_idfobject(idf_object(idf, 1)) +#' +#' \dontrun{ +#' is_epw(read_epw(download_weather("los angeles.*tmy3", type = "epw", ask = FALSE, max_match = 1))) +#' } +# is_eplus_ver {{{ +is_eplus_ver <- function (ver, strict = FALSE) { + !is.na(convert_to_eplus_ver(ver, strict)) +} +# }}} + +#' @rdname assertion +#' @export +# is_idd_ver {{{ +is_idd_ver <- function (ver, strict = FALSE) { + !is.na(convert_to_eplus_ver(ver, strict)) +} +# }}} + +#' @param path A path to test. +#' @rdname assertion +#' @export +# is_eplus_path {{{ +is_eplus_path <- function (path) { + eplus <- paste0("energyplus", if (is_windows()) ".exe" else "") + eplus1 <- paste0("EnergyPlus", if (is_windows()) ".exe" else "") + # in case input is a numeric version + path <- as.character(path) + dir.exists(path) & + (file.exists(file.path(path, eplus)) | file.exists(file.path(path, eplus1))) & + file.exists(file.path(path, "Energy+.idd")) +} +# }}} + +#' @param x An object to test. +#' @rdname assertion +#' @export +# is_idd {{{ +is_idd <- function (x) test_r6(x, "Idd") +# }}} + +#' @rdname assertion +#' @export +# is_idf {{{ +is_idf <- function (x) test_r6(x, "Idf") +# }}} + +#' @rdname assertion +#' @export +# is_iddobject {{{ +is_iddobject <- function (x) test_r6(x, "IddObject") +# }}} + +#' @rdname assertion +#' @export +# is_idfobject {{{ +is_idfobject <- function (x) test_r6(x, "IdfObject") +# }}} + +#' @rdname assertion +#' @export +# is_epw {{{ +is_epw <- function (x) test_r6(x, "Epw") +# }}} + +# is_rdd {{{ +is_rdd <- function (x) checkmate::test_class(x, "RddFile") +is_mdd <- function (x) checkmate::test_class(x, "MddFile") +# }}} + +# is_range {{{ +is_range <- function (x) { + checkmate::test_list(x, len = 4L) && checkmate::test_class(x, "Range") +} +# }}} + +# assert_strint {{{ +check_strint <- function (x, len = NULL, min.len = NULL, max.len = NULL, names = NULL, null.ok = FALSE) { + chk <- checkmate::check_character(x, any.missing = FALSE, len = len, min.len = max.len, names = names, null.ok = null.ok) + if (isTRUE(chk)) TRUE else chk + num <- suppressWarnings(as.double(x)) + chk <- checkmate::check_integerish(num, any.missing = FALSE) + if (isTRUE(chk)) TRUE + else "Must be a vector with integer-coercible format" +} +test_strint <- checkmate::makeTestFunction(check_strint) +assert_strint <- function (x, len = NULL, coerce = FALSE, .var.name = checkmate::vname(x), add = NULL) { + res <- check_strint(x) + checkmate::makeAssertion(x, res, .var.name, add) + if (isTRUE(coerce)) storage.mode(x) <- "integer" + x +} +# }}} +# assert_length {{{ +check_length <- function (x, len, step = NULL) { + if (is_range(len)) { + res <- if (in_range(length(x), len)) TRUE + else paste0("Must have length in range ", len, ", but has length ", length(x)) + } else if (checkmate::test_count(len)){ + if (is.null(step)) { + length(x) == len + res <- if (length(x) == len) TRUE + else paste0("Must have length ", len, ", but has length ", length(x)) + } else { + if (!checkmate::test_count(step, positive = TRUE)) stop("'step' should be either NULL or an integer") + res <- if (length(x) >= len && ((length(x) - len) %% step == 0L)) TRUE + else paste0("Must have length of pattern '", len, " + " , step, " x N'") + } + } else if (checkmate::test_integerish(len, lower = 0L)) { + if (!is.null(step)) { + stop("'step' should not be provided when 'len' is an integer vector") + } + res <- if (length(x) %in% len) TRUE + else paste0("Must have length ", collapse(len, or = TRUE), ", but has length ", length(x)) + } else { + stop("'len' should be either a range or an integer vector") + } +} +assert_length <- checkmate::makeAssertionFunction(check_length) +# }}} +# assert_same_len {{{ +check_same_len <- function (x, y) { + if (NROW(x) == NROW(y)) TRUE else "Must have same length" +} +test_same_len <- checkmate::makeTestFunction(check_same_len) +assert_same_len <- function(x, y, .var.name = paste(checkmate::vname(x), "and", checkmate::vname(y)), add = NULL) { + res <- check_same_len(x, y) + checkmate::makeAssertion(x, res, .var.name, add) +} +# }}} +# in_range {{{ +in_range <- function (x, range) { + if (range$lower_incbounds == range$upper_incbounds) { + between(x, range$minimum, range$maximum, range$lower_incbounds) + } else { + if (range$lower_incbounds) { + x >= range$minimum & x < range$maximum + } else { + x > range$minimum & x <= range$maximum + } + } +} +# }}} +# check_range {{{ +check_range <- function (x, range) { + res <- in_range(x, range) + if (all(res)) TRUE + else paste("Must in range", range) +} +# }}} +# is_choice {{{ +is_choice <- function (x, choices) { + is.character(x) & stri_trans_tolower(x) %chin% stri_trans_tolower(choices) +} +# on_fail(is_choice) <- function (call, env) { +# paste0(deparse(call$x), " should be one of ", collapse(eval(call$choices, env))) +# } +# }}} + +# has_names {{{ +has_names <- function(x, names) names %chin% names(x) +# }}} +# has_ext {{{ +has_ext <- function (path, ext) tolower(tools::file_ext(path)) %chin% ext +# }}} + +assert_epwdate <- function (x, len = NULL, null.ok = FALSE, .var.name = checkmate::vname(x), add = NULL) { + x <- assert_vector(x, len = len, null.ok = null.ok) + if (is.null(x)) return(x) + x <- epw_data(x) + res <- if (!checkmate::anyMissing(x)) TRUE + else "Must be a vector of valid EPW date specifications" + makeAssertion(x, res, .var.name, add) +} +assert_wday <- function (x, len = NULL, null.ok = FALSE, .var.name = checkmate::vname(x), add = NULL) { + x <- assert_vector(x, len = len, null.ok = null.ok) + if (is.null(x)) return(x) + x <- get_epw_wday(x) + res <- if (!checkmate::anyMissing(x)) TRUE + else "Must be a vector of valid EPW day of week specifications" + makeAssertion(x, res, .var.name, add) +} + +# is_epwdate {{{ +is_epwdate <- function (x) { + length(x) == 1L && !is.na(epw_date(x)) +} +# }}} +# not_epwdate_realyear {{{ +not_epwdate_realyear <- function (x, scalar = FALSE, zero = TRUE) { + d <- epw_date(x) + r <- !is.na(d) & get_epwdate_type(d) != 3L + if (!zero) r <- r & get_epwdate_type(d) != 0L + if (scalar) { + length(x) == 1L && all(r) + } else { + r + } +} +# on_fail(not_epwdate_realyear) <- function (call, env) { +# s <- eval(call$scalar, env) +# if (!is.null(s) && s) { +# paste0(deparse(call$x), " should not be EPW real-year date specification.") +# } else { +# paste0(deparse(call$x), " should not contain any EPW real-year date specification.") +# } +# } +# }}} +# not_epwdate_weekday {{{ +not_epwdate_weekday <- function (x, scalar = FALSE, zero = TRUE) { + d <- epw_date(x) + r <- !is.na(d) & get_epwdate_type(d) != 5L + if (!zero) r <- r & get_epwdate_type(d) != 0L + if (scalar) { + length(x) == 1L && all(r) + } else { + r + } +} +# on_fail(not_epwdate_weekday) <- function (call, env) { +# s <- eval(call$scalar, env) +# if (!is.null(s) && s) { +# paste0(deparse(call$x), " is not valid EPW Julian day or Month/Day date specification.") +# } else { +# paste0(deparse(call$x), " contains invalid EPW Julian day or Month/Day date specification.") +# } +# } +# }}} + +# is_windows {{{ +is_windows <- function () .Platform$OS.type == 'windows' +# }}} +# is_linux {{{ +is_linux <- function () Sys.info()["sysname"] == "Linux" +# }}} +# is_macos {{{ +is_macos <- function () Sys.info()["sysname"] == "Darwin" +# }}} diff --git a/R/epw.R b/R/epw.R index 2f2820e3c..c8c578842 100644 --- a/R/epw.R +++ b/R/epw.R @@ -3,9 +3,49 @@ #' @importFrom cli rule cat_rule #' @importFrom R6 R6Class #' @importFrom utils menu +#' @importFrom checkmate assert_list assert_names assert_flag +#' @include idd.R +#' @include idf.R #' @include impl-epw.R NULL +# EpwIdd {{{ +EpwIdd <- R6::R6Class(classname = "EpwIdd", cloneable = FALSE, lock_objects = FALSE, + inherit = Idd, + public = list( + initialize = function (path) { + # add a uuid + private$m_log <- new.env(hash = FALSE, parent = emptyenv()) + private$m_log$uuid <- unique_id() + + idd_file <- parse_idd_file(path, epw = TRUE) + private$m_version <- idd_file$version + private$m_build <- idd_file$build + + private$m_idd_env <- list2env( + idd_file[!names(idd_file) %in% c("version", "build")], parent = emptyenv() + ) + + # add current idd to .globals + .globals$epw <- self + }, + + print = function () + epwidd_print(self, private) + ) +) +# }}} +# epwidd_print {{{ +epwidd_print <- function (self, private) { + cli::cat_rule("EnergyPlus Weather File Data Dictionary") + cli::cat_line("* ", c( + paste0("Version", ": ", private$m_version), + paste0("Build", ": ", private$m_build), + paste0("Total Class", ": ", nrow(private$m_idd_env$class)) + )) +} +# }}} + #' Read, and modify an EnergyPlus Weather File (EPW) #' #' Reading an EPW file starts with function [read_epw()], which parses an EPW @@ -83,7 +123,7 @@ Epw <- R6::R6Class(classname = "Epw", #' #' @details #' It takes an EnergyPlus Weather File (EPW) as input and returns an - #' `EPW` object. + #' `Epw` object. #' #' @param path Either a path, a connection, or literal data (either a #' single string or a raw vector) to an EnergyPlus Weather File @@ -116,16 +156,19 @@ Epw <- R6::R6Class(classname = "Epw", #' } #' initialize = function (path, warning = FALSE) { - if (is_string(path) && file.exists(path)) { + if (checkmate::test_file_exists(path, "r")) { private$m_path <- normalizePath(path) } - epw_file <- parse_epw_file(path, warning = warning) + private$m_idd <- get_epw_idd() + + epw_file <- parse_epw_file(path, warning = warning, idd = private$m_idd) - private$m_header <- epw_file$header + private$m_idf_env <- list2env(epw_file$header, parent = emptyenv()) private$m_data <- epw_file$data private$m_log <- new.env(hash = FALSE, parent = emptyenv()) + private$m_log$matched <- epw_file$matched private$m_log$unit <- FALSE private$m_log$miss_na <- FALSE private$m_log$range_na <- FALSE @@ -136,6 +179,8 @@ Epw <- R6::R6Class(classname = "Epw", private$m_log$purged <- FALSE private$m_log$unsaved <- FALSE private$m_log$uuid <- unique_id() + private$m_log$order <- private$m_idf_env$object[, list(object_id)][ + , object_order := 0L] }, # }}} @@ -160,6 +205,37 @@ Epw <- R6::R6Class(classname = "Epw", path = function () epw_path(self, private), # }}} + # definition {{{ + #' @description + #' Get the [IddObject] object for specified EPW class. + #' + #' @details + #' `$definition()` returns an [IddObject] of given EPW class. [IddObject] + #' contains all data used for parsing that EPW class. + #' + #' Currently, all supported EPW classes are: + #' + #' * `LOCATION` + #' * `DESIGN CONDITIONS` + #' * `TYPICAL/EXTREME PERIODS` + #' * `GROUND TEMPERATURES` + #' * `HOLIDAYS/DAYLIGHT SAVINGS` + #' * `COMMENTS 1` + #' * `COMMENTS 2` + #' * `DATA PERIODS` + #' * `WEATHER DATA` + #' + #' @param class A single string. + #' + #' @examples + #' \dontrun{ + #' # get path + #' epw$definition("LOCATION") + #' } + #' + definition = function (class) + epw_definition(self, private, class), + # }}} # }}} # HEADER {{{ @@ -220,7 +296,7 @@ Epw <- R6::R6Class(classname = "Epw", #' * `source`: A string of source field #' * `heating`: A list, usually of length 16, of the heading design conditions #' * `cooling`: A list, usually of length 32, of the cooling design conditions - #' * `extreme`: A list, usually of length 16, of the extreme design conditions + #' * `extremes`: A list, usually of length 16, of the extreme design conditions #' #' For the meaning of each element, please see ASHRAE Handbook of Fundamentals. #' @@ -270,17 +346,17 @@ Epw <- R6::R6Class(classname = "Epw", #' #' @details #' `$ground_temperature()` returns the parsed values of `GROUND TEMPERATURE` - #' header in a [data.table][data.table::data.table()] format with 7 columns: + #' header in a [data.table][data.table::data.table()] format with 17 columns: #' #' * `index`: Integer type. The index of ground temperature record #' * `depth`: Numeric type. The depth of the ground temperature is measured - #' * `month`: Integer type. The month when the ground temperature is measured #' * `soil_conductivity`: Numeric type. The soil conductivity at measured depth #' * `soil_density`: Numeric type. The soil density at measured depth #' * `soil_specific heat`: Numeric type. The soil specific heat at measured depth - #' * `temperature`: Numeric type. The measured group temperature + #' * `January` to `December`: Numeric type. The measured group + #' temperature for each month. #' - #' @return A [data.table::data.table()] with 7 columns. + #' @return A [data.table::data.table()] with 17 columns. #' #' @examples #' \dontrun{ @@ -477,7 +553,7 @@ Epw <- R6::R6Class(classname = "Epw", #' #' * `index`: Integer type. The index of data period. #' * `name`: Character type. The name of data period. - #' * `start_day_of_week`: Integer type. The start day of week of data period. + #' * `start_day_of_week`: Character type. The start day of week of data period. #' * `start_day`: Date (EpwDate) type. The start day of data period. #' * `end_day`: Date (EpwDate) type. The end day of data period. #' @@ -657,6 +733,9 @@ Epw <- R6::R6Class(classname = "Epw", #' the newly created `datetime` column using `start_year`. If #' `FALSE`, original year data in the `Epw` object is kept. #' Default: `FALSE`. + #' @param line If `TRUE`, a column named `line` is prepended indicating + #' the line numbers where data occur in the actual EPW file. + #' Default: `FALSE`. #' #' @return A [data.table::data.table()] of 36 columns. #' @@ -677,8 +756,8 @@ Epw <- R6::R6Class(classname = "Epw", #' attributes(epw$data(tz = "Etc/GMT+8")$datetime) #' } #' - data = function (period = 1L, start_year = NULL, align_wday = TRUE, tz = "UTC", update = FALSE) - epw_data(self, private, period, start_year, align_wday, tz, update), + data = function (period = 1L, start_year = NULL, align_wday = TRUE, tz = "UTC", update = FALSE, line = FALSE) + epw_data(self, private, period, start_year, align_wday, tz, update, line), # }}} # abnormal_data {{{ @@ -702,8 +781,8 @@ Epw <- R6::R6Class(classname = "Epw", #' described above. #' @param cols A character vector identifying what data columns, i.e. #' all columns except `datetime`, `year`, `month`, `day`, `hour` - #' and `minute`, to search abnormal values. If `NULL`, all data - #' columns are used. Default: `NULL`. + #' `minute`, and character columns, to search abnormal values. If + #' `NULL`, all data columns are used. Default: `NULL`. #' @param keep_all If `TRUE`, all columns are returned. If `FALSE`, only #' `line`, `datetime`, `year`, `month`, `day`, `hour` and #' `minute`, together with columns specified in `cols` are @@ -792,11 +871,6 @@ Epw <- R6::R6Class(classname = "Epw", #' \href{../../eplusr/html/Epw.html#method-abnormal_data}{\code{$abnormal_data()}} #' may be different after calling `$make_na()`. #' - #' @param period A positive integer vector identifying the data period - #' indexes. Data periods information can be obtained using - #' \href{../../eplusr/html/Epw.html#method-period}{\code{$period()}} - #' described above. If `NULL`, all data periods are included. - #' Default: `NULL`. #' @param missing If `TRUE`, missing values are included. Default: #' `FALSE`. #' @param out_of_range If `TRUE`, out-of-range values are included. @@ -812,8 +886,8 @@ Epw <- R6::R6Class(classname = "Epw", #' summary(epw$data()$liquid_precip_rate) #' } #' - make_na = function (period = NULL, missing = FALSE, out_of_range = FALSE) - epw_make_na(self, private, period, missing, out_of_range), + make_na = function (missing = FALSE, out_of_range = FALSE) + epw_make_na(self, private, missing, out_of_range), # }}} # fill_abnormal {{{ @@ -844,11 +918,6 @@ Epw <- R6::R6Class(classname = "Epw", #' \href{../../eplusr/html/Epw.html#method-abnormal_data}{\code{$abnormal_data()}} #' may be different after calling `$fill_abnormal()`. #' - #' @param period A positive integer vector identifying the data period - #' indexes. Data periods information can be obtained using - #' \href{../../eplusr/html/Epw.html#method-period}{\code{$period()}} - #' described above. If `NULL`, all data periods are included. - #' Default: `NULL`. #' @param missing If `TRUE`, missing values are included. Default: #' `FALSE`. #' @param out_of_range If `TRUE`, out-of-range values are included. @@ -870,9 +939,8 @@ Epw <- R6::R6Class(classname = "Epw", #' summary(epw$data()$liquid_precip_rate) #' } #' - fill_abnormal = function (period = NULL, missing = FALSE, out_of_range = FALSE, - special = FALSE) - epw_fill_abnormal(self, private, period, missing, out_of_range, special), + fill_abnormal = function (missing = FALSE, out_of_range = FALSE, special = FALSE) + epw_fill_abnormal(self, private, missing, out_of_range, special), # }}} # add_unit {{{ @@ -995,7 +1063,7 @@ Epw <- R6::R6Class(classname = "Epw", #' existing data periods. #' * The date time of input data should not overlap with existing data #' periods. - #' * Input data should have all 29 weather data columns with right + #' * Input data should have all 29 weather data columns with correct #' types. The `year`, `month`, `day`, and `minute` column are not #' compulsory. They will be created according to values in the #' `datetime` column. Existing values will be overwritten. @@ -1109,6 +1177,7 @@ Epw <- R6::R6Class(classname = "Epw", # }}} # }}} + # SAVE {{{ # is_unsaved {{{ #' @description #' Check if there are unsaved changes in current `Epw` @@ -1157,6 +1226,7 @@ Epw <- R6::R6Class(classname = "Epw", save = function (path = NULL, overwrite = FALSE, purge = FALSE) epw_save(self, private, path, overwrite, purge), # }}} + # }}} # print {{{ #' @description @@ -1181,10 +1251,19 @@ Epw <- R6::R6Class(classname = "Epw", private = list( m_path = NULL, - m_header = NULL, + m_idd = NULL, + m_idf_env = NULL, m_data = NULL, m_log = NULL, + idd_env = function () { + get_priv_env(private$m_idd)$m_idd_env + }, + + idf_env = function () { + private$m_idf_env + }, + deep_clone = function (name, value) { epw_deep_clone(self, private, name, value) } @@ -1241,6 +1320,11 @@ epw_path <- function (self, private) { private$m_path } # }}} +# epw_definition {{{ +epw_definition <- function (self, private, class) { + IddObject$new(class, private$m_idd) +} +# }}} # epw_location {{{ epw_location <- function (self, private, city, state_province, country, data_source, @@ -1257,138 +1341,352 @@ epw_location <- function (self, private, if (!missing(time_zone)) l$time_zone <- time_zone if (!missing(elevation)) l$elevation <- elevation - if (!length(l)) return(private$m_header$location) + if (length(l)) { + idf_set(self, private, ..(EPW_CLASS$location) := l, .default = FALSE, .empty = TRUE) + } - private$m_header <- set_epw_location(private$m_header, l) - log_unsaved(private$m_log) - log_new_uuid(private$m_log) - private$m_header$location + parse_epw_header_location(private$idf_env()) } # }}} # epw_design_condition {{{ epw_design_condition <- function (self, private) { - copy(private$m_header$design) + # short names {{{ + nm <- c( + "n", # [2] int + "source", # [3] chr + "empty_separator", # [4] chr + "heating", # [5] chr + "coldest_month", # [6] int + "heating_db_99.6", # [7] dbl + "heating_db_99.0", # [8] dbl + "humidification_dp_99.6", # [9] dbl + "humidification_hr_99.6", #[10] dbl + "humidification_mcdb_99.6", #[11] dbl + "humidification_dp_99.0", #[12] dbl + "humidification_hr_99.0", #[13] dbl + "humidification_mcdb_99.0", #[14] dbl + "coldest_month_ws_0.4", #[15] dbl + "coldest_month_mcdb_0.4", #[16] dbl + "coldest_month_ws_1.0", #[17] dbl + "coldest_month_mcdb_1.0", #[18] dbl + "mcws_99.6_db", #[19] dbl + "pcwd_99.6_db", #[20] dbl + "cooling", #[21] chr + "hotest_month", #[22] int + "hotest_month_db_range", #[23] dbl + "cooling_db_0.4", #[24] dbl + "cooling_mcwb_0.4", #[25] dbl + "cooling_db_1.0", #[26] dbl + "cooling_mcwb_1.0", #[27] dbl + "cooling_db_2.0", #[28] dbl + "cooling_mcwb_2.0", #[29] dbl + "evaporation_wb_0.4", #[30] dbl + "evaporation_mcdb_0.4", #[31] dbl + "evaporation_wb_1.0", #[32] dbl + "evaporation_mcdb_1.0", #[33] dbl + "evaporation_wb_2.0", #[34] dbl + "evaporation_mcdb_2.0", #[35] dbl + "mcws_0.4_db", #[36] dbl + "pcwd_0.4_db", #[37] dbl + "dehumification_dp_0.4", #[38] dbl + "dehumification_hr_0.4", #[39] dbl + "dehumification_mcdb_0.4", #[40] dbl + "dehumification_dp_1.0", #[41] dbl + "dehumification_hr_1.0", #[42] dbl + "dehumification_mcdb_1.0", #[43] dbl + "dehumification_dp_2.0", #[44] dbl + "dehumification_hr_2.0", #[45] dbl + "dehumification_mcdb_2.0", #[46] dbl + "enthalpy_0.4", #[47] dbl + "mcdb_0.4", #[48] dbl + "enthalpy_1.0", #[49] dbl + "mcdb_1.0", #[50] dbl + "enthalpy_2.0", #[51] dbl + "mcdb_2.0", #[52] dbl + "hours_8_to_4_12.8_20.6", #[53] dbl + "extremes", #[54] chr + "extreme_annual_ws_1.0", #[55] dbl + "extreme_annual_ws_2.5", #[56] dbl + "extreme_annual_ws_5.0", #[57] dbl + "extreme_max_wb", #[58] dbl + "extreme_annual_db_mean_min", #[59] dbl + "extreme_annual_db_mean_max", #[60] dbl + "extreme_annual_db_sd_min", #[61] dbl + "extreme_annual_db_sd_max", #[62] dbl + "5_year_return_period_values_of_extreme_db_min", #[63] dbl + "5_year_return_period_values_of_extreme_db_max", #[64] dbl + "10_year_return_period_values_of_extreme_db_min", #[65] dbl + "10_year_return_period_values_of_extreme_db_max", #[66] dbl + "20_year_return_period_values_of_extreme_db_min", #[67] dbl + "20_year_return_period_values_of_extreme_db_max", #[68] dbl + "50_year_return_period_values_of_extreme_db_min", #[69] dbl + "50_year_return_period_values_of_extreme_db_max" #[70] dbl + ) + # }}} + val <- parse_epw_header_design(private$idf_env(), strict = TRUE)$value + setattr(val, "names", nm) + + list(source = val$source, + heating = val[5:19], + cooling = val[21:52], + extremes = val[53:69] + ) } # }}} # epw_typical_extreme_period {{{ epw_typical_extreme_period <- function (self, private) { - copy(private$m_header$typical) + parse_epw_header_typical(private$idf_env(), strict = TRUE) } # }}} # epw_ground_temperature {{{ epw_ground_temperature <- function (self, private) { - copy(private$m_header$ground) + parse_epw_header_ground(private$idf_env(), strict = TRUE) } # }}} # epw_holiday {{{ epw_holiday <- function (self, private, leapyear, dst, holiday) { if (missing(leapyear) && missing(dst) && missing(holiday)) { - copy(private$m_header$holiday) + return(parse_epw_header_holiday(private$idf_env())) } - private$m_header <- set_epw_holiday(private$m_header, leapyear, dst, holiday) - log_unsaved(private$m_log) - log_new_uuid(private$m_log) - copy(private$m_header$holiday) + hol <- parse_epw_header_holiday(private$idf_env()) + l <- list() + + if (!missing(leapyear)) { + assert_flag(leapyear) + l$"..1" <- if (leapyear) "Yes" else "No" + + period <- parse_epw_header_period(private$idf_env()) + + # note that parsed start and end day in data period can only be + # either md or ymd type + s <- period$period$start_day + e <- period$period$end_day + + # current is leap year but want to change to non-leap year + # for md type, it is ok to change only if that period does not cover + # Feb 29, e.g. [01/02, 02/28] + # for ymd type, if that period covers multiple years, e.g. + # [2007-01-01, 2009-01-01], there is a need to check 2008-02-28 + if (hol$leapyear & !leapyear) { + for (i in seq_along(s)) { + # in case ymd format that spans multiple years + feb29 <- lubridate::make_date(c(lubridate::year(s[i]) : lubridate::year(e[i])), 2, 29) + # for case [2007-01-01, 2009-01-01] + feb29 <- feb29[!is.na(feb29)] + + # if February exists in the data + if (any(s[i] <= feb29 & feb29 <= e[i])) { + abort(paste0("Failed to change leap year indicator to ", leapyear, ", ", + "because data period ", + period$period[i, paste0("#", index, " ", surround(name))], + " contains weather data of February 29th [", s[i], ", ", e[i], "]." + ), "epw_header") + } + } + + # current is non-leap year but want to change to leap year + # for md type, it is ok to change only if that period does not + # across Feb, e.g. [01/02, 02/28], [03/01, 12/31] + # for ymd type, it is always OK + } else if (!hol$leapyear & leapyear) { + is_md <- is_epwdate_type(s, "md") + if (any(is_md)) { + s_md <- s[is_md] + e_md <- e[is_md] + for (i in seq_along(s_md)) { + # in case ymd format that spans multiple years + feb28 <- lubridate::make_date(lubridate::year(s_md[i]), 2L, 28L) + + if (!all(e_md[i] <= feb28 | feb28 <= s_md[i])) { + abort(paste0("Failed to change leap year indicator to ", leapyear, ", ", + "because data period ", + period$period[is_md][i, paste0("#", index, " ", surround(name))], + " contains weather data of February 29th [", s_md[i], ", ", e_md[i], "]." + ), "epw_header") + } + } + } + } + } + + if (!missing(dst)) { + dst <- assert_vector(as.character(dst), len = 2L, .var.name = "Daylight saving time") + dst <- epw_date(dst) + + # make it possible for directly giving Date-Time object + if (any(is_epwdate_type(dst, "ymd"))) { + is_ymd <- is_epwdate_type(dst, "ymd") + dst[is_ymd] <- ymd_to_md(dst[is_ymd]) + } + + l$"Daylight Saving Start Day" <- format(dst[1]) + l$"Daylight Saving End Day" <- format(dst[2]) + } + + if (!missing(holiday)) { + assert_list(holiday, len = 2L) + assert_names(names(holiday), must.include = c("name", "day")) + + holiday <- as.list(unlist(data.table::transpose(as.data.table(holiday)))) + setattr(holiday, "names", paste0("..", 4 + seq_along(holiday))) + l <- c(l, holiday) + l$"Number of Holidays" <- length(holiday)/2L + } + + # store current values in case error occur in later procedures + obj <- get_idf_object(private$idd_env(), private$idf_env(), EPW_CLASS$holiday) + val <- get_idf_value(private$idd_env(), private$idf_env(), EPW_CLASS$holiday) + # store save status + unsaved <- private$m_log$unsaved + + idf_set(self, private, ..(EPW_CLASS$holiday) := l, .default = FALSE, .empty = TRUE) + + withCallingHandlers(parse_epw_header_holiday(private$idf_env()), + eplusr_warning_epw_header_num_field = function (w) invokeRestart("muffleWarning"), + eplusr_error_parse_epw_header = function (e) { + # restore header value + env <- private$idf_env() + env$object <- append_dt(env$object, obj, "object_id") + env$value <- append_dt(env$value, val, "object_id") + setorderv(env$object, "object_id") + setorderv(env$value, "object_id") + + # restore save status + private$m_log$unsaved <- unsaved + } + ) } # }}} # epw_comment1 {{{ +#' @importFrom checkmate assert_string epw_comment1 <- function (self, private, comment) { - if (missing(comment)) { - return(private$m_header$comment1) - } else { - assert(is_string(comment)) - log_unsaved(private$m_log) - log_new_uuid(private$m_log) - (private$m_header$comment1 <- comment) - } + val <- get_idf_value(private$idd_env(), private$idf_env(), EPW_CLASS$comment1) + + if (missing(comment)) return(val$value_chr) + + assert_string(comment) + private$idf_env()$value[J(val$value_id), on = "value_id", value_chr := comment] + log_unsaved(private$m_log) + log_new_uuid(private$m_log) + + comment } # }}} # epw_comment2 {{{ -epw_comment2 <- function (self, private, comment) { - if (missing(comment)) { - return(private$m_header$comment2) - } else { - assert(is_string(comment)) - log_unsaved(private$m_log) - log_new_uuid(private$m_log) - (private$m_header$comment2 <- comment) - } -} +epw_comment2 <- epw_comment1 # }}} # epw_num_period {{{ epw_num_period <- function (self, private) { - nrow(private$m_header$period$period) + get_idf_value(private$idd_env(), private$idf_env(), EPW_CLASS$period, field = 1L)$value_num } # }}} # epw_interval {{{ epw_interval <- function (self, private) { - private$m_header$period$interval + get_idf_value(private$idd_env(), private$idf_env(), EPW_CLASS$period, field = 2L)$value_num } # }}} # epw_period {{{ epw_period <- function (self, private, period, name, start_day_of_week) { - if (missing(period) && missing(name) && missing(start_day_of_week)) { - return(private$m_header$period$period[, -c("from", "to", "missing", "out_of_range")]) + p <- parse_epw_header_period(private$idf_env()) + + if (!missing(period)) { + period <- assert_count(period, coerce = TRUE) + if (period > nrow(p$period)) { + abort(paste0("Invalid data period index found. EPW contains only ", + nrow(p$period), " data period(s) but ", surround(period), " is specified." + ), "epw_data_period_index" + ) + } } - private$m_header <- set_epw_period_basic(private$m_header, period, name, start_day_of_week) - log_unsaved(private$m_log) - log_new_uuid(private$m_log) - private$m_header$period$period + l <- list() + if (!missing(name)) l[sprintf("Data Period %i Name/Description", period)] <- name + if (!missing(start_day_of_week)) { + if (!is.na(wd <- get_epw_wday(start_day_of_week, TRUE))) start_day_of_week <- wd + l[sprintf("Data Period %i Start Day of Week", period)] <- start_day_of_week + } + + if (!length(l)) { + if (missing(period)) return(p$period) else return(p$period[period]) + } + + # store current values in case error occur in later procedures + obj <- get_idf_object(private$idd_env(), private$idf_env(), EPW_CLASS$period) + val <- get_idf_value(private$idd_env(), private$idf_env(), EPW_CLASS$period) + # store save status + unsaved <- private$m_log$unsaved + + idf_set(self, private, ..(EPW_CLASS$period) := l, .default = FALSE, .empty = TRUE) + + withCallingHandlers(parse_epw_header_period(private$idf_env())$period[period], + eplusr_warning_epw_header_num_field = function (w) invokeRestart("muffleWarning"), + eplusr_error_parse_epw_header = function (e) { + # restore header value + env <- private$idf_env() + env$object <- append_dt(env$object, obj, "object_id") + env$value <- append_dt(env$value, val, "object_id") + setorderv(env$object, "object_id") + setorderv(env$value, "object_id") + + # restore save status + private$m_log$unsaved <- unsaved + } + ) } # }}} # epw_missing_code {{{ epw_missing_code <- function (self, private) { - EPW_MISSING_CODE + get_epw_data_missing_code() } # }}} # epw_initial_missing_value {{{ epw_initial_missing_value <- function (self, private) { - EPW_INIT_MISSING$atmospheric_pressure <- std_atm_press(private$m_header$location$elevation) - EPW_INIT_MISSING + get_epw_data_init_value() } # }}} # epw_range_exist {{{ epw_range_exist <- function (self, private) { - EPW_RANGE_EXIST + get_epw_data_range("exist") } # }}} # epw_range_valid {{{ epw_range_valid <- function (self, private) { - EPW_RANGE_VALID + get_epw_data_range("valid") } # }}} # epw_fill_action {{{ epw_fill_action <- function (self, private, type = c("missing", "out_of_range")) { - type <- match.arg(type) - if (type == "missing") { - EPW_REPORT_MISSING - } else { - EPW_REPORT_RANGE - } + get_epw_data_fill_action(match.arg(type)) } # }}} # epw_data {{{ epw_data <- function (self, private, period = 1L, start_year = NULL, align_wday = TRUE, - tz = "UTC", update = FALSE) { - get_epw_data(private$m_data, private$m_header, period, start_year, align_wday, tz, update) + tz = "UTC", update = FALSE, line = FALSE) { + d <- get_epw_data(private$m_data, private$idf_env(), private$m_log$matched, + period, start_year, align_wday, tz, update) + + assert_flag(line) + + if (!line) set(d, NULL, "line", NULL) + d[] } # }}} # epw_abnormal_data {{{ epw_abnormal_data <- function (self, private, period = 1L, cols = NULL, keep_all = TRUE, type = c("both", "missing", "out_of_range")) { - get_epw_data_abnormal(private$m_data, private$m_header, period, cols, keep_all, type) + get_epw_data_abnormal(private$m_data, private$idf_env(), private$m_log$matched, + period, cols, keep_all, type) } # }}} # epw_redundant_data {{{ epw_redundant_data <- function (self, private) { - get_epw_data_redundant(private$m_data, private$m_header) + get_epw_data_redundant(private$m_data, private$idf_env(), private$m_log$matched) } # }}} # epw_make_na {{{ -epw_make_na <- function (self, private, period = NULL, missing = FALSE, out_of_range = FALSE) { - assert(is_flag(missing), is_flag(out_of_range)) +#' @importFrom checkmate assert_flag +epw_make_na <- function (self, private, missing = FALSE, out_of_range = FALSE) { if (!missing && !out_of_range) return(invisible(self)) if (missing) { if (private$m_log$miss_na) { @@ -1408,16 +1706,21 @@ epw_make_na <- function (self, private, period = NULL, missing = FALSE, out_of_r private$m_log$range_filled <- FALSE } } - private$m_data <- make_epw_data_na(private$m_data, private$m_header, period = period, - missing = missing, out_of_range = out_of_range + private$m_data <- make_epw_data_na(private$m_data, private$idf_env(), private$m_log$matched, + period = NULL, missing = missing, out_of_range = out_of_range ) invisible(self) } # }}} # epw_fill_abnormal {{{ -epw_fill_abnormal <- function (self, private, period = NULL, missing = FALSE, out_of_range = FALSE, special = FALSE) { - assert(is_flag(missing), is_flag(out_of_range), is_flag(special)) +#' @importFrom checkmate assert_flag +epw_fill_abnormal <- function (self, private, missing = FALSE, out_of_range = FALSE, special = FALSE) { + assert_flag(missing) + assert_flag(out_of_range) + assert_flag(special) + if (!missing && !out_of_range) return(invisible(self)) + miss_na <- private$m_log$miss_na if (missing) { if (private$m_log$miss_filled) { @@ -1429,6 +1732,7 @@ epw_fill_abnormal <- function (self, private, period = NULL, missing = FALSE, ou miss_na <- TRUE } } + range_na <- private$m_log$range_na if (out_of_range) { if (private$m_log$range_filled) { @@ -1440,12 +1744,16 @@ epw_fill_abnormal <- function (self, private, period = NULL, missing = FALSE, ou range_na <- TRUE } } - private$m_data <- fill_epw_data_abnormal(private$m_data, private$m_header, - period, missing, out_of_range, special, private$m_log$miss_na, private$m_log$range_na + + private$m_data <- fill_epw_data_abnormal(private$m_data, private$idf_env(), + private$m_log$matched, NULL, NULL, missing, out_of_range, special, + private$m_log$miss_na, private$m_log$range_na ) + # have to update na status after filling, as it was used when doing filling private$m_log$miss_na <- miss_na private$m_log$range_na <- range_na + invisible(self) } # }}} @@ -1476,36 +1784,32 @@ epw_purge <- function (self, private) { if (private$m_log$purged) { verbose_info("Redundant data has already been purged before. Skip...") } else { - lst <- purge_epw_data_redundant(private$m_data, private$m_header) - if (nrow(lst$data) != nrow(private$m_data)) { + purged <- purge_epw_data_redundant(private$m_data, private$idf_env(), private$m_log$matched) + if (nrow(purged$data) != nrow(private$m_data)) { log_unsaved(private$m_log) log_new_uuid(private$m_log) } - private$m_header <- lst$header - private$m_data <- lst$data + private$m_data <- purged$data + private$m_log$matched <- purged$matched } invisible(self) } # }}} # epw_align_data_status {{{ -epw_align_data_status <- function (self, private, data, data_period) { - if (private$m_log$miss_na) { - data <- make_epw_data_na_line(data, data_period$missing[[1L]]) - } else if (private$m_log$miss_filled) { - data <- fill_epw_data_abnormal_line(data, data_period$missing[[1L]], FALSE, - private$m_log$miss_filled_special, "missing") - } +epw_align_data_status <- function (self, private, data, period = NULL) { + data <- make_epw_data_na(data, private$idf_env(), private$m_log$matched, + period, missing = private$m_log$miss_na, out_of_range = private$m_log$range_na + ) - if (private$m_log$range_na) { - data <- make_epw_data_na_line(data, data_period$out_of_range[[1L]]) - } else if (private$m_log$range_filled) { - data <- fill_epw_data_abnormal_line(data, data_period$out_of_range[[1L]], FALSE, - private$m_log$miss_filled_special, "out_of_range") - } + data <- fill_epw_data_abnormal(data, private$idf_env(), + private$m_log$matched, period, NULL, + private$m_log$miss_filled, + private$m_log$range_filled, + private$m_log$miss_filled_special && private$m_log$range_filled_special, + private$m_log$miss_na, private$m_log$range_na + ) - if (private$m_log$unit) { - data <- add_epw_data_unit(data) - } + if (private$m_log$unit) data <- add_epw_data_unit(data) data } @@ -1513,51 +1817,62 @@ epw_align_data_status <- function (self, private, data, data_period) { # epw_add {{{ epw_add <- function (self, private, data, realyear = FALSE, name = NULL, start_day_of_week = NULL, after = 0L, warning = TRUE) { - lst <- add_epw_data(private$m_data, private$m_header, data, realyear, name, start_day_of_week, after, warning) - lst$data <- epw_align_data_status(self, private, lst$data, lst$header$period$period[after + 1L]) - private$m_header <- lst$header - private$m_data <- rbindlist(lst[names(lst) != "header"]) + lst <- add_epw_data(private$m_data, private$idf_env(), private$m_log$matched, + data, realyear, name, start_day_of_week, after, warning) - if (eplusr_option("verbose_info")) { - # get data period - n <- nrow(lst$header$period$period) - # use nearest as template - if (after > n) after <- n - 1L + lst$data <- epw_align_data_status(self, private, lst$data, lst$period) + private$m_data <- lst$data + private$m_log$matched <- lst$matched + idf_update_idf_env(self, private, lst$header) + if (in_verbose()) { cli::cat_rule("Info", col = "green") - cat("New data period has been added successfully:\n") + cat("New data period has been added successfully:\n\n") - print(private$m_header$period$period[after + 1L, - list(" " = paste0(index, ": "), Name = name, - `StartDayOfWeek` = get_epw_wday(start_day_of_week, label = TRUE), + print(self$period()[lst$period][, + list( + " " = paste0(index, ": "), + Name = name, + `StartDayOfWeek` = start_day_of_week, `StartDay` = start_day, `EndDay` = end_day)], - row.names = FALSE + class = FALSE, row.names = FALSE ) + + cli::cat_rule() } log_unsaved(private$m_log) log_new_uuid(private$m_log) + private$m_log$purged <- FALSE invisible(self) } # }}} # epw_set {{{ epw_set <- function (self, private, data, realyear = FALSE, name = NULL, start_day_of_week = NULL, period = 1L, warning = TRUE) { - lst <- set_epw_data(private$m_data, private$m_header, data, realyear, name, start_day_of_week, period, warning) - lst$data <- epw_align_data_status(self, private, lst$data, lst$header$period$period[period]) - private$m_header <- lst$header - private$m_data <- rbindlist(lst[names(lst) != "header"]) + lst <- set_epw_data(private$m_data, private$idf_env(), private$m_log$matched, + data, realyear, name, start_day_of_week, period, warning) + + lst$data <- epw_align_data_status(self, private, lst$data, lst$period) - if (eplusr_option("verbose_info")) { + private$m_data <- lst$data + private$m_log$matched <- lst$matched + idf_update_idf_env(self, private, lst$header) + + if (in_verbose()) { cli::cat_rule("Info", col = "green") - cat("Data period", paste0("#", period), "has been replaced with input data.\n") + cat("Data period", paste0("#", lst$period), "has been replaced with input data.\n\n") - print(private$m_header$period$period[period, - list(" " = paste0(index, ": "), Name = name, - `StartDayOfWeek` = get_epw_wday(start_day_of_week, label = TRUE), + print(self$period()[lst$period][, + list( + " " = paste0(index, ": "), + Name = name, + `StartDayOfWeek` = start_day_of_week, `StartDay` = start_day, `EndDay` = end_day)], - row.names = FALSE + class = FALSE, row.names = FALSE ) + + cli::cat_rule() } log_unsaved(private$m_log) @@ -1567,9 +1882,30 @@ epw_set <- function (self, private, data, realyear = FALSE, name = NULL, # }}} # epw_del {{{ epw_del <- function (self, private, period) { - l <- del_epw_data(private$m_data, private$m_header, period) - private$m_header <- l$header - private$m_data <- l$data + lst <- del_epw_data(private$m_data, private$idf_env(), private$m_log$matched, period) + + if (in_verbose()) p <- self$period() + + private$m_data <- lst$data + private$m_log$matched <- lst$matched + idf_update_idf_env(self, private, lst$header) + + if (in_verbose()) { + cli::cat_rule("Info", col = "green") + cat("Data period", paste0("#", lst$period), "has been successfully deleted:\n\n") + + print(p[lst$period][, + list( + " " = paste0(index, ": "), + Name = name, + `StartDayOfWeek` = start_day_of_week, + `StartDay` = start_day, `EndDay` = end_day)], + class = FALSE, row.names = FALSE + ) + + cli::cat_rule() + } + log_unsaved(private$m_log) log_new_uuid(private$m_log) invisible(self) @@ -1584,23 +1920,22 @@ epw_is_unsaved <- function (self, private) { epw_save <- function (self, private, path = NULL, overwrite = FALSE, purge = FALSE) { if (is.null(path)) { if (is.null(private$m_path)) { - abort("error_not_local", - paste0( - "The Epw object is not created from local file. ", - "Please give the path to save." - ) - ) + abort("The Epw object is not created from local file. Please give the path to save.") } else { path <- private$m_path } } - assert(is_string(path), has_ext(path, "epw"), is_flag(overwrite), is_flag(purge)) + assert_string(path) + if (!has_ext(path, "epw")) abort("'path' should have an file extension of 'epw'", "epw_save_ext") + assert_flag(overwrite) + assert_flag(purge) # fill all NAs with missing code fill <- if (!private$m_log$miss_filled || !private$m_log$range_filled) TRUE else FALSE - p <- save_epw_file(private$m_data, private$m_header, path, overwrite, fmt_digit = TRUE, + p <- save_epw_file(private$m_data, private$idf_env(), private$m_log$matched, + path, overwrite, fmt_digit = TRUE, fill = fill, missing = private$m_log$miss_filled, out_of_range = private$m_log$range_filled, @@ -1617,22 +1952,29 @@ epw_save <- function (self, private, path = NULL, overwrite = FALSE, purge = FAL # }}} # epw_print {{{ epw_print <- function (self, private) { - print_epw_header(private$m_header) + cli::cat_rule("EnergyPlus Weather File", line = 2) + + cli::cat_line(format_epw_meta(private$idf_env())) + + cli::cat_line() + + cli::cat_rule("Data Periods") + + period <- parse_epw_header_period(private$idf_env()) + print(period$period[, + list(Name = name, + `StartDayOfWeek` = get_epw_wday(start_day_of_week, label = TRUE), + `StartDay` = start_day, `EndDay` = end_day)], + class = FALSE + ) + + cli::cat_line() + + cli::cat_rule() } # }}} # epw_deep_clone {{{ -epw_deep_clone <- function (self, private, name, value) { - if (is.environment(value)) { - l <- as.list.environment(value) - # copy data.table is necessary here - l <- lapply(l, function (x) if (inherits(x, "data.table")) copy(x) else x) - list2env(l) - } else if (inherits(value, "data.table")){ - copy(value) - } else { - value - } -} +epw_deep_clone <- idf_deep_clone # }}} # S3 Epw methods {{{ #' @export @@ -1642,13 +1984,13 @@ str.Epw <- function (object, ...) { #' @export format.Epw <- function (x, ...) { - paste0(utils::capture.output(x$print()), collapse = "\n") + utils::capture.output(x$print()) } #' @export `==.Epw` <- function (e1, e2) { if (!is_epw(e2)) return(FALSE) - identical(._get_private(e1)$m_log$uuid, ._get_private(e2)$m_log$uuid) + identical(get_priv_env(e1)$m_log$uuid, get_priv_env(e2)$m_log$uuid) } #' @export diff --git a/R/iddobj.R b/R/iddobj.R index 26e806891..5dc2635f6 100644 --- a/R/iddobj.R +++ b/R/iddobj.R @@ -1611,7 +1611,7 @@ iddobj_field_range <- function (self, private, which = NULL) { "minimum", "lower_incbounds", "maximum", "upper_incbounds"), underscore = TRUE) # set limits to Inf for numeric values that do not have ranges - fld[type_enum < IDDFIELD_TYPE$choice & has_range == FALSE, + fld[J(c(IDDFIELD_TYPE$integer, IDDFIELD_TYPE$real), FALSE), on = c("type_enum", "has_range"), `:=`(maximum = Inf, minimum = -Inf)] fld[, `:=`(range = list(ranger(minimum, lower_incbounds, maximum, upper_incbounds))), by = field_id] diff --git a/R/idf.R b/R/idf.R index cab3dcce6..4714e0ba4 100644 --- a/R/idf.R +++ b/R/idf.R @@ -2136,7 +2136,7 @@ Idf <- R6::R6Class(classname = "Idf", lock_objects = FALSE, #' @details #' `$to_table()` returns a [data.table][data.table::data.table()] that #' contains core data of specified objects. - #' The returned [data.table][data.table::data.table()] has 6 columns: + #' The returned [data.table][data.table::data.table()] has 5 columns: #' #' * `id`: Integer type. Object IDs. #' * `name`: Character type. Object names. diff --git a/R/idfobj.R b/R/idfobj.R index 3e6670b31..10f845c4e 100644 --- a/R/idfobj.R +++ b/R/idfobj.R @@ -53,7 +53,7 @@ IdfObject <- R6::R6Class(classname = "IdfObject", lock_objects = FALSE, #' #' @importFrom checkmate assert_count initialize = function (object, class = NULL, parent) { - if (missing(parent) || !is_idf(parent)) { + if (missing(parent) || (!is_idf(parent) && !is_epw(parent))) { abort(paste("IdfObject can only be created based a parent Idf object.", "Please give 'parent', which should be an Idf object.") ) diff --git a/R/impl-epw.R b/R/impl-epw.R index ac5583097..f4c89a1ba 100644 --- a/R/impl-epw.R +++ b/R/impl-epw.R @@ -14,23 +14,14 @@ #' @importFrom methods setOldClass #' @include parse.R #' @include utils.R -#' @include assertions.R +#' @include assert.R # HELPER -# abort_bad_epw_period {{{ -abort_bad_epw_period <- function (period, n) { - abort("error_invalid_data_period_index", - paste0("Invalid data period index found. EPW contains only ", n, - " data period(s) but ", collapse(period), " is specified." - ), - period = period - ) -} -# }}} # combine_date {{{ -combine_date <- function (year = NULL, month, day, hour) { +combine_date <- function (year = NULL, month, day, hour, minute = NULL) { y <- if (!is.null(year)) paste0(year, "/") else "" - paste0(y, month, "/", day, " ", lpad(hour, "0", 2L), ":XX") + m <- if (!is.null(minute)) minite else "XX" + paste0(y, month, "/", day, " ", lpad(hour, "0", 2L), ":", m) } # }}} # std_atm_press {{{ @@ -43,8 +34,8 @@ as_date <- function (x, ...) { # }}} # CONSTANTS -# EPW_HEADER {{{ -EPW_HEADER <- list( +# EPW_CLASS {{{ +EPW_CLASS <- list( location = "LOCATION", design = "DESIGN CONDITIONS", typical = "TYPICAL/EXTREME PERIODS", @@ -52,222 +43,8 @@ EPW_HEADER <- list( holiday = "HOLIDAYS/DAYLIGHT SAVINGS", comment1 = "COMMENTS 1", comment2 = "COMMENTS 2", - period = "DATA PERIODS" -) -# }}} -# EPW_UNIT {{{ -EPW_UNIT <- list( - dry_bulb_temperature = "degC", - dew_point_temperature = "degC", - relative_humidity = "%", - atmospheric_pressure = "Pa", - extraterrestrial_horizontal_radiation = "W*h/m^2", - extraterrestrial_direct_normal_radiation = "W*h/m^2", - horizontal_infrared_radiation_intensity_from_sky = "W*h/m^2", - global_horizontal_radiation = "W*h/m^2", - direct_normal_radiation = "W*h/m^2", - diffuse_horizontal_radiation = "W*h/m^2", - global_horizontal_illuminance = "lux", - direct_normal_illuminance = "lux", - diffuse_horizontal_illuminance = "lux", - zenith_luminance = "lux", - wind_direction = "degree", - wind_speed = "m/s", - visibility = "km", - ceiling_height = "m", - precipitable_water = "mm", - snow_depth = "cm", - days_since_last_snow = "day", - liquid_precip_depth = "mm", - liquid_precip_rate = "hour" -) -# }}} -# EPW_TYPE {{{ -EPW_TYPE <- list( - year = "integer", - month = "integer", - day = "integer", - hour = "integer", - minute = "integer", - datasource = "character", - dry_bulb_temperature = "double", - dew_point_temperature = "double", - relative_humidity = "double", - atmospheric_pressure = "double", - extraterrestrial_horizontal_radiation = "double", - extraterrestrial_direct_normal_radiation = "double", - horizontal_infrared_radiation_intensity_from_sky = "double", - global_horizontal_radiation = "double", - direct_normal_radiation = "double", - diffuse_horizontal_radiation = "double", - global_horizontal_illuminance = "double", - direct_normal_illuminance = "double", - diffuse_horizontal_illuminance = "double", - zenith_luminance = "double", - wind_direction = "double", - wind_speed = "double", - total_sky_cover = "integer", - opaque_sky_cover = "integer", - visibility = "double", - ceiling_height = "double", - present_weather_observation = "integer", - present_weather_codes = "character", - precipitable_water = "double", - aerosol_optical_depth = "double", - snow_depth = "double", - days_since_last_snow = "integer", - albedo = "double", - liquid_precip_depth = "double", - liquid_precip_rate = "double" -) -# }}} -# EPW_FORMAT {{{ -EPW_FORMAT <- list( - dry_bulb_temperature = fmt_int, - dew_point_temperature = fmt_int, - relative_humidity = as.integer, - atmospheric_pressure = as.integer, - extraterrestrial_horizontal_radiation = as.integer, - extraterrestrial_direct_normal_radiation = as.integer, - horizontal_infrared_radiation_intensity_from_sky = as.integer, - global_horizontal_radiation = as.integer, - direct_normal_radiation = as.integer, - diffuse_horizontal_radiation = as.integer, - global_horizontal_illuminance = as.integer, - direct_normal_illuminance = as.integer, - diffuse_horizontal_illuminance = as.integer, - zenith_luminance = as.integer, - wind_direction = as.integer, - wind_speed = fmt_int, - visibility = fmt_int, - ceiling_height = as.integer, - precipitable_water = as.integer, - aerosol_optical_depth = function (x) fmt_dbl(x, 4L), - snow_depth = as.integer, - albedo = function (x) fmt_dbl(x, 3L), - liquid_precip_depth = fmt_int, - liquid_precip_rate = fmt_int -) -# }}} -# EPW_MISSING_CODE {{{ -EPW_MISSING_CODE <- list( - dry_bulb_temperature = 99.9, - dew_point_temperature = 99.9, - relative_humidity = 999, - atmospheric_pressure = 999999, - extraterrestrial_horizontal_radiation = 9999, - extraterrestrial_direct_normal_radiation = 9999, - horizontal_infrared_radiation_intensity_from_sky = 9999, - global_horizontal_radiation = 9999, - direct_normal_radiation = 999999, - diffuse_horizontal_radiation = 9999, - global_horizontal_illuminance = 999999, - direct_normal_illuminance = 999999, - diffuse_horizontal_illuminance = 999999, - zenith_luminance = 99990, - wind_direction = 999, - wind_speed = 999, - total_sky_cover = 99, - opaque_sky_cover = 99, - visibility = 9999, - ceiling_height = 99999, - present_weather_observation = 9L, - present_weather_codes = "999999999", - precipitable_water = 999, - aerosol_optical_depth = 0.999, - snow_depth = 999, - days_since_last_snow = 99, - albedo = 999, - liquid_precip_depth = 999, - liquid_precip_rate = 99 -) -# }}} -# EPW_INIT_MISSING {{{ -EPW_INIT_MISSING <- list( - dry_bulb_temperature = 6.0, - dew_point_temperature = 3.0, - relative_humidity = 50.0, - wind_speed = 2.5, - wind_direction = 180, - total_sky_cover = 5L, - opaque_sky_cover = 5L, - visibility = 777.7, - ceiling = 77777, - precipitable_water = 0, - aerosol_optical_depth = 0, - snow_depth = 0, - days_since_last_snow = 88L, - albedo = 0.0, - liquid_precip_depth = 0 -) -# }}} -# EPW_RANGE_EXIST {{{ -EPW_RANGE_EXIST <- list( - # special - wind_direction = ranger(0, TRUE, 360, TRUE), # SPECIAL, value greater than MISSING_CODE will be treated as missing - present_weather_observation = ranger(0, TRUE, 9, TRUE), # SPECIAL, negative value will be replaced with 9 - # missing = var >= MISSING_CODE - dry_bulb_temperature = ranger(-Inf, FALSE, EPW_MISSING_CODE$dry_bulb_temperature, FALSE), - dew_point_temperature = ranger(-Inf, FALSE, EPW_MISSING_CODE$dew_point_temperature, FALSE), - # missing = ! var %in% [0, MISSING_CODE) - relative_humidity = ranger(0, TRUE, EPW_MISSING_CODE$relative_humidity, FALSE), - atmospheric_pressure = ranger(0, TRUE, EPW_MISSING_CODE$atmospheric_pressure, FALSE), - global_horizontal_illuminance = ranger(0, TRUE, EPW_MISSING_CODE$global_horizontal_illuminance, FALSE), - direct_normal_illuminance = ranger(0, TRUE, EPW_MISSING_CODE$direct_normal_illuminance, FALSE), - diffuse_horizontal_illuminance = ranger(0, TRUE, EPW_MISSING_CODE$diffuse_horizontal_illuminance, FALSE), - wind_speed = ranger(0, TRUE, EPW_MISSING_CODE$wind_speed, FALSE), - total_sky_cover = ranger(0, TRUE, EPW_MISSING_CODE$total_sky_cover, TRUE), - opaque_sky_cover = ranger(0, TRUE, EPW_MISSING_CODE$opaque_sky_cover, TRUE), - extraterrestrial_horizontal_radiation = ranger(0, TRUE, EPW_MISSING_CODE$extraterrestrial_horizontal_radiation, FALSE), - extraterrestrial_direct_normal_radiation = ranger(0, TRUE, EPW_MISSING_CODE$extraterrestrial_direct_normal_radiation, FALSE), - horizontal_infrared_radiation_intensity_from_sky = ranger(0, TRUE, EPW_MISSING_CODE$horizontal_infrared_radiation_intensity_from_sky, FALSE), - global_horizontal_radiation = ranger(0, TRUE, EPW_MISSING_CODE$global_horizontal_radiation, FALSE), - direct_normal_radiation = ranger(0, TRUE, EPW_MISSING_CODE$direct_normal_radiation, FALSE), - diffuse_horizontal_radiation = ranger(0, TRUE, EPW_MISSING_CODE$diffuse_horizontal_radiation, FALSE), - zenith_luminance = ranger(0, TRUE, EPW_MISSING_CODE$zenith_luminance, FALSE), - visibility = ranger(0, TRUE, EPW_MISSING_CODE$visibility, FALSE), - ceiling_height = ranger(0, TRUE, EPW_MISSING_CODE$ceiling_height, FALSE), - precipitable_water = ranger(0, TRUE, EPW_MISSING_CODE$precipitable_water, FALSE), - aerosol_optical_depth = ranger(0, TRUE, EPW_MISSING_CODE$aerosol_optical_depth, FALSE), - snow_depth = ranger(0, TRUE, EPW_MISSING_CODE$snow_depth, FALSE), - days_since_last_snow = ranger(0, TRUE, EPW_MISSING_CODE$days_since_last_snow, FALSE), - albedo = ranger(0, TRUE, EPW_MISSING_CODE$albedo, FALSE), - liquid_precip_depth = ranger(0, TRUE, EPW_MISSING_CODE$liquid_precip_depth, FALSE), - liquid_precip_rate = ranger(0, TRUE, EPW_MISSING_CODE$liquid_precip_rate, FALSE) -) -# }}} -# EPW_RANGE_VALID {{{ -EPW_RANGE_VALID <- list( - # missing = var >= MISSING_CODE - dry_bulb_temperature = ranger(-90, TRUE, 70, TRUE), - dew_point_temperature = ranger(-90, TRUE, 70, TRUE), - # missing = ! var %in% [0, MISSING_CODE) - relative_humidity = ranger(0, TRUE, 110, TRUE), - atmospheric_pressure = ranger(31000, FALSE, 120000, TRUE), - global_horizontal_illuminance = ranger(0, TRUE, 999900, FALSE), - direct_normal_illuminance = ranger(0, TRUE, 999900, FALSE), - diffuse_horizontal_illuminance = ranger(0, TRUE, 999900, FALSE), - wind_direction = ranger(0, TRUE, 360, TRUE), - wind_speed = ranger(0, TRUE, 40, TRUE), - total_sky_cover = ranger(0, TRUE, 10, TRUE), - opaque_sky_cover = ranger(0, TRUE, 10, TRUE), - present_weather_observation = ranger(0, TRUE, 9, TRUE), - extraterrestrial_horizontal_radiation = ranger(0, TRUE, EPW_MISSING_CODE$extraterrestrial_horizontal_radiation, FALSE), - extraterrestrial_direct_normal_radiation = ranger(0, TRUE, EPW_MISSING_CODE$extraterrestrial_direct_normal_radiation, FALSE), - horizontal_infrared_radiation_intensity_from_sky = ranger(0, TRUE, EPW_MISSING_CODE$horizontal_infrared_radiation_intensity_from_sky, FALSE), - global_horizontal_radiation = ranger(0, TRUE, EPW_MISSING_CODE$global_horizontal_radiation, FALSE), - direct_normal_radiation = ranger(0, TRUE, EPW_MISSING_CODE$direct_normal_radiation, FALSE), - diffuse_horizontal_radiation = ranger(0, TRUE, EPW_MISSING_CODE$diffuse_horizontal_radiation, FALSE), - zenith_luminance = ranger(0, TRUE, EPW_MISSING_CODE$zenith_luminance, FALSE), - visibility = ranger(0, TRUE, EPW_MISSING_CODE$visibility, FALSE), - ceiling_height = ranger(0, TRUE, EPW_MISSING_CODE$ceiling_height, FALSE), - precipitable_water = ranger(0, TRUE, EPW_MISSING_CODE$precipitable_water, FALSE), - aerosol_optical_depth = ranger(0, TRUE, EPW_MISSING_CODE$aerosol_optical_depth, FALSE), - snow_depth = ranger(0, TRUE, EPW_MISSING_CODE$snow_depth, FALSE), - days_since_last_snow = ranger(0, TRUE, EPW_MISSING_CODE$days_since_last_snow, FALSE), - albedo = ranger(0, TRUE, EPW_MISSING_CODE$albedo, FALSE), - liquid_precip_depth = ranger(0, TRUE, EPW_MISSING_CODE$liquid_precip_depth, FALSE), - liquid_precip_rate = ranger(0, TRUE, EPW_MISSING_CODE$liquid_precip_rate, FALSE) + period = "DATA PERIODS", + data = "WEATHER DATA" ) # }}} # EPW_REPORT_MISSING {{{ @@ -348,6 +125,22 @@ EPWDATE_YEAR <- list( ) # }}} +# IDD +# get_epw_idd {{{ +get_epw_idd <- function () { + if (!length(.globals$epw)) { + .globals$epw <- EpwIdd$new(system.file("extdata/epw.idd", package = "eplusr")) + } + + .globals$epw +} +# }}} +# get_epw_idd_env {{{ +get_epw_idd_env <- function () { + get_priv_env(get_epw_idd())$idd_env() +} +# }}} + # PARSE # parse_epw_file {{{ # (a) no match checking will be made between the year in data periods and the @@ -383,840 +176,589 @@ EPWDATE_YEAR <- list( # 01:00:00, Hour of 2 corresponds to the period between 01:00:01 to 02:00:00, # and etc. The minute column is **not used** to determine currently sub-hour # time. - -parse_epw_file <- function (path, warning = FALSE) { +parse_epw_file <- function (path, warning = FALSE, idd = NULL) { # read and parse header - epw_header <- parse_epw_header(read_epw_header(path), warning = warning) + epw_header <- parse_epw_header(path) # read core weather data - epw_data <- read_epw_data(path) + epw_data <- parse_epw_data(path) + + # add line indicator + set(epw_data, NULL, "line", seq_len(nrow(epw_data))) # parse date time - # first ignore minute column here epw_data[, datetime := lubridate::make_datetime(year, month, day, hour, tz = "UTC")] - # make sure that each data period exists and get corresponding line number - epw_header$period$period[, c("from", "to", "missing", "out_of_range") := - match_epw_data_period(epw_data, .SD, - epw_header$period$interval, - epw_header$holiday$leapyear, warning), - by = index - ] - - # stop if there are overlaps in multiple data periods {{{ - if (nrow(epw_header$period$period) > 1L) { - p <- epw_header$period$period - comb <- utils::combn(p$index, 2L, simplify = FALSE) - for (i in comb) { - int <- intersect(seq(p$from[i[1L]], p$to[i[1L]]), seq(p$from[i[2L]], p$to[i[2L]])) - if (length(int)) { - parse_issue("error_epw_data_period_overlapped", "epw", - "Overlapping in data periods found", - data = data.table(line = 8L, string = paste(EPW_HEADER$period, format_epw_header_period(epw_header$period), sep = ",")), - post = paste0("Each data period should not have overlapped period with others. ", - "Data period #", i[1L], " ", surround(p$name[i[1L]]), " overlaps with ", - "data period #", i[2L], " ", surround(p$name[i[2L]]), "." - ) - ) - } - } - } - # }}} - - # warning if redundant lines found - if (warning) { - redundant <- get_epw_data_redundant_line(epw_data, epw_header, simplify = TRUE) - if (length(redundant)) { - all <- nrow(epw_data) - unused <- round(length(redundant)/all, 4L) - parse_issue("warning_redundant_epw_data", "epw", - "Redundant weather data found", num = length(redundant), - post = paste0( - "All data periods only cover ", - all - length(redundant), " rows (", round(100 * (1 - unused), 2L), " %", - ") of weather data, leaving ", length(redundant), " rows (", 100 * unused, " %", - ") unused." - ), - stop = FALSE - ) - } - } + # match date time + matched <- match_epw_data(epw_data, epw_header) # clean and set column order set(epw_data, NULL, "line", NULL) - setcolorder(epw_data, c("datetime", setdiff(names(epw_data), "datetime"))) + setcolorder(epw_data, "datetime") - list(header = epw_header, data = epw_data) + list(header = epw_header, data = epw_data, matched = matched) } # }}} -## header -# read_epw_header {{{ -read_epw_header <- function (path) { - num_header <- 8L - - # HEADER - # header dict {{{ - dict_header <- data.table( - name = unlist(EPW_HEADER, use.names = FALSE), - # currently, only location, holidays and data periods are parsed - parse = c(TRUE, FALSE, FALSE, FALSE, TRUE, FALSE, FALSE, TRUE) - ) - # }}} +## HEADER +# parse_epw_header {{{ +parse_epw_header <- function (path, strict = FALSE) { + idd_env <- get_epw_idd_env() - # read header {{{ - header <- read_lines(path, nrows = num_header) + dt_in <- read_lines(path, nrows = 8L) - # split header lines using comma - set(header, NULL, "contents", stri_split_fixed(header$string, ",")) - # get header name - set(header, NULL, "name", stri_trans_toupper(vapply(header$contents, "[[", character(1L), 1L))) + # in case header does not any fields, e.g. "LOCATION\n" + dt_in[!stri_detect_fixed(string, ","), string := paste0(string, ",")] - header <- merge(dict_header, header, by = "name", all = TRUE, sort = FALSE) + # type enum + type_enum <- list(unknown = 0L, special = 1L, macro = 2L, comment = 3L, + object = 4L, object_value = 5L, value = 6L, value_last = 7L + ) - if (any(is.na(header$line))) { - mis <- header[is.na(line), name] - parse_issue("error_miss_epw_header", "epw", - paste0("Missing required header data ", collapse(mis)), num = length(mis) - ) - } + # separate lines into bodies, and comments + set(dt_in, NULL, "body", paste0(dt_in$string, ";")) + set(dt_in, NULL, "comment", "") - if (any(is.na(header$parse))) { - parse_issue("error_invalid_epw_header", "epw", "Invalid header name ", header[is.na(parse)]) - } + # mark lines + set(dt_in, NULL, "type", type_enum$value_last) - # header should come in order - # Reference: EnergyPlus/WeatherManager.cc - if (!identical(header$line, 1L:8L)) { - parse_issue("error_invalid_epw_header_order", "epw", "Invalid header order", - header[order(line)], - post = paste0("EPW header should come in order: ", collapse(dict_header$name)) + # object table + dt <- tryCatch(sep_object_table(dt_in, type_enum, idd_env), + eplusr_error_parse_idf_class = function (e) { + parse_error("epw", "Invalid header name", e$data, subtype = "header_name") + } + ) + dt_object <- dt$object + dt <- dt$left + + add_class_name(idd_env, dt) + # detect invalid lines with multiple semicolon (;) + # in case there are multiple semicolon in one line + if (any(stri_count_fixed(dt$body[!dt$class_name %chin% c("COMMENTS 1", "COMMENTS 2")], ";") > 1L)) { + parse_error("epw", "Invalid header line found", + dt[stri_count_fixed(body, ";") > 1L & !class_name %chin% c("COMMENTS 1", "COMMENTS 2")], + subtype = "header_line" ) } - # }}} - - set(header, NULL, "parse", NULL) - setcolorder(header, c("line", "name", "contents", "string")) - header -} -# }}} -# parse_epw_header {{{ -parse_epw_header <- function (header, warning = FALSE) { - epw_header <- EPW_HEADER - for (i in seq_along(epw_header)) { - fun <- match.fun(paste0("parse_epw_header_", names(epw_header)[i])) - epw_header[[i]] <- fun(input = header[i, contents][[1L]], data = header[i], warning = warning) - } - - # update EpwDate year according to leapyear element in HOLIDAYS header - set(epw_header$period$period, NULL, c("start_day", "end_day"), - list(reset_epwdate_year(epw_header$period$period$start_day, epw_header$holiday$leapyear), - reset_epwdate_year(epw_header$period$period$end_day, epw_header$holiday$leapyear) - ) + set(dt, NULL, "class_name", NULL) + + # value table + # now it is save to set escape to TRUE since only comments can have multiple + # semicolons + dt_value <- tryCatch(get_value_table(dt, idd_env, escape = TRUE), + eplusr_error_parse_idf_field = function (e) { + d <- e$data[, list(field_index = max(field_index)), by = c("line", "string", "class_id")] + add_rleid(d) + add_class_property(idd_env, d, c("class_name", "min_fields", "num_fields")) + msg <- gsub("Class", "Header", errormsg_field_index(d), fixed = TRUE) + parse_error("epw", "Invalid header field number found", d, post = msg, subtype = "header_field") + } ) - # check if leap day is found in period but leap year is not allowed in the header {{{ - if (!epw_header$holiday$leapyear && - any(format(as.Date.EpwDate(epw_header$period$period$start_day), "%m-%d") == "02-29" | - format(as.Date.EpwDate(epw_header$period$period$end_day), "%m-%d") == "02-29" - ) - ) { - parse_issue("error_invalid_epw_data_period_leapday", "epw", - "Invalid start/end day of data period found", - data = header[name == EPW_HEADER$period], - post = paste0("EPW file header ", surround(EPW_HEADER$holiday), - " indicates no leap year but start/end day on Feb 29 found in", - "header", surround(EPW_HEADER$period), "." - ) - ) - } - # }}} + # update object name + dt_object <- update_object_name(dt_object, dt_value) - epw_header -} -# }}} -# parse_epw_header_basic {{{ -parse_epw_header_basic <- function ( - header_type, input, - len = NULL, name = NULL, type = NULL, range = NULL, raw = TRUE, coerce = TRUE, strict = TRUE, ... -) { + # remove unuseful columns + set(dt_value, NULL, setdiff(names(dt_value), + c("value_id", "value_chr", "value_num", "object_id", "field_id")), NULL + ) - # convert to a list if necessary - if (!is.list(input)) input <- as.list(input) + # column order + setcolorder(dt_object, c("object_id", "object_name", "object_name_lower", "comment", "class_id")) + setcolorder(dt_value, c("value_id", "value_chr", "value_num", "object_id", "field_id")) - # set names - if (!is.null(name)) { - if (length(input) < length(name)) { - name <- name[1:length(input)] - } - setattr(input, "names", name) - } + dt_reference <- data.table( + object_id = integer(0L), value_id = integer(0L), + src_object_id = integer(0L), src_value_id = integer(0L), + src_enum = integer(0L) + ) - # check length {{{ - # use length of names as expect minimum length of input - if (!is.null(len)) { - if (is_range(len) || are_integer(len)) { - assert(has_len(input, len), prefix = EPW_HEADER[[header_type]]) - } else { - assert(is.list(len), has_name(len, "len")) - assert(has_len(input, len$len, len$step), prefix = EPW_HEADER[[header_type]]) - } - } - # }}} + header <- list(object = dt_object, value = dt_value, reference = dt_reference) - # check type and coerce to corresponding type {{{ - if (!is.null(type)) { - assert(is_named(type)) - tnm <- names(type) - # type is a list of functions - if (has_name(input, tnm)) { - for (i in tnm) { - fun <- header_data_type_fun(type[[i]], raw = raw, coerce = coerce, - prefix = paste(EPW_HEADER[[header_type]]), strict = strict - ) - input[[i]] <- tryCatch(fun(input[[i]]), - error_assertion = function (e) header_error_cnd(e, header_type, "type", tnm, raw, ...) - ) - } - } else { - # for each function - for (i in tnm) { - - # get member indices - indices <- type[[i]] - - # if input is raw string and indices are names, make sure input - # has corresponding members - if (is.character(indices)) { - if (raw && !has_name(input, indices)) { - stop("Invalid input name in `type`.") - } else { - indices <- indices[indices %in% names(input)] - } - } + # auto fill "0" for some empty headers + if (!strict) { + cls_nm <- c(EPW_CLASS$design, EPW_CLASS$typical, EPW_CLASS$ground) + cls_id <- idd_env$class[J(cls_nm), on = "class_name", class_id] + cls_id <- cls_id[cls_id %in% header$object$class_id] - # get type assert and coerce function - fun <- header_data_type_fun(i, raw = raw, coerce = coerce, prefix = paste(EPW_HEADER[[header_type]]), strict = strict) + if (length(cls_id)) { + val <- get_idf_value(idd_env, header, cls_id) - # for each specified index - for (idx in indices) { - # assert and coerce - input[[idx]] <- tryCatch(fun(input[[idx]]), - error_assertion = function (e) header_error_cnd(e, header_type, "type", idx, raw, ...) - ) - } + id <- val[, list(value_chr = value_chr[[1L]], num = max(field_index)), by = "object_id"][ + num == 1L & is.na(value_chr), object_id] + if (length(id)) { + header$value[J(id), on = "object_id", `:=`(value_chr = "0", value_num = 0)] } } } - # }}} - - # check range {{{ - if (!is.null(range)) { - # for raw string, make sure input exists - if (raw) { - assert(has_name(input, names(range))) - } else { - range <- range[names(range) %in% names(input)] - } - for (name in names(range)) { - tryCatch(assert(in_range(input[[name]], range[[name]]), prefix = paste(EPW_HEADER[[header_type]])), - error_assertion = function (e) { - if (!strict) NA_real_ else header_error_cnd(e, header_type, "range", name, raw, ...) - } - ) - } - } - # }}} - input + validate_epw_header(header, strict = strict) + header } # }}} # parse_epw_header_location {{{ -parse_epw_header_location <- function (input, warning = TRUE, ...) { - res <- parse_epw_header_basic("location", input, len = 10L, - name = c("header_name", - "city", "state_province", "country", "data_source", "wmo_number", - "latitude", "longitude", "time_zone", "elevation" - ), - type = list(dbl = c("latitude", "longitude", "elevation", "time_zone")), - range = list( - latitude = ranger(-90, TRUE, 90, TRUE), - longitude = ranger(-180, TRUE, 180, TRUE), - time_zone = ranger(-12, TRUE, 14, TRUE), - elevation = ranger(-1000, TRUE, 9999.9, FALSE) - ), - coerce = TRUE, - raw = TRUE, - strict = FALSE, - ... - )[-1L] - - if (warning) warn_epw_header_na(input, res) - - res +parse_epw_header_location <- function (header, strict = FALSE, transform = TRUE) { + if (!transform) return(header) + val <- get_idf_value(get_epw_idd_env(), header, EPW_CLASS$location, property = c("type_enum", "field_name_us")) + nm <- val$field_name_us + val <- get_value_list(val) + setattr(val, "names", nm) + val } # }}} # parse_epw_header_design {{{ -# currently, only parse annual design day conditions as specified in ASHRAE HOF -# 2009 -parse_epw_header_design <- function (input, warning = TRUE, ...) { - n <- suppressWarnings(as.integer(input[2L])) - - if (is.na(n) || !n %in% c(0L, 1L)) { - parse_issue("error_invalid_epw_header_design_number", "epw", - paste("Non-integral design condition number field"), - post = paste0("Number of design condition can either be 0 or 1. ", - "Note that currently only one design conditon specified in ", - "ASHRAE HOF 2009 and above is supported per EPW file." - ), - ... - ) - } +parse_epw_header_design <- function (header, strict = FALSE, transform = TRUE) { + obj <- get_idf_object(get_epw_idd_env(), header, EPW_CLASS$design, property = "num_extensible_group") + val <- get_idf_value(get_epw_idd_env(), header, EPW_CLASS$design, property = c("extensible_group", "type_enum")) - # "DESIGN CONDITIONS, 0" - if (length(input) == 2L && n == 0L) return(list(list(NULL))) - - res <- parse_epw_header_basic("design", input, len = 70L, - # name {{{ - name = c( - "header_name", # [1] chr - "n", # [2] int - "source", # [3] chr - "empty_separator", # [4] chr - "heating", # [5] chr - "coldest_month", # [6] int - "heating_db_99.6", # [7] dbl - "heating_db_99.0", # [8] dbl - "humidification_dp_99.6", # [9] dbl - "humidification_hr_99.6", #[10] dbl - "humidification_mcdb_99.6", #[11] dbl - "humidification_dp_99.0", #[12] dbl - "humidification_hr_99.0", #[13] dbl - "humidification_mcdb_99.0", #[14] dbl - "coldest_month_ws_0.4", #[15] dbl - "coldest_month_mcdb_0.4", #[16] dbl - "coldest_month_ws_1.0", #[17] dbl - "coldest_month_mcdb_1.0", #[18] dbl - "mcws_99.6_db", #[19] dbl - "pcwd_99.6_db", #[20] dbl - "cooling", #[21] chr - "hotest_month", #[22] int - "hotest_month_db_range", #[23] dbl - "cooling_db_0.4", #[24] dbl - "cooling_mcwb_0.4", #[25] dbl - "cooling_db_1.0", #[26] dbl - "cooling_mcwb_1.0", #[27] dbl - "cooling_db_2.0", #[28] dbl - "cooling_mcwb_2.0", #[29] dbl - "evaporation_wb_0.4", #[30] dbl - "evaporation_mcdb_0.4", #[31] dbl - "evaporation_wb_1.0", #[32] dbl - "evaporation_mcdb_1.0", #[33] dbl - "evaporation_wb_2.0", #[34] dbl - "evaporation_mcdb_2.0", #[35] dbl - "mcws_0.4_db", #[36] dbl - "pcwd_0.4_db", #[37] dbl - "dehumification_dp_0.4", #[38] dbl - "dehumification_hr_0.4", #[39] dbl - "dehumification_mcdb_0.4", #[40] dbl - "dehumification_dp_1.0", #[41] dbl - "dehumification_hr_1.0", #[42] dbl - "dehumification_mcdb_1.0", #[43] dbl - "dehumification_dp_2.0", #[44] dbl - "dehumification_hr_2.0", #[45] dbl - "dehumification_mcdb_2.0", #[46] dbl - "enthalpy_0.4", #[47] dbl - "mcdb_0.4", #[48] dbl - "enthalpy_1.0", #[49] dbl - "mcdb_1.0", #[50] dbl - "enthalpy_2.0", #[51] dbl - "mcdb_2.0", #[52] dbl - "hours_8_to_4_12.8_20.6", #[53] dbl - "extremes", #[54] chr - "extreme_annual_ws_1.0", #[55] dbl - "extreme_annual_ws_2.5", #[56] dbl - "extreme_annual_ws_5.0", #[57] dbl - "extreme_max_wb", #[58] dbl - "extreme_annual_db_mean_min", #[59] dbl - "extreme_annual_db_mean_max", #[60] dbl - "extreme_annual_db_sd_min", #[61] dbl - "extreme_annual_db_sd_max", #[62] dbl - "5_year_return_period_values_of_extreme_db_min", #[63] dbl - "5_year_return_period_values_of_extreme_db_max", #[64] dbl - "10_year_return_period_values_of_extreme_db_min", #[65] dbl - "10_year_return_period_values_of_extreme_db_max", #[66] dbl - "20_year_return_period_values_of_extreme_db_min", #[67] dbl - "20_year_return_period_values_of_extreme_db_max", #[68] dbl - "50_year_return_period_values_of_extreme_db_min", #[69] dbl - "50_year_return_period_values_of_extreme_db_max" #[70] dbl - ), - # }}} - type = list( - int = c("n", "coldest_month", "hotest_month"), - dbl = c(7L:20L, 23L:53L, 55L:70L) - ), - range = list( - `hours_8_to_4_12.8_20.6` = ranger(0L, TRUE), - `coldest_month` = ranger(1L, TRUE, 12L, TRUE), - `hotest_month` = ranger(1L, TRUE, 12L, TRUE) - ), - raw = TRUE, coerce = TRUE, strict = FALSE, ... - ) + update_epw_header_num_field(header, obj, val, strict = strict) - if (warning) warn_epw_header_na(input, res) + if (!transform) return(header) - list(source = res$source, heating = res[6L:20L], cooling = res[22L:53L], extremes = res[55L:70L]) + if (nrow(val) == 1L) return(list()) + get_idf_table(get_epw_idd_env(), header, EPW_CLASS$design, string_value = FALSE)[ + , list(index, field, value)] } # }}} # parse_epw_header_typical {{{ -parse_epw_header_typical <- function (input, warning = TRUE, ...) { - # get number of typical periods - n <- parse_epw_header_basic("typical", input[2L], name = "n", - type = list(int = "n"), range = list(n = ranger(0, TRUE)), - raw = TRUE, coerce = TRUE, ... - )$n - - # check length - assert(has_len(input, 2L, step = 4L), prefix = EPW_HEADER$typical) - - # "TYPICAL/EXTREME PERIODS, 0" - if (length(input) == 2L && n == 0L) return(list(list(data.table()))) - - if ((actual_n <- (length(input) - 2) %/% 4) != n) { - if (actual_n * 4 != (length(input) - 2)) input <- input[1:(actual_n * 4 + 2)] - - if (warning) { - parse_issue("warning_invalid_epw_header_typical_length", "epw", - paste("Invalid", input[[1]], "header data format"), num = 1, - post = paste0("Number of periods '", n, "' did not match the actual data period presented '", - actual_n, "'. The latter will be used during parsing."), - stop = FALSE - ) - } - } - - input <- input[-c(1L, 2L)] - n <- actual_n - - days <- data.table(matrix(input, nrow = n, byrow = TRUE, - dimnames = list(as.character(1:n), c("name", "type", "start_day", "end_day")) - )) +parse_epw_header_typical <- function (header, strict = FALSE, transform = TRUE) { + obj <- get_idf_object(get_epw_idd_env(), header, EPW_CLASS$typical, property = "num_extensible_group") + val <- get_idf_value(get_epw_idd_env(), header, EPW_CLASS$typical, property = "extensible_group") - set(days, NULL, "index", seq_len(nrow(days))) - set(days, NULL, "type", stri_trans_tolower(days$type)) - set(days, NULL, "start_day", epw_date(days$start_day)) - set(days, NULL, "end_day", epw_date(days$end_day)) - setcolorder(days, c("index", "name", "type", "start_day", "end_day")) + update_epw_header_num_field(header, obj, val, strict = strict) - tryCatch( - assert(is_unique(days$name), prefix = paste("Name of", EPW_HEADER$typical)), - error_assertion = function (e) { - if (warning) header_error_cnd(e, "typical", "day_name", stop = FALSE, ...) - } - ) - tryCatch( - assert(is_choice(days$type, c("Extreme", "Typical")), prefix = paste("Day type of", EPW_HEADER$typical)), - error_assertion = function (e) { - if (warning) header_error_cnd(e, "typical", "day_type", stop = FALSE, ...) - } - ) - tryCatch( - assert(not_epwdate_realyear(days$start_day), prefix = paste("Start day of", EPW_HEADER$typical)), - error_assertion = function (e) { - if (warning) header_error_cnd(e, "typical", "day_date", stop = FALSE, ...) - } - ) - tryCatch( - assert(not_epwdate_realyear(days$end_day), prefix = paste("End day of", EPW_HEADER$typical)), - error_assertion = function (e) { - if (warning) header_error_cnd(e, "typical", "day_date", stop = FALSE, ...) - } - ) - days -} -# }}} -# parse_epw_header_ground {{{ -parse_epw_header_ground <- function (input, warning = TRUE, ...) { - # get number of ground temperature periods - n <- parse_epw_header_basic("ground", input[2L], name = "n", - type = list(int = "n"), range = list(n = ranger(0, TRUE)), - raw = TRUE, coerce = TRUE, strict = TRUE, ... - )$n - - # check length - assert(has_len(input, 2L, step = 16L), prefix = EPW_HEADER$ground) - - # "GROUND TEMPERATURES, 0" - if (length(input) == 2L && n == 0L) return(list(list(data.table()))) - - if ((actual_n <- (length(input) - 2) %/% 16) != n) { - if (actual_n * 16 != (length(input) - 2)) input <- input[1:(actual_n * 16 + 2)] - - if (warning) { - parse_issue("warning_invalid_epw_header_typical_length", "epw", - paste("Invalid", input[[1]], "header data format"), num = 1, - post = paste0("Number of periods '", n, "' did not match the actual data period presented '", - actual_n, "'. The latter will be used during parsing."), - stop = FALSE - ) - } + if (max(val$extensible_group) == 0) { + if (!transform) return(header) else return(data.table()) } - if (warning) type <- input[1L] + val[extensible_group > 0, extensible_field_index := seq_len(.N), by = c("object_id", "extensible_group")] + start_day <- val[J(3L), on = "extensible_field_index", epw_date(value_chr)] + end_day <- val[J(4L), on = "extensible_field_index", epw_date(value_chr)] - input <- input[-c(1L, 2L)] - n <- actual_n + if (checkmate::anyMissing(start_day)) { + i <- which(is.na(start_day)) + invld <- val[J(i, 3L), on = c("extensible_group", "extensible_field_index")] + issue_epw_header_parse_error_single(obj, invld, i) + } - m <- matrix(suppressWarnings(as.numeric(input)), nrow = n, byrow = TRUE) - if (warning) { - inp <- matrix(input, nrow = n, byrow = TRUE) - if (any(na <- is.na(m[, 1L]))) { - parse_issue("warning_invalid_epw_header_ground_depth", "epw", - paste("Invalid", type, "header data format"), - num = sum(na), - post = sprintf("[%s]: failed to parse ground depth value '%s' at field position #%i. NA was introduced.", - lpad(seq_len(sum(na)), "0"), as.character(inp[na, 1L]), (which(na) - 1L) * 16 + 2L - ), - stop = FALSE - ) - } + if (checkmate::anyMissing(end_day)) { + i <- which(is.na(end_day)) + invld <- val[J(i, 4L), on = c("extensible_group", "extensible_field_index")] + issue_epw_header_parse_error_single(obj, invld, i) + } - if (any(na <- is.na(m[, 5L:16L]))) { - i_fld <- which(t(na)) %% 12L - i_dep <- vlapply(seq_len(n), function(i) any(na[i, ])) - parse_issue("warning_invalid_epw_header_ground_temp", "epw", - paste("Invalid", type, "header data format"), - num = sum(na), - post = sprintf("[%s]: failed to parse ground temp value '%s' at field position #%i of #%i depth '%s'. NA was introduced.", - lpad(seq_len(sum(na)), "0"), as.character(unlist(inp[, 5L:16L])[unlist(na)]), - i_fld + 3L, which(i_dep), m[, 1L][i_dep] - ), - stop = FALSE - ) - } + if (any(rewind <- as_date(start_day) > as_date(align_epwdate_type(end_day, start_day)))) { + i <- which(rewind) + invld <- val[J(i), on = "extensible_group"] + issue_epw_header_parse_error_conn(obj, invld, i, 4L, 3L, ". Should be equal as or later than %s ('%s').") } - # change into a data.table - temp <- data.table(m) - setnames(temp, - c("depth", - "soil_conductivity", - "soil_density", - "soil_specific_heat", - "1", "2", "3", "4", "5", "6", "7", "8", "9", "10", "11", "12" - ) - ) + if (!transform) return(header) - tryCatch( - assert(is_unique(temp$depth), prefix = paste("Depth of", EPW_HEADER$ground)), - error_assertion = function (e) { - if (warning) header_error_cnd(e, "ground", "depth", stop = FALSE, ...) - } + data.table( + index = seq_along(start_day), + name = val[J(1L), on = "extensible_field_index", value_chr], + type = val[J(2L), on = "extensible_field_index", value_chr], + start_day = start_day, + end_day = end_day ) +} +# }}} +# parse_epw_header_ground {{{ +parse_epw_header_ground <- function (header, strict = FALSE, transform = TRUE) { + obj <- get_idf_object(get_epw_idd_env(), header, EPW_CLASS$ground, property = "num_extensible_group") + val <- get_idf_value(get_epw_idd_env(), header, EPW_CLASS$ground, property = "extensible_group") - # change into tidy format - temp <- melt.data.table(temp[, index := .I], - id.vars = c("index", "depth", "soil_conductivity", "soil_density", "soil_specific_heat"), - variable.name = "month", value.name = "temperature", variable.factor = FALSE - ) - set(temp, NULL, "month", as.integer(temp$month)) - setcolorder(temp, c("index", "depth", "month", "soil_conductivity", "soil_density", "soil_specific_heat", "temperature")) - setorderv(temp, c("index", "month")) + update_epw_header_num_field(header, obj, val, strict = strict) + + if (!transform) return(header) - temp + if (nrow(val) == 1L) return(data.table()) + + val <- get_idf_table(get_epw_idd_env(), header, EPW_CLASS$ground, group_ext = "index", wide = TRUE) + set(val, NULL, 2:4, NULL) + setnames(val, c("index", "depth", "soil_conductivity", "soil_density", + "soil_specific_heat", MONTH)) + val <- val[, by = "index", lapply(.SD, unlist)] + val[, index := .I] + val } # }}} # parse_epw_header_holiday {{{ -parse_epw_header_holiday <- function (input, warning = TRUE, ...) { - # get number of holidays - res <- parse_epw_header_basic("holiday", input[2L:5L], - name = c("leapyear", "dst_start_day", "dst_end_day", "n"), - type = list( - leapyear = list( - function (x) is_choice(x, c("Yes", "No", "Y", "N")), - function (x) if (stri_trans_tolower(x) == "yes") TRUE else FALSE - ), - dst_start_day = list(not_epwdate_realyear, epw_date), - dst_end_day = list(not_epwdate_realyear, epw_date), - n = list(is_strint, as.integer) - ), - range = list(n = ranger(0, TRUE)), - raw = TRUE, coerce = TRUE, ... - ) +parse_epw_header_holiday <- function (header, strict = FALSE, transform = TRUE) { + obj <- get_idf_object(get_epw_idd_env(), header, EPW_CLASS$holiday, property = "num_extensible_group") + val <- get_idf_value(get_epw_idd_env(), header, EPW_CLASS$holiday, property = "extensible_group") - # check length - assert(has_len(input, 5L, step = 2L), prefix = EPW_HEADER$holiday) + update_epw_header_num_field(header, obj, val, 4L, strict = strict) - # if dst start date is given but end date is not - if (res$dst_start_day == 0L && res$dst_end_day != 0L) { - parse_issue("error_invalid_epw_dst_end_date", "epw", - "Missing daylight saving period end date field", - post = paste0("Daylight saving start date is given (", surround(res$dst_start_day),"), ", - "but end date is not." - ), ... + dst <- val[J(c(2L, 3L)), on = "field_index", value_chr] + setattr(dst, "names", c("start_day", "end_day")) + + # if dst start date and end date should have same existence status + if (any((dst["start_day"] != "0" && dst["end_day"] == "0") || + (dst["start_day"] == "0" && dst["end_day"] != "0")) + ) + { + parse_error("epw", paste("Invalid", obj$class_name[[1L]], "header"), num = 1, + post = sprintf("Invalid Daylight Saving Start/End Day pair found: ('%s', '%s'). %s", + dst["start_day"], dst["end_day"], "Should both be '0' or neither be '0'." + ), + subtype = "header" ) } - # if dst start date is not given but end date is given - if (res$dst_start_day != 0L && res$dst_end_day == 0L) { - parse_issue("error_invalid_epw_dst_end_date", "epw", - "Missing daylight saving period start date field", - post = paste0("Daylight saving end date is given (", surround(res$dst_end_day),"), ", - "but start date is not given." - ), ... - ) + + leapyear <- tolower(val$value_chr[[1L]]) == "yes" + dst <- epw_date(dst) + + if (nrow(val) <= 4L) { + if (!transform) { + return(header) + } else { + return(list(leapyear = leapyear, dst = dst, holiday = data.table())) + } } - res$dst <- c(res$dst_start_day, res$dst_end_day) - res$dst_start_day <- NULL - res$dst_end_day <- NULL + val[extensible_group > 0, extensible_field_index := seq_len(.N), by = c("object_id", "extensible_group")] + holiday <- val[J(2L), on = "extensible_field_index", epw_date(value_chr)] - # "HOLIDAYS/DAYLIGHT SAVINGS, No, 0, 0, 0" - if (length(input) == 5L && res$n == 0L) { - res$n <- NULL - res$holiday <- data.table() - return(res) + if (any(invld <- is.na(holiday))) { + i <- which(invld) + invld <- val[J(i, 2L), on = c("extensible_group", "extensible_field_index")] + issue_epw_header_parse_error_single(obj, invld, i) + } + if (any(realyr <- !not_epwdate_realyear(holiday))) { + i <- which(realyr) + invld <- val[J(i, 2L), on = c("extensible_group", "extensible_field_index")] + issue_epw_header_parse_error_single(obj, invld, i, ". Can not contain year specification.") } - # change into a data.table - holiday <- data.table(matrix(input[-c(1L:5L)], nrow = res$n, byrow = TRUE)) - setnames(holiday, c("name", "day")) - set(holiday, NULL, "index", seq_len(nrow(holiday))) - setcolorder(holiday, c("index", "name", "day")) + # check if duplicated names + name = val[J(1L), on = "extensible_field_index", value_chr] + if (anyDuplicated(tolower(name))) { + i <- which(duplicated(tolower(name))) + invld <- val[J(i, 1L), on = c("extensible_group", "extensible_field_index")] + issue_epw_header_parse_error_single(obj, invld, NULL, ". Cannot be the same as existing period names.") + } - # parse holiday - set(days, NULL, "day", epw_date(holiday$day)) + if (!transform) return(header) - tryCatch( - assert(is_unique(holiday$name), prefix = paste("Name of", EPW_HEADER$holiday)), - error_assertion = function (e) header_error_cnd(e, "holiday", "name", ...) - ) - tryCatch( - assert(not_epwdate_realyear(holiday$day), prefix = EPW_HEADER$holiday), - error_assertion = function (e) header_error_cnd(e, "holiday", "day_date", ...) - ) + holiday <- data.table(index = seq_along(holiday), name = name, day = holiday) - res$n <- NULL - res -} -# }}} -# parse_epw_header_comment1 {{{ -parse_epw_header_comment1 <- function (input, warning = TRUE, ...) { - Reduce(function (...) paste(..., sep = ","), input[-1L]) + list(leapyear = leapyear, dst = dst, holiday = holiday) } # }}} -# parse_epw_header_comment2 {{{ -parse_epw_header_comment2 <- parse_epw_header_comment1 -# }}} # parse_epw_header_period {{{ -parse_epw_header_period <- function (input, warning = TRUE, ...) { - # get number of data periods - res <- parse_epw_header_basic("period", input, len = list(len = 7L, step = 4L), - name = c("header_name", "n", "interval"), - type = list( - n = list(is_strint, as.integer), - interval = list(is_strint, as.integer) - ), - range = list(n = ranger(1L, TRUE), interval = ranger(1L, TRUE, 60L, TRUE)), - raw = TRUE, coerce = TRUE, ... - ) - res <- res[2L:3L] +parse_epw_header_period <- function (header, strict = FALSE, transform = TRUE) { + obj <- get_idf_object(get_epw_idd_env(), header, EPW_CLASS$period, property = "num_extensible_group") + val <- get_idf_value(get_epw_idd_env(), header, EPW_CLASS$period, property = "extensible_group") - if (60L %% res$interval != 0L){ - parse_issue("error_invalid_epw_data_interval", "epw", - "Invalid number of records per hour field in DATA PERIODS header", - post = paste0( - "Number of records per hour of ", surround(res$interval), - " does not result in integral number of minutes between records" - ), ... - ) + update_epw_header_num_field(header, obj, val, strict = strict) + + interval <- val$value_num[[2L]] + # check interval {{{ + if (60L %% interval != 0L){ + issue_epw_header_parse_error_single(obj, val[2L], 1L, " does not result in integral number of minutes between records.") } + # }}} - # change into a data.table - period <- data.table(matrix(input[-c(1L:3L)], nrow = res$n, byrow = TRUE)) + val[extensible_group > 0, extensible_field_index := seq_len(.N), by = c("object_id", "extensible_group")] + name <- val[J(1L), on = "extensible_field_index", value_chr] + start_day_of_week <- val[J(2L), on = "extensible_field_index", get_epw_wday(value_chr)] + start_day <- val[J(3L), on = "extensible_field_index", epw_date(value_chr)] + end_day <- val[J(4L), on = "extensible_field_index", epw_date(value_chr)] - # check if invalid number of data period - if (ncol(period) != 4L) { - parse_issue("error_invalid_epw_data_period_number", "epw", - "Invalid number of data periods field in DATA PERIODS header", - post = paste0(as.integer(ncol(period) / 4L), " data periods found but ", - "the field only indicates ", res$n, "." - ), ... - ) + # check if duplicated names {{{ + if (anyDuplicated(tolower(name))) { + i <- which(duplicated(tolower(name))) + invld <- val[J(i, 1L), on = c("extensible_group", "extensible_field_index")] + issue_epw_header_parse_error_single(obj, invld, NULL, ". Cannot be the same as existing period names.") } - setnames(period, c("name", "start_day_of_week", "start_day", "end_day")) - set(period, NULL, "index", seq_len(nrow(period))) - set(period, NULL, "start_day_of_week", get_epw_wday(period$start_day_of_week)) - set(period, NULL, "start_day", epw_date(period$start_day)) - set(period, NULL, "end_day", epw_date(period$end_day)) - setcolorder(period, c("index", "name", "start_day_of_week", "start_day", "end_day")) + # }}} - tryCatch( - assert(are_wday(period$start_day_of_week), prefix = paste("Start day of week in", EPW_HEADER$period)), - error_assertion = function (e) header_error_cnd(e, "period", "start_wday", ...) - ) - tryCatch( - assert(not_epwdate_weekday(period$start_day, zero = FALSE), prefix = EPW_HEADER$period), - error_assertion = function (e) header_error_cnd(e, "period", "start_day", ...) - ) - tryCatch( - assert(not_epwdate_weekday(period$end_day, zero = FALSE), prefix = EPW_HEADER$period), - error_assertion = function (e) header_error_cnd(e, "period", "end_day", ...) + # check start day and end day {{{ + if (any(wd <- !is_epwdate_type(start_day, c("md", "ymd")))) { + i <- which(wd) + invld <- val[J(i, 3L), on = c("extensible_group", "extensible_field_index")] + issue_epw_header_parse_error_single(obj, invld, i) + } + if (any(wd <- !is_epwdate_type(end_day, c("md", "ymd")))) { + i <- which(wd) + invld <- val[J(i, 4L), on = c("extensible_group", "extensible_field_index")] + issue_epw_header_parse_error_single(obj, invld, i) + } + + # update year value according to leapyear element in HOLIDAYS header + hol <- get_idf_value(get_epw_idd_env(), header, EPW_CLASS$holiday, field = "LeapYear Observed") + # in case holiday header is broken + if (is.na(hol$value_chr)) issue_epw_header_parse_error_single( + get_idf_object(get_epw_idd_env(), header, EPW_CLASS$holiday), hol ) + ly <- if (tolower(hol$value_chr) == "yes") TRUE else FALSE - i <- period[is_epwdate_type(start_day, "ymd") & !is_epwdate_type(end_day, "ymd"), which = TRUE] - if (length(i)) { - period[i, end_day := set_epwdate_year(end_day, lubridate::year(start_day))] + start_day <- reset_epwdate_year(start_day, ly) + end_day <- reset_epwdate_year(end_day, ly) - # check if invalid date introduced after updating year - if (any(is.na(period$end_day[i]))) { - parse_issue("error_invalid_epw_date_introduced", "epw", - "Missing year data in data period end day", - post = paste0( - "Start day of data period contains year but end day does not. ", + if (any(mism <- is_epwdate_type(start_day, "ymd") & !is_epwdate_type(end_day, "ymd"))) { + i <- which(mism) + invld <- val[J(i), on = "extensible_group"] + end_day[i] <- set_epwdate_year(end_day[i], lubridate::year(start_day[i])) + + if (any(is.na(end_day[i]))) { + issue_epw_header_parse_error_conn(obj, invld, i, 4L, 3L, + msg_pre = paste0( + "Start day contains year but end day does not. ", "Assuming same year for those data periods introduces invalid date. ", "Usually this means that the year is not a leap year but end day occurs on Feb 29." - ), - ... + ) ) } else { - parse_issue("warning_conflict_epw_period", "epw", - "Missing year data in data period end day", - post = paste0( + issue_epw_header_parse_error_conn(obj, invld, i, 4L, 3L, stop = FALSE, + msg_pre = paste0( "Start day of data period contains year but end day does not. ", "Assuming same year for those data periods." - ), - stop = FALSE, ... + ) ) + invld[J(i, 4L), on = c("extensible_group", "extensible_field_index"), + value_chr := format(end_day[i])] + header$value[invld, on = "value_id", value_chr := i.value_chr] } } + if (any(mism <- !is_epwdate_type(start_day, "ymd") & is_epwdate_type(end_day, "ymd"))) { + i <- which(mism) + invld <- val[J(i), on = "extensible_group"] + end_day[i] <- set_epwdate_year(end_day[i], lubridate::year(start_day[i])) - i <- period[!is_epwdate_type(start_day, "ymd") & is_epwdate_type(end_day, "ymd"), which = TRUE] - if (length(i)) { - period[i, end_day := set_epwdate_year(end, lubridate::year(start_day))] - - parse_issue("warning_conflict_epw_period", "epw", - "Missing year data in data period start day", - post = paste0( + issue_epw_header_parse_error_conn(obj, invld, i, 4L, 3L, stop = FALSE, + msg_pre = paste0( "End day of data period contains year but start day does not. ", "Assuming non-real-year for those data periods." - ), - stop = FALSE, ... + ) ) + invld[J(i, 4L), on = c("extensible_group", "extensible_field_index"), + value_chr := format(end_day[i])] + header$value[invld, on = "value_id", value_chr := i.value_chr] } - # for real year, check if day of week matches - i <- period[is_epwdate_type(start_day, "ymd") & start_day_of_week != wday(start_day), which = TRUE] - if (length(i)) { - parse_issue("warning_mismatch_epw_period_dayofweek", "epw", - "Mismatched start day of week", - post = paste0("The actual start day (", period$start_day[i], ") of ", - "data period #", period$index[i], " ", surround(period$name[i]) ," is ", - wday(period$start_day[i], label = TRUE), - " but specified as ", - wday(period$start_day_of_week[i], label = TRUE), - collapse = "\n" - ), - stop = FALSE, ... + if (any(mism <- is_epwdate_type(start_day, "ymd") & start_day_of_week != wday(start_day))) { + i <- which(mism) + invld <- val[J(i), on = "extensible_group"] + + parse_warn("epw", paste("Invalid", obj$class_name, "header"), num = length(i), + post = paste0( + "Actual start day of week mismatches with specified.\n", + paste0(collapse = "\n", sprintf( + " #%s| Invalid %s found: '%s', with actual day of week being '%s' for %s ('%s')", + lpad(seq_along(i), "0"), + invld[J(2L), on = "extensible_field_index", field_name], + invld[J(2L), on = "extensible_field_index", value_chr], + wday(start_day, TRUE)[i], + invld[J(3L), on = "extensible_field_index", field_name], + invld[J(3L), on = "extensible_field_index", value_chr] + )) + ) ) } # check if not real year and end day smaller than start day - if (period[as_date(start_day) > as_date(align_epwdate_type(end_day, start_day)), .N]) { - parse_issue("error_invalid_epw_data_period_endday", "epw", - "Invalid data period end day", + if (any(mism <- as_date(start_day) > as_date(align_epwdate_type(end_day, start_day)))) { + i <- which(mism) + invld <- val[J(i), on = "extensible_group"] + issue_epw_header_parse_error_conn(obj, invld, i, 4L, 3L, ". Should be equal as or later than %s ('%s').") + } + # }}} + + # check if leap day is found in period but leap year is not allowed in the header {{{ + if (!ly && + any(ld <- format(as.Date.EpwDate(start_day), "%m-%d") == "02-29" | + format(as.Date.EpwDate(end_day), "%m-%d") == "02-29") + ) + { + i <- which(ld) + invld <- val[J(i), on = "extensible_group"] + parse_error("epw", paste("Invalid", obj$class_name[[1L]], "header"), num = sum(i), post = paste0( - "Currently rewinded data period is not supported. ", - "End day should always be euqal as or later than start day." - ), ... + "EPW file header '", EPW_CLASS$holiday, "' indicates no leap year ", + "but start/end day on Feb 29 found.\n", + paste0(collapse = "\n", sprintf( + " #%s| %s '%s' & %s '%s'", + lpad(seq_along(i), "0"), + invld[J(3L), on = "extensible_field_index", field_name], + invld[J(3L), on = "extensible_field_index", value_chr], + invld[J(4L), on = "extensible_field_index", field_name], + invld[J(4L), on = "extensible_field_index", value_chr] + )) + ), + subtype = "header" ) } + # }}} - res$n <- NULL - res$period <- period - res -} -# }}} -# warn_epw_header_na {{{ -warn_epw_header_na <- function (input, res) { - if (!any(na <- vlapply(res, is.na))) return() - - nm <- gsub("_", " ", names(res[na]), fixed = TRUE) - - parse_issue("warning_invalid_epw_header_design", "epw", - paste("Invalid", input[[1]], "header data format"), - num = sum(na), - post = sprintf("[%s]: failed to parse value '%s' at field position #%i. NA was introduced.", - lpad(seq_along(nm), "0"), unlist(input[na]), which(na) - ), - stop = FALSE - ) + # check each period does not overlap {{{ + n <- val$value_num[[1]] + if (n > 1) { + comb <- utils::combn(seq_len(n), 2L, simplify = FALSE) - res -} -# }}} -# header_data_type_fun {{{ -header_data_type_fun <- function (type, coerce = TRUE, raw = FALSE, strict = TRUE, ...) { - factory <- function (before, after = NULL) { - if (!coerce) { - function (x) {assert(before(x), ...); x} - } else if (strict) { - function (x) {assert(before(x), ...); after(x)} - } else { - function (x) suppressWarnings(after(x)) + for (i in comb) { + overlapped <- !(start_day[i[1L]] > end_day[i[2L]] || end_day[i[1L]] < start_day[i[2L]]) + if (overlapped) { + parse_error("epw", paste("Invalid", obj$class_name[[1L]], "header"), num = 1L, + post = paste0( + "Each data period should not have overlapped with each other.\n", + paste0(collapse = "\n", sprintf( + "Data Period %i [%s, %s] overlapped with Data Period %i [%s, %s]", + i[2L], start_day[i[2L]], end_day[i[2L]], + i[1L], start_day[i[1L]], end_day[i[1L]] + )) + ) + ) + } } } + # }}} + + # update format + val[J(3L), on = "extensible_field_index", value_chr := format(start_day)] + val[J(4L), on = "extensible_field_index", value_chr := format(end_day)] + header$value[val, on = "value_id", value_chr := i.value_chr] - # if input is a list of function - if (is.list(type)) return(factory(type[[1]], type[[2]])) + if (!transform) return(header) - switch(type, - int = if (raw) factory(is_strint, as.integer) else factory(is_integer, as.integer), - dbl = if (raw) factory(is_strnum, as.double) else factory(is_number, as.double), - chr = factory(is_string, as.character), - epwdate = factory(is_epwdate, epw_date), - integer = if (raw) factory(are_strint, as.integer) else factory(are_integer, as.integer), - double = if (raw) factory(are_strnum, as.double) else factory(are_number, as.double), - character = factory(are_string, as.character), - stop("Invalid type specification") + list( + interval = interval, + period = data.table( + index = seq_along(name), + name = name, + start_day_of_week = get_epw_wday(start_day_of_week, TRUE), + start_day = start_day, + end_day = end_day + ) ) } # }}} -# header_error_cnd {{{ -header_error_cnd <- function (cnd, header_type, check_type, idx = NULL, raw = TRUE, stop = TRUE, ...) { - # error message from the original assertion or coercion - msg <- conditionMessage(cnd) +# validate_epw_header {{{ +validate_epw_header <- function (header, strict = FALSE) { + # validation against IDD + valid <- validate_epw_header_basic(header) + assert_valid(valid, epw = TRUE) - # new error type according to header name - err_type <- c(paste("error_invalid_epw_header", header_type, check_type, sep = "_")) + parse_epw_header_design(header, strict = strict, transform = FALSE) + parse_epw_header_typical(header, strict = strict, transform = FALSE) + parse_epw_header_ground(header, strict = strict, transform = FALSE) + parse_epw_header_holiday(header, strict = strict, transform = FALSE) + parse_epw_header_period(header, strict = strict, transform = FALSE) - # position message - if (!is.null(idx)) { - if (is.character(idx)) { - nm <- gsub("_", " ", idx) - } else { - nm <- paste0("#", idx) + header +} +# }}} +# validate_epw_header_basic {{{ +validate_epw_header_basic <- function (header, class = NULL, field = NULL) { + chk <- level_checks("final") + chk$auto_field <- FALSE + chk$reference <- FALSE + + if (is.null(class)) { + valid <- validate_on_level(get_epw_idd_env(), header, level = chk) + } else { + dt_object <- get_idf_object(get_epw_idd_env(), header, class) + dt_value <- get_idf_value(get_epw_idd_env(), header, class, field = field) + valid <- validate_on_level(get_epw_idd_env(), header, dt_object, dt_value, level = chk) + } + + # exclude incomplete extensible group for soil properties fields in 'GROUND + # TEMPERATURES' + if (nrow(valid$incomplete_extensible) && EPW_CLASS$ground %chin% valid$incomplete_extensible$class_name) { + add_field_property(get_epw_idd_env(), valid$incomplete_extensible, "extensible_group") + valid$incomplete_extensible[extensible_group > 0, + extensible_field_index := seq_len(.N), by = c("object_id", "extensible_group")] + + ext_grp <- valid$incomplete_extensible[J(EPW_CLASS$ground), on = "class_name", + by = "extensible_group", list(incomplete = anyNA(value_chr[-(2:4)])) + ][J(FALSE), on = "incomplete", nomatch = NULL, extensible_group] + + if (length(ext_grp)) { + valid$incomplete_extensible <- valid$incomplete_extensible[ + !J(EPW_CLASS$ground, ext_grp), + on = c("class_name", "extensible_group")] } - msg <- paste(nm, "in", msg) + + set(valid$incomplete_extensible, NULL, c("extensible_group", "extensible_field_index"), NULL) } - if (raw) { - parse_issue(err_type, "epw", - title = paste("Invalid", EPW_HEADER[[header_type]], "header data format"), - post = msg, stop = stop, ... + setattr(valid, "class", c("EpwValidity", class(valid))) + valid +} +# }}} +# update_epw_header_num_field {{{ +update_epw_header_num_field <- function (header, dt_object, dt_value, i = 1L, strict = FALSE) { + if ((num <- max(dt_value$extensible_group)) > 0 && !is.na(dt_value$value_num[i]) && dt_value$value_num[i] != num) { + if (strict) { + parse_error("epw", paste("Invalid", dt_object$class_name, "header"), num = 1, + post = sprintf( + "%s ('%s') did not match the actual number ('%s').", + dt_value$field_name[i], + dt_value$value_num[i], + num + ), + subtype = "header_num_field" + ) + } + + parse_warn("epw", paste("Invalid", dt_object$class_name, "header"), num = 1, + post = sprintf( + "%s ('%s') did not match the actual number ('%s'). The later will be used.", + dt_value$field_name[i], + dt_value$value_num[i], + num + ), + subtype = "header_num_field" ) - } else { - abort(err_type, msg) + + set(dt_value, i, "value_num", as.double(dt_object$num_extensible_group)) + set(dt_value, i, "value_chr", as.character(dt_object$num_extensible_group)) + + # update the value table + header$value[dt_value[i], on = "value_id", `:=`( + value_chr = i.value_chr, value_num = i.value_num)] } + + header +} +# }}} +# issue_epw_header_parse_error_single {{{ +issue_epw_header_parse_error_single <- function (obj, val, i = NULL, msg_post = "") { + if (is.null(i)) i <- seq_len(nrow(val)) + parse_error("epw", paste("Invalid", obj$class_name[[1L]], "header"), num = length(i), + post = sprintf(" #%s| Invalid %s found: '%s'%s", + lpad(seq_along(i), "0"), val$field_name[i], val$value_chr[i], msg_post + ), + subtype = "header" + ) } # }}} -# get_epw_header_data {{{ -get_epw_header_data <- function (epw_header, name) { - nm <- name - epw_header[name == EPW_HEADER[[nm]], contents][[1L]] +# issue_epw_header_parse_error_conn {{{ +issue_epw_header_parse_error_conn <- function (obj, val, i, index1, index2, fmt_conn = ", with %s being '%s'", msg_pre = NULL, stop = TRUE) { + title <- paste("Invalid", obj$class_name[[1L]], "header") + fmt <- paste0(" #%s| Invalid %s found: '%s'", fmt_conn) + post <- sprintf(fmt, lpad(seq_along(i), "0"), + val[J(index1), on = "extensible_field_index", field_name], + val[J(index1), on = "extensible_field_index", value_chr], + val[J(index2), on = "extensible_field_index", field_name], + val[J(index2), on = "extensible_field_index", value_chr] + ) + if (!is.null(msg_pre)) { + post <- paste0(msg_pre, "\n", paste0(post, collapse = "\n")) + } + + if (stop) { + parse_error("epw", title, num = length(i), post = post, subtype = "header") + } else { + parse_warn("epw", title, num = length(i), post = post, subtype = "header") + } } # }}} # get_epw_wday {{{ -get_epw_wday <- function (x, label = FALSE, abbr = FALSE){ - wd <- c("Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday", "Sunday") +DAYOFWEEK <- c("Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday", "Sunday") +get_epw_wday <- function (x, label = FALSE, abbr = FALSE, monday_start = TRUE){ + wd <- if (monday_start) DAYOFWEEK else c(DAYOFWEEK[7L], DAYOFWEEK[-7L]) res <- if (label) rep(NA_character_, length(x)) else rep(NA_integer_, length(x)) @@ -1226,7 +768,7 @@ get_epw_wday <- function (x, label = FALSE, abbr = FALSE){ res[is_ok] <- as.integer(x[is_ok]) } else { if (abbr) { - res[is_ok] <- stri_sub(wd[x[is_ok]], 3L) + res[is_ok] <- stri_sub(wd[x[is_ok]], to = 3L) } else { res[is_ok] <- wd[x[is_ok]] } @@ -1249,9 +791,9 @@ get_epw_wday <- function (x, label = FALSE, abbr = FALSE){ } # }}} # get_epw_month {{{ +MONTH <- c("January", "February", "March", "April", "May", "June", "July", "August", "September", "October", "November", "December") get_epw_month <- function (x, label = FALSE){ - mon <- c("January", "February", "March", "April", "May", "June", "July", "August", "September", "October", "November", "December") - match_in_vec(x, mon, label = label) + match_in_vec(x, MONTH, label = label) } # }}} # EpwDate {{{ @@ -1306,7 +848,7 @@ set_epwdate_year <- function(x, year) { assign_epwdate(tmp) } align_epwdate_type <- function (x, to) { - assert(have_same_len(x, to)) + assert_same_len(x, to) t <- get_epwdate_type(x) # only for julian and month day can_align <- t >= EPWDATE_TYPE$jul & t <= EPWDATE_TYPE$md @@ -1325,8 +867,8 @@ reset_epwdate_year <- function (x, leapyear) { # expect empty and real year t <- get_epwdate_type(x) if (any(t == EPWDATE_TYPE$nth | t == EPWDATE_TYPE$last)) warning("Cannot reset year of nth or last format date.") - x[t == EPWDATE_TYPE$jul] <- set_epwdate_year(x, if (leapyear) EPWDATE_YEAR$leap$jul else EPWDATE_YEAR$noleap$jul) - x[t == EPWDATE_TYPE$md] <- set_epwdate_year(x, if (leapyear) EPWDATE_YEAR$leap$md else EPWDATE_YEAR$noleap$md) + x[t == EPWDATE_TYPE$jul] <- set_epwdate_year(x[t == EPWDATE_TYPE$jul], if (leapyear) EPWDATE_YEAR$leap$jul else EPWDATE_YEAR$noleap$jul) + x[t == EPWDATE_TYPE$md] <- set_epwdate_year(x[t == EPWDATE_TYPE$md], if (leapyear) EPWDATE_YEAR$leap$md else EPWDATE_YEAR$noleap$md) x } ymd_to_md <- function (x) { @@ -1549,7 +1091,7 @@ is_EpwDate <- function (x) { # }}} #' @export # format.EpwDate {{{ -format.EpwDate <- function (x, m_spc = FALSE, ...) { +format.EpwDate <- function (x, m_spc = TRUE, ...) { on.exit(Sys.setlocale("LC_TIME", Sys.getlocale("LC_TIME")), add = TRUE) Sys.setlocale("LC_TIME", "C") t <- get_epwdate_type(x) @@ -1651,23 +1193,25 @@ as.POSIXct.EpwDate <- function (x, ...) { } # }}} # }}} -## data -# read_epw_data {{{ -read_epw_data <- function (path) { +## DATA +# parse_epw_data {{{ +parse_epw_data <- function (path) { num_header <- 8L + idd_env <- get_epw_idd_env() + cls <- idd_env$class[J(EPW_CLASS$data), on = "class_name"] + type <- unlist(get_epw_data_type()) + # parse the rest of file {{{ # colnames refers to column "Long Name" in Table 2.8 in # "AuxiliaryPrograms.pdf" of EnergyPlus 8.6 # TODO: fread will directly skip those few abnormal rows header_epw_data <- fread(path, sep = ",", skip = num_header, nrows = 0L, header = FALSE) - if (ncol(header_epw_data) != 35L) { - parse_issue("error_invalid_epw_data_column_num", "epw", - "Invalid weather data column", num = 1L, - post = paste0( - "Expected 35 fields in EPW data instead of ", - surround(ncol(header_epw_data)), " in current file" - ) + if (ncol(header_epw_data) != cls$min_fields) { + parse_error("epw", "Invalid weather data column", num = 1L, + post = sprintf("Expected %i fields in EPW weather data instead of '%i' in current file", + cls$min_fields, ncol(header_epw_data)), + subtype = "data_column" ) } @@ -1676,22 +1220,8 @@ read_epw_data <- function (path) { # NAs would result. # This means that even if a column is specified as integer in colClasses, it # still could be resulted as character or double. - epw_data <- fread(path, skip = num_header, col.names = names(EPW_TYPE), colClasses = unlist(EPW_TYPE, use.names = FALSE)) - # check column types - int_chk <- epw_data[, vapply(.SD, is.integer, logical(1L)), .SDcols = names(which(unlist(EPW_TYPE) == "integer"))] - dbl_chk <- epw_data[, vapply(.SD, is.double, logical(1L)), .SDcols = names(which(unlist(EPW_TYPE) == "double"))] - if (!any(int_chk)) { - parse_issue("error_invalid_epw_data_integer_type", "epw", - "Failed to parse variables as integer", num = sum(!int_chk), - post = paste0("Failed variables: ", collapse(names(which(!int_chk)))) - ) - } - if (!any(dbl_chk)) { - parse_issue("error_invalid_epw_data_double_type", "epw", - "Failed to parse variables as double", num = sum(!int_chk), - post = paste0("Failed variables: ", collapse(names(which(!int_chk)))) - ) - } + epw_data <- suppressWarnings(fread(path, skip = num_header, col.names = names(type), colClasses = type)) + epw_data <- check_epw_data_type(epw_data, type) # }}} # handle abnormal values of present weather codes @@ -1700,851 +1230,726 @@ read_epw_data <- function (path) { stri_sub(present_weather_codes[stri_sub(present_weather_codes, 1L, 1L) == "'"], 1L, 1L) <- "" stri_sub(present_weather_codes[stri_sub(present_weather_codes, -1L, -1L) == "'"], -1L, -1L) <- "" # if not a 9-length string, including empty string "", replace with default missing code - present_weather_codes[nchar(present_weather_codes) != 9L] <- EPW_MISSING_CODE$present_weather_codes + present_weather_codes[nchar(present_weather_codes) != 9L] <- + get_idd_field(idd_env, EPW_CLASS$data, "present_weather_codes", underscore = TRUE, property = "missing_chr")$missing_chr # replace non-digits with "9" stri_replace_all_charclass(present_weather_codes, "[^0-9]", "9") }] - # add line index - set(epw_data, NULL, "line", seq_len(nrow(epw_data)) + num_header) - epw_data } # }}} -# add_epw_raw_string {{{ -add_epw_raw_string <- function (dt, exclude = c("datetime", "line")) { - dt[, string := Reduce(function (...) paste(..., sep = ","), .SD), .SDcols = setdiff(names(EPW_TYPE), exclude)] -} -# }}} -# create_epw_datetime_sequence {{{ -create_epw_datetime_sequence <- function (start, end, interval, tz = "UTC", leapyear = FALSE) { - if (is_epwdate(start)) start <- reset_epwdate_year(start, leapyear) - if (is_epwdate(end)) end <- reset_epwdate_year(end, leapyear) +# match_epw_data {{{ +match_epw_data <- function (epw_data, epw_header, period = NULL, tz = "UTC", check_minute = FALSE) { + dp <- parse_epw_header_period(epw_header) + holiday <- parse_epw_header_holiday(epw_header) + data_period <- match_epw_data_period(dp$period, period) - start <- as_date(start) - end <- as_date(end) + # check if real year + realyear <- get_epwdate_type(data_period$start_day) == EPWDATE_TYPE$ymd - step <- 60L / interval - offset <- lubridate::minutes(step) + # get datetime range for each data period + data_period[, by = "index", c("year", "month", "day", "hour", "minute", "step", "num") := + get_epw_datetime_range(start_day, end_day, dp$interval, holiday$leapyear)] - seq(lubridate::force_tz(start + offset, tzone = tz), - lubridate::force_tz(lubridate::as_datetime(end + lubridate::hours(24L)), tzone = tz), - by = paste(step, "mins") - ) + col_on <- c("year", "month", "day", "hour") + if (check_minute) col_on <- c(col_on, "minute") + + # extract date time + if (!has_names(epw_data, "line")) { + set(epw_data, NULL, "line", seq_len(nrow(epw_data))) + on.exit(set(epw_data, NULL, "line", NULL)) + } + dt <- epw_data[, .SD, .SDcols = c("line", "datetime", col_on)] + + # find first match + if (length(unique(realyear)) == 1L) { + if (!realyear[[1]]) col_on <- setdiff(col_on, "year") + matched <- dt[data_period, on = col_on][, by = "index", .SD[1L]] + } else { + matched <- rbindlist(use.names = TRUE, + lapply(split(data_period, by = "index"), function (dp) { + on <- col_on + if (!realyear[dp$index]) on <- setdiff(on, "year") + dt[dp, on = col_on, mult = "first"] + }) + ) + } + + # stop if first match was not found + if (any(i <- is.na(matched$line))) { + invld <- matched[i] + set(invld, NULL, "string", do.call(combine_date, invld[, .SD, .SDcols = col_on])) + set(invld, NULL, "line", seq_len(nrow(invld))) + set(invld, NULL, "suffix", sprintf(" is missing for data period #%i '%s'", invld$index, invld$name)) + + parse_error("epw", "Invalid WEATHER DATA", invld, subtype = "data", loc_name = "DateTime") + } + + # check core weather data range on the row of first day, just as EnergyPlus does + range <- get_epw_data_range("valid", unlist(EPW_REPORT_RANGE, FALSE, FALSE)) + line_range <- check_epw_data_range(epw_data[matched$line], range) + if (length(line_range)) { + # only show the first invalid for each data period + m <- matched[J(line_range), on = "line", mult = "first", nomatch = NULL] + invld <- epw_data[m, on = "line"] + + # get the first invalid variable + invld[, by = "line", variable := { + names(range)[which(!apply2_lgl(mget(names(range)), range, in_range))] + }] + + # get field name + nm <- get_idd_field(get_epw_idd_env(), EPW_CLASS$data, invld$variable, underscore = TRUE)$field_name + set(invld, NULL, "field_name", nm) + + # construct message + invld <- invld[, string := sprintf( + "Line %i: First '%s' ('%s') is out of prescribed range %s for Data Period #%i '%s'.", + line, field_name, get(variable), format(range[[variable]]), index, name) + ] + parse_error("epw", "Invalid WEATHER DATA", num = nrow(invld), subtype = "data", + post = paste0(invld$string, collapse = "\n") + ) + } + + # validate_datetime_range {{{ + validate_datetime_range <- function (datetime, matched, realyear) { + if (length(datetime) - matched$line + 1L < length(matched$num)) { + parse_error("epw", paste("Invalid WEATHER DATA"), subtype = "data", + post = sprintf("%i rows of weather data (starting from row %i) are expected for data period #%i '%s', but only '%i' were found.", + matched$num, matched$line, matched$index, matched$name, length(datetime) - matched$line + 1L + ) + ) + } + index <- seq(matched$line, length.out = matched$num) + datetime <- datetime[index] + + if (any(i <- is.na(datetime))) return(which(i)[[1L]]) + + lubridate::year(datetime) <- get_epw_datetime_year(matched$year, matched$start_day, matched$end_day, matched$num, matched$step) + steps <- as.numeric(difftime(datetime[-1L], datetime[-matched$num], units = "mins")) + + which(steps != matched$step) + } + # }}} + + # validate time step for each data period + for (i in seq_len(nrow(matched))) { + invld <- validate_datetime_range(dt$datetime, matched[i], realyear) + + if (length(invld)) { + # first actual index + i <- i[[1L]] + 1L + invld <- epw_data[i] + + set(invld, NULL, "string", paste(do.call(combine_date, invld[, .SD, .SDcols = col_on]), "...")) + set(invld, NULL, "suffix", sprintf(" is found but date time '%s' is expected for data period #%i '%s'", + do.call(combine_date, matched[, .SD, .SDcols = col_on]), + matched$index, matched$name + )) + parse_error("epw", paste("Invalid WEATHER DATA"), invld, subtype = "data") + } + } + + set(matched, NULL, setdiff(names(matched), c("index", "line", "num")), NULL) + setnames(matched, "line", "row") } # }}} -# create_epw_datetime_components {{{ -create_epw_datetime_components <- function (start, end, interval, tz = "UTC", leapyear = FALSE) { +# get_epw_datetime_range {{{ +get_epw_datetime_range <- function (start, end, interval, leapyear = FALSE, realyear = FALSE) { if (is_epwdate(start)) start <- reset_epwdate_year(start, leapyear) if (is_epwdate(end)) end <- reset_epwdate_year(end, leapyear) start <- as_date(start) end <- as_date(end) - step <- as.integer(60L / interval) - offset <- lubridate::minutes(step) - - s <- lubridate::force_tz(start + offset, tzone = tz) - e <- lubridate::force_tz(end + offset + lubridate::days(1L), tzone = tz) - - # get hour - h <- rep(1L:24L, each = interval, times = difftime(e, s, units = "days")) - - # get minute - start_min <- if (interval == 1L) 0L else step - m <- rep(seq(start_min, 60L, length.out = interval), times = difftime(e, s, units = "hours")) + step <- 60L / interval + if (!test_integerish(step, len = 1L)) abort("Invalid interval") - # get year, month and day - ymd <- rep(seq(as_date(s), as_date(e) - lubridate::days(1L), by = "day"), - each = 24 * interval - ) + num <- as.numeric(difftime(end + lubridate::days(1L), start, units = "hours")) * interval - data.table( - year = as.integer(lubridate::year(ymd)), - month = as.integer(lubridate::month(ymd)), - day = as.integer(lubridate::mday(ymd)), - hour = h, minute = m + list( + year = lubridate::year(start), + month = lubridate::month(start), + day = lubridate::mday(start), + hour = 1L, + minute = if (interval == 1L) 0L else step, + step = step, + num = as.integer(num) ) } # }}} -# match_epw_data_period {{{ -match_epw_data_period <- function (epw_data, data_period, interval, leapyear, warning = FALSE) { - # check if real year {{{ - if (get_epwdate_type(data_period$start_day) < EPWDATE_TYPE$ymd) { - realyear <- FALSE - } else if (get_epwdate_type(data_period$start_day) == EPWDATE_TYPE$ymd){ - realyear <- TRUE +# get_epw_datetime_year {{{ +get_epw_datetime_year <- function (start_year, start_day, end_day, num, step) { + # update year value + # year value does not change + if (lubridate::year(start_day) == lubridate::year(end_day)) { + # need to change the year value for the last day + if (format(as_date(end_day), "%m-%d") == "12-31") { + c(rep(start_year, num - 60 / step), rep(start_year + 1L, 60 / step)) + } else { + rep(start_year, num) + } + # if real year, it is possible that multiple years exist } else { - # just in case - stop("Invalid EPW date type.") + lubridate::year(seq( + as_datetime(start_day) + lubridate::minutes(step), + as_datetime(end_day) + lubridate::days(24L), + by = paste(step, "mins") + )) } - # }}} +} +# }}} +# get_epw_data_range {{{ +get_epw_data_range <- function (type = c("valid", "exist"), field = NULL) { + type <- match.arg(type) + prop <- c("type_enum", "field_name_us") - data <- match_epw_data_datetime(epw_data, data_period$index, data_period$name, - data_period$start_day, data_period$end_day, interval, leapyear, realyear - ) + if (type == "valid") { + prop <- c(prop, "has_range", "minimum", "lower_incbounds", "maximum", "upper_incbounds") + } else { + prop <- c(prop, "has_exist", "exist_minimum", "exist_lower_incbounds", "exist_maximum", "exist_upper_incbounds") + } + + fld <- get_idd_field(get_epw_idd_env(), EPW_CLASS$data, field, prop, underscore = TRUE) - # check if there is any NA in data {{{ - if (nrow(na.omit(data, invert = TRUE))) { - na <- na.omit(data, invert = TRUE) - parse_issue("error_invalid_epw_data_data", "epw", - paste0("Invalid data found for ", nm), - data = add_epw_raw_string(na) + if (type == "exist") { + setnames(fld, + c("has_exist", "exist_minimum", "exist_lower_incbounds", "exist_maximum", "exist_upper_incbounds"), + c("has_range", "minimum", "lower_incbounds", "maximum", "upper_incbounds") ) } - # }}} - # get row range {{{ - from <- epw_data[line == data$line[1L], which = TRUE] - to <- from + nrow(data) - 1L - # }}} + # set limits to Inf for numeric values that do not have ranges + fld[J(c(IDDFIELD_TYPE$integer, IDDFIELD_TYPE$real), FALSE), on = c("type_enum", "has_range"), `:=`(maximum = Inf, minimum = -Inf)] + fld[J(TRUE, NA_real_), on = c("has_range", "maximum"), `:=`(maximum = Inf)] + fld[J(TRUE, NA_real_), on = c("has_range", "minimum"), `:=`(minimum = -Inf)] + fld[, `:=`(range = list(ranger(minimum, lower_incbounds, maximum, upper_incbounds))), by = field_id] - # find missing or out-of-range value - abnormal <- find_epw_data_abnormal_line(data, offset = from - 1L, warning, - period_name = paste0("#", data_period$index, " ", surround(data_period$name), - " (", 60/interval, " mins interval)" - ), from = from - ) + range <- fld$range + setattr(range, "names", fld$field_name_us) + # exclude non-applicable + range[!names(range) %chin% c("year", "month", "day", "hour", "minute", "data_source", "present_weather_codes")] +} +# }}} +# get_epw_data_missing_code {{{ +get_epw_data_missing_code <- function () { + fld <- get_idd_field(get_epw_idd_env(), EPW_CLASS$data, + property = c("missing_chr", "missing_num", "field_name_us", "type_enum"))[ + !J(NA_character_), on = "missing_chr"] - # update datetime and minute column {{{ - set(epw_data, from:to, c("datetime", "minute"), - list(create_epw_datetime_sequence(data_period$start_day, data_period$end_day, interval, leapyear = leapyear), - data$minute_in - ) - ) - # reset year - set(epw_data, NULL, "datetime", {d <- epw_data$datetime; lubridate::year(d) <- epw_data$year; d}) - # }}} + setnames(fld, c("missing_chr", "missing_num"), c("value_chr", "value_num")) - list(from = from, to = to, missing = abnormal[1L], out_of_range = abnormal[2L]) + setattr(get_value_list(fld), "names", fld$field_name_us) } # }}} -# match_epw_data_datetime {{{ -match_epw_data_datetime <- function (epw_data, index, name, start, end, interval, - leapyear, realyear, check_minute = FALSE) { - if (realyear && check_minute) { - datetime <- create_epw_datetime_sequence(start, end, interval, leapyear = leapyear) +# get_epw_data_init_value {{{ +get_epw_data_init_value <- function () { + fld <- get_idd_field(get_epw_idd_env(), EPW_CLASS$data, + property = c("default_chr", "default_num", "field_name_us", "type_enum"))[ + !J(NA_character_), on = "default_chr"] - # find first match - day_1 <- datetime[1L] - l_1 <- epw_data[J(day_1), on = "datetime", mult = "first", line] + setnames(fld, c("default_chr", "default_num"), c("value_chr", "value_num")) + setattr(get_value_list(fld), "names", fld$field_name_us) +} +# }}} +# get_epw_data_fill_action {{{ +get_epw_data_fill_action <- function (type = c("missing", "out_of_range")) { + type <- match.arg(type) + if (type == "missing") { + EPW_REPORT_MISSING } else { - datetime <- create_epw_datetime_components(start, end, interval, leapyear = leapyear) - - # find first match - day_1 <- datetime[1L] - col_on <- if (realyear) c("year", "month", "day", "hour") else c("month", "day", "hour") - l_1 <- epw_data[day_1, on = col_on, mult = "first", line] + EPW_REPORT_RANGE } +} +# }}} +# get_epw_data_unit {{{ +get_epw_data_unit <- function (field = NULL) { + fld <- get_idd_field(get_epw_idd_env(), EPW_CLASS$data, field, c("units", "field_name_us"), underscore = TRUE)[ + !J(NA_character_), on = "units"] - # name for error printing - nm <- paste0("data period #", index, " ", surround(name), " (", (60 / interval), " mins interval)") + setattr(as.list(fld$units), "names", fld$field_name_us) +} +# }}} +# get_epw_data_type {{{ +get_epw_data_type <- function (field = NULL) { + fld <- get_idd_field(get_epw_idd_env(), EPW_CLASS$data, field, c("type", "field_name_us"), underscore = TRUE) - # find the first match {{{ - if (!length(l_1) || is.na(l_1)) { - if (realyear) { - if (check_minute) { - first_date <- day_1 - } else { - first_date <- combine_date(day_1$year, day_1$month, day_1$day, day_1$hour) - } - } else { - first_date <- combine_date(NULL, day_1$month, day_1$day, day_1$hour) - } + fld[J("real"), on = "type", type := "double"] + fld[J("alpha"), on = "type", type := "character"] + setattr(as.list(fld$type), "names", fld$field_name_us) +} +# }}} +# check_epw_data_range{{{ +check_epw_data_range <- function (epw_data, range, merge = TRUE) { + m <- epw_data[, apply2(.SD, range, function (x, y) !is.na(x) & in_range(x, y)), .SDcols = names(range)] - parse_issue("error_epw_data_first_date", "epw", - paste0("Failed to find start date time for ", nm), - num = 1L, - post = paste0("Failed to find date time ", first_date, " in weather data ") - ) - } - # }}} + if (!merge) return(lapply(m, function (x) which(!x))) - # combine - if (realyear && check_minute) { - l <- seq_along(datetime) - joined <- set(epw_data[J(l), on = "line"], NULL, "datetime1", datetime) - } else { - setnames(datetime, paste0(names(datetime), "_in")) - l <- seq_len(nrow(datetime)) + (l_1 - 1L) - joined <- cbind(epw_data[J(l), on = "line"], datetime) - } + assert_names(names(epw_data), must.include = "line") + m[, c(names(range)) := lapply(.SD, function (x) {x[x == FALSE] <- NA;x}), .SDcols = names(range)] + set(m, NULL, "line", epw_data$line) + na.omit(m, invert = TRUE)$line +} +# }}} +# check_epw_data_type{{{ +check_epw_data_type <- function (epw_data, type = NULL) { + if (is.null(type)) type <- unlist(get_epw_data_type()) + assert_names(type) + assert_data_table(epw_data) + assert_names(names(epw_data), must.include = names(type)) + setcolorder(epw_data, names(type)) - # find missing or invalid datetime {{{ - if (any(is.na(joined$datetime))) { - miss <- joined[is.na(datetime)] - if (realyear) { - if (check_minute) { - miss[, string := as.character(datetime1)] + type_detected <- epw_data[, vcapply(.SD, typeof)] + for (j in seq_along(type)) { + if (type[[j]] == "integer") { + if (type_detected[[j]] == "integer") { + # remove all derived S3 class + set(epw_data, NULL, j, as.integer(epw_data[[j]])) } else { - miss[, string := combine_date(year_in, month_in, day_in, hour_in)] + parse_error("epw", "Failed to parse variables as integer", num = 1L, + post = paste0("Failed variables: ", + get_idd_field(idd_env, EPW_CLASS$data, names(type)[[j]], underscore = TRUE)$field_name), + subtype = "data_type" + ) } - } else { - miss[, string := combine_date(NULL, month_in, day_in, hour_in)] - } - parse_issue("error_invalid_epw_data_date", "epw", - paste0("Missing or invalid date found for ", nm), - data = miss[, string := paste0("input - , but expecting - ", string)] - ) - } - # }}} - - # find mismatched {{{ - if (realyear) { - if (check_minute) { - q <- quote(datetime != datetime1) - } else { - q <- quote(year != year_in | month != month_in | day != day_in | hour != hour_in) - } - } else { - q <- quote(month != month_in | day != day_in | hour != hour_in) - } - if (nrow(joined[eval(q)])) { - mismatched <- joined[eval(q)] - - if (realyear) { - if (check_minute) { - mismatched[, string := paste0( - "input - ", as.character(datetime), ", ", - "but expecting - ", as.character(datetime1)) - ] + } else if (type[[j]] == "double") { + # it is ok to coerce integer to double + if (type_detected[[j]] %chin% c("integer", "double")) { + # remove all derived S3 class + set(epw_data, NULL, j, as.double(epw_data[[j]])) } else { - mismatched[, string := paste0( - "input - ", combine_date(year, month, day, hour), ", ", - "but expecting - ", combine_date(year_in, month_in, day_in, hour_in)) - ] + parse_error("epw", "Failed to parse variables as double", num = 1L, + post = paste0("Failed variables: ", + get_idd_field(idd_env, EPW_CLASS$data, names(type)[[j]], underscore = TRUE)$field_name), + subtype = "data_type" + ) } } else { - mismatched[, string := paste0( - "input - ", combine_date(NULL, month, day, hour), ", ", - "but expecting - ", combine_date(NULL, month_in, day_in, hour_in)) - ] + # remove all derived S3 class + set(epw_data, NULL, j, as.character(epw_data[[j]])) } - - parse_issue("error_mismatch_epw_data_date", "epw", - paste0("Date time mismatch for ", nm), - data = mismatched - ) } - # }}} - # check if leap day is found in the data but leap year is not allowed in the header {{{ - if (nrow(joined[month == 2L & day == 29L]) && !leapyear) { - parse_issue("error_invalid_epw_data_leapday", "epw", - paste0("Data on Feb 29 found for ", nm), - data = add_epw_raw_string(joined[month == 2L & day == 29L]), - post = paste("EPW file header", surround(EPW_HEADER$holiday), "indicates no leap year.") - ) - } - # }}} + epw_data +} +# }}} - joined -} -# }}} -# find_epw_data_abnormal_line {{{ -find_epw_data_abnormal_line <- function (epw_data, offset = 0L, warning = FALSE, period_name = NULL, from = 0L) { - # data period name for reporting - nm <- if (is.null(period_name)) "." else paste0(" for data period ", period_name, ".") - - # here check all rows if there are any missing values or values out of range - # store the row number for further use during making NAs and fill NAs - epw_data[, { - ln <- .I + offset - # 8 core environment data - # EnergyPlus will stop reading weather data if any first row of these 8 - # variable out of range - core <- c( - "dry_bulb_temperature", - "dew_point_temperature", - "relative_humidity", - "atmospheric_pressure", - "wind_direction", "wind_speed", - "direct_normal_radiation", - "diffuse_horizontal_radiation" +# DATA +# get_epw_data {{{ +#' @importFrom checkmate assert_flag assert_scalar assert_count +get_epw_data <- function (epw_data, epw_header, matched, period = 1L, start_year = NULL, + align_wday = FALSE, tz = "UTC", update = FALSE) { + assert_count(period) + assert_count(start_year, null.ok = TRUE) + assert_flag(align_wday) + assert_scalar(tz) + assert_flag(update) + + # get data periods + dp <- parse_epw_header_period(epw_header, TRUE) + if (period > nrow(dp$period)) { + abort(paste0("Invalid data period index found. EPW contains only ", + nrow(dp$period), " data period(s) but ", surround(period), " is specified." + ), "epw_data_period_index" ) + } + interval <- dp$interval + p <- dp$period[period] - # just in case - assert(have_same_len(EPW_RANGE_EXIST, EPW_RANGE_VALID)) - - miss <- vector("list", length(EPW_RANGE_EXIST)) - range <- vector("list", length(EPW_RANGE_VALID)) - setattr(miss, "names", names(EPW_RANGE_EXIST)) - setattr(range, "names", names(EPW_RANGE_VALID)) - rpt_miss <- unlist(EPW_REPORT_MISSING, use.names = FALSE) - rpt_range <- unlist(EPW_REPORT_RANGE, use.names = FALSE) - - mes_miss <- NULL - mes_range <- NULL - mes_first <- NULL - - for (name in names(miss)) { - val <- if (inherits(get(name), "units")) units::drop_units(get(name)) else get(name) - m <- ln[!in_range(val, EPW_RANGE_EXIST[[name]])] - r <- setdiff(ln[!in_range(val, EPW_RANGE_VALID[[name]])], m) - if (name %in% rpt_miss && length(m)) { - mes_miss <- c(mes_miss, paste0(gsub("_", " ", name, fixed = TRUE), " is missing")) - } - if (name %in% rpt_range && length(r)) { - mes_r <- paste0(gsub("_", " ", name, fixed = TRUE), " should in range ", EPW_RANGE_VALID[[name]], ".") - if (name %in% core && any(r == from)) mes_first <- c(mes_first, mes_r) - mes_range <- c(mes_range, mes_r) - } - miss[[name]] <- m - range[[name]] <- r - } - - # check core weather data range on the row of first day, just as EnergyPlus does - if (!is.null(mes_first)) { - parse_issue("error_invalid_epw_data_first_day", "epw", - paste0("Out of range error found for initial row", nm), - data = add_epw_raw_string(.SD[1L]), num = length(mes_first), - post = paste0("At ", combine_date(year[1L], month[1L], day[1L], hour[1L]), ": ", mes_first) - ) - } + # leap year + leapyear <- parse_epw_header_holiday(epw_header, TRUE)$leapyear - if (warning && !is.null(mes_miss)) { - ln_miss <- unlist(miss[rpt_miss], use.names = FALSE) - offset - parse_issue("warning_epw_data_missing", "epw", - paste0("Missing data found", nm), - data = add_epw_raw_string(.SD[ln_miss]), - num = length(unlist(miss, use.names = FALSE)), - post = paste0("At ", combine_date(year[ln_miss], month[ln_miss], day[ln_miss], hour[ln_miss]), ": ", mes_miss), - stop = FALSE - ) - } + # get match info + m <- matched[period] - if (warning && !is.null(mes_range)) { - ln_range <- unlist(range[rpt_range], use.names = FALSE) - offset - parse_issue("warning_epw_data_out_of_range", "epw", - paste0("Out of range data found", nm), - data = add_epw_raw_string(.SD[ln_range]), - num = length(unlist(range, use.names = FALSE)), - post = paste0("Note that the out of range values in ", - collapse(EPW_REPORT_RANGE$do_nothing), " will not be ", - "changed by EnergyPlus and could affect your simulation.\n", - paste0("At ", combine_date(year[ln_range], month[ln_range], day[ln_range], hour[ln_range]), ": ", mes_range)), - stop = FALSE - ) - } + # get data + i <- seq(matched$row[period], length.out = matched$num[period]) + d <- epw_data[i] - list(list(miss, range)) - }]$V1 -} -# }}} -# find_epw_data_na_line {{{ -find_epw_data_na_line <- function (epw_data, offset = 0L, warning = FALSE, period_name = NULL) { - # data period name for reporting - nm <- if (is.null(period_name)) "." else paste0(" for data period ", period_name, ".") - - epw_data[, { - ln <- .I + offset - # 8 core environment data - # EnergyPlus will stop reading weather data if any first row of these 8 - # variable out of range - core <- c( - "dry_bulb_temperature", - "dew_point_temperature", - "relative_humidity", - "atmospheric_pressure", - "wind_direction", "wind_speed", - "direct_normal_radiation", - "diffuse_horizontal_radiation" - ) + can_update <- FALSE - na <- vector("list", length(EPW_RANGE_EXIST)) - setattr(na, "names", names(EPW_RANGE_EXIST)) - rpt_na <- unlist(EPW_REPORT_MISSING, use.names = FALSE) + # check if real year + realyear <- get_epwdate_type(p$start_day) == EPWDATE_TYPE$ymd - mes_na <- NULL + datetime <- d$datetime + year <- lubridate::year(datetime) + # use the year column + if (is.null(start_year)) { + if (realyear) { + mism <- NULL + if (wday(p$start_day, TRUE) != p$start_day_of_week) { + mism <- paste0(" Actual start day of week (", wday(p$start_day, TRUE), ") ", + "mismatches with the value specified in the header (", p$start_day_of_week, "). ", + "The later will be used." + ) + } - for (name in names(na)) { - l <- ln[is.na(get(name))] - if (name %in% rpt_na && length(l)) { - mes_na <- c(mes_na, paste0(gsub("_", " ", name, fixed = TRUE), - " contains NA(s) which will be treated as missing value(s).") + # issue a warning if trying to align day of week for a real year + if (align_wday) { + warn(paste0("Data period #", period, " ", surround(p$name), + " seems like a real-year data starting from ", + format(p$start_day), " to ", + format(p$end_day), ".", mism, + if (align_wday) " No day of week alignment is performed." + ), + "warning_rewrite_epw_acutal_year" ) } - na[[name]] <- l - } + # calculate new start year based on start day of week + } else if (align_wday) { + can_update <- TRUE - if (warning && !is.null(mes_na)) { - ln_na <- unlist(na[rpt_na], use.names = FALSE) - offset - parse_issue("warning_epw_data_na", "epw", - paste0("NA found in data", nm), - data = add_epw_raw_string(.SD[ln_na]), - num = length(unlist(na, use.names = FALSE)), - post = paste0("At ", combine_date(year[ln_na], month[ln_na], day[ln_na], hour[ln_na]), ": ", mes_na), - stop = FALSE - ) + # align start day of week + start_year <- find_nearst_wday_year(p$start_day, p$start_day_of_week, + lubridate::year(Sys.Date()), leapyear) + year <- get_epw_datetime_year(start_year, p$start_day, p$end_day, m$num, 60 / interval) + start_year <- year[1L] + lubridate::year(datetime) <- year } - list(list(na)) - }]$V1[[1L]] -} -# }}} - -# HEADER -# get_epw_data_period {{{ -get_epw_data_period <- function (epw_header, period = NULL) { - if (is.null(period)) return(NULL) - - n <- nrow(epw_header$period$period) - assert(are_count(period), is_unique(period)) - if (any(period > n)) abort_bad_epw_period(period[period > n], n) - as.integer(period) -} -# }}} -# set_epw_location {{{ -set_epw_location <- function (epw_header, input) { - res <- parse_epw_header_basic("location", input, - type = list( - chr = c("city", "state_province", "country", "data_source", "wmo_number"), - dbl = c("latitude", "longitude", "elevation", "time_zone") - ), - range = list( - latitude = ranger(-90, TRUE, 90, TRUE), - longitude = ranger(-180, TRUE, 180, TRUE), - time_zone = ranger(-12, TRUE, 12, TRUE), - elevation = ranger(-1000, TRUE, 9999.9, FALSE) - ), - coerce = FALSE, - raw = FALSE - ) - - for (name in names(res)) epw_header$location[[name]] <- res[[name]] - - epw_header -} -# }}} -# set_epw_design_condition {{{ -set_epw_design_condition <- function (epw_header, idfobj = FALSE) { - -} -# }}} -# set_epw_holiday {{{ -set_epw_holiday <- function (epw_header, leapyear, dst, holiday) { - if (!missing(leapyear)) { - assert(is_flag(leapyear)) - # note that parsed start and end day in data period can only be - # either md or ymd type - s <- epw_header$period$period$start_day - e <- epw_header$period$period$end_day - - # current is leap year but want to change to non-leap year - # for md type, it is ok to change only if that period does not cover - # Feb 29, e.g. [01/02, 02/28] - # for ymd type, if that period covers multiple years, e.g. - # [2007-01-01, 2009-01-01], there is a need to check 2008-02-28 - if (epw_header$holiday$leapyear & !leapyear) { - for (i in seq_along(s)) { - # in case ymd format that spans multiple years - feb29 <- lubridate::make_date(c(lubridate::year(s[i]) : lubridate::year(e[i])), 2, 29) - # for case [2007-01-01, 2009-01-01] - feb29 <- feb29[!is.na(feb29)] - - # if February exists in the data - if (any(s[i] <= feb29 & feb29 <= e[i])) { - abort("error_invalid_epw_header_leapyear", - paste0("Failed to change leap year indicator to ", leapyear, ", ", - "because data period ", - epw_header$period$period[i, paste0("#", index, " ", surround(name))], - " (", 60 / epw_header$period$interval, " mins interval) ", - " contains weather data of February 29th." - ) - ) - } - } + } else { + can_update <- TRUE - # current is non-leap year but want to change to leap year - # for md type, it is ok to change only if that period does not - # across Feb, e.g. [01/02, 02/28], [03/01, 12/31] - # for ymd type, it is always OK - } else if (!epw_header$holiday$leapyear & leapyear) { - is_md <- is_epwdate_type(s, "md") - if (any(is_md)) { - s_md <- s[is_md] - e_md <- e[is_md] - for (i in seq_along(s_md)) { - # in case ymd format that spans multiple years - feb28 <- lubridate::make_date(lubridate::year(s_md[i]), 2L, 28L) - - if (!all(e_md[i] <= feb28 | feb28 <= s_md[i])) { - abort("error_invalid_epw_header_leapyear", - paste0("Failed to change leap year indicator to ", leapyear, ", ", - "because data period ", - epw_header$period$period[is_md][i, paste0("#", index, " ", surround(name))], - " (", 60 / epw_header$period$interval, " mins interval) ", - " contains weather data that cross February." - ) - ) - } - } + if (leapyear != lubridate::leap_year(start_year)) { + # warning if leap year status mismatches + msg <- if (leapyear) { + "The original starting date falls in a leap year, however input 'start_year' is not a leap year." + } else { + "The original start year is not a leap year, however input 'start_year' is." } - + warn(paste0("Invalid 'start_year' found for Data period #", period, " ", surround(p$name), + " starting from ", format(p$start_day), " to ", format(p$end_day), ". ", + msg, " Invalid date time may occur." + ) + ) } - s <- reset_epwdate_year(s, leapyear) - e <- reset_epwdate_year(e, leapyear) - - epw_header$holiday$leapyear <- leapyear - epw_header$period$period[, `:=`(start_day = s, end_day = e)] - } - - if (!missing(dst)) { - assert(!is.list(dst)) - assert(has_len(dst, 2L)) - dst <- epw_date(dst) + # if real year and start_year argument is given, issue an warning + if (realyear) { + s <- as_date(p$start_day) + lubridate::year(s) <- start_year + s <- epw_date(s) - assert(are_epwdate(dst), prefix = "Daylight saving time") + warn(paste0("Data period #", period, " ", surround(p$name), + " seems like a real-year data starting from ", + format(p$start_day), " to ", + format(p$end_day), ". ", + "The starting date will be overwriten as ", + format(s), "." + ) + ) - # make it possible for directly giving Date-Time object - if (any(is_epwdate_type(dst, "ymd"))) { - is_ymd <- is_epwdate_type(dst, "ymd") - dst[is_ymd] <- ymd_to_md(dst[is_ymd]) + e <- as_date(p$end_day) + lubridate::year(e) <- lubridate::year(e) - (lubridate::year(as_date(p$start_day)) - start_year) + set(p, NULL, "start_day", s) + set(p, NULL, "end_day", e) } - epw_header$holiday$dst <- dst + year <- get_epw_datetime_year(start_year, p$start_day, p$end_day, m$num, 60 / interval) + lubridate::year(datetime) <- year } - if (!missing(holiday)) { - assert(is.list(holiday), has_len(holiday, 2L), has_name(holiday, c("name", "day")), - msg = paste("holiday should be a list or a data.frame containing", - "`name` and `day` element(column)." - ) - ) - holiday <- as.data.table(holiday) - set(holiday, NULL, "day", reset_epwdate_year(epw_date(holiday$day), epw_header$holiday$leapyear)) - assert(are_epwdate(holiday$day), prefix = "Holiday") - - epw_header$holiday$holiday <- holiday + if (tz != lubridate::tz(datetime[[1L]])) { + can_update <- TRUE + datetime <- lubridate::force_tz(datetime, tz) + start_year <- lubridate::year(datetime[[1L]]) } - epw_header -} -# }}} -# set_epw_period_basic {{{ -set_epw_period_basic <- function (epw_header, period, name, start_day_of_week) { - n <- nrow(epw_header$period$period) + # original data should not have any NA as this has been checked when + # parsing. NA will be introduced in cases when input year is a leap year: + # "2016-02-29" + lubridate::years(1) + if (can_update && any(j <- is.na(datetime))) { + j <- which(j) + invld <- if (length(j) > 10L) { + set(d[j[1:10]], NULL, "new_year", year[j[1:10]]) + } else { + set(d[j], NULL, "new_year", year[j]) + } - if (missing(period)) { - period <- seq_len(n) - } else { - period <- get_epw_data_period(epw_header, period) - } + mes <- invld[, paste0("Original: ", datetime, " --> New year: ", new_year)] - if (missing(name)) { - name <- NULL - } else { - assert(have_same_len(period, name)) - assert(!name %in% epw_header$period$period$name, - msg = "Input new name should not be the same as existing ones.", - err_type = "error_invalid_epw_data_period_name" + if (length(j) > 10L) mes <- c(mes, "...[truncated. First 10 are shown.]") + + abort(paste0("Invalid date introduced with input new start year (", start_year, ") and time zone (", tz, "):\n", + paste0(mes, collapse = "\n")), + "epw_data" ) - set(epw_header$period$period, period, "name", name) } - if (missing(start_day_of_week)) { - start_day_of_week <- NULL - } else { - assert(have_same_len(period, start_day_of_week)) - assert(is_wday(start_day_of_week)) - sdow <- get_epw_wday(start_day_of_week) - - # for real year, check if day of week matches - # have to get the line instead of subsetting - # see https://github.com/Rdatatable/data.table/issues/3388 - start_day <- epw_header$period$period[period][is_epwdate_type(start_day, "ymd"), start_day] - if (length(start_day)) { - real_wday <- wday(start_day) - if (any(real_wday != sdow)) { - idx <- real_wday != sdow - warn("warning_mismatch_epw_period_dayofweek", - paste0("Mismatched start day of week found. The actual day ", - "of week for start day (", start_day[idx], ") of ", - "data period #", period[idx], " is ", - wday(real_wday[idx], label = TRUE), - " but specified as ", - wday(sdow[idx], label = TRUE), - collapse = "\n" - ) - ) - } - } - - set(epw_header$period$period, period, "start_day_of_week", sdow) - } + set(d, NULL, "datetime", datetime) - epw_header -} -# }}} - -# DATA -# merge_list {{{ -merge_list <- function (x, y) { - assert(have_same_len(x, y)) - for (i in seq_along(y)) { - if (length(y[[i]])) { - if (length(x[[i]])) { - x[[i]] <- sort(unique(c(x[[i]], y[[i]]))) - } else { - x[[i]] <- y[[i]] - } - } - } - x -} -# }}} -# merge_data_period_abnormal_index {{{ -merge_data_period_abnormal_index <- function (epw_header, period = NULL, missing = TRUE, out_of_range = TRUE) { - if (is.null(period)) { - p <- epw_header$period$period - } else { - period <- get_epw_data_period(epw_header, period) - p <- epw_header$period$period[period] - } + if (update && can_update) set(d, NULL, "year", year(d$datetime)) - m <- NULL - r <- NULL - # get all out of range lines - if (missing) { - m <- Reduce(function (...) merge_list(...), p$missing) - } - if (out_of_range) { - r <- Reduce(function (...) merge_list(...), p$out_of_range) - } + # add line + set(d, NULL, "line", i + 8L) + setcolorder(d, "line") - list(missing = m, out_of_range = r) + d } # }}} # get_epw_data_abnormal {{{ -get_epw_data_abnormal <- function (epw_data, epw_header, period = 1L, cols = NULL, +#' @importFrom checkmate assert_count assert_flag +get_epw_data_abnormal <- function (epw_data, epw_header, matched, period = 1L, cols = NULL, keep_all = TRUE, type = c("both", "missing", "out_of_range")) { - assert(is_count(period)) - period <- get_epw_data_period(epw_header, period) - assert(is_flag(keep_all)) + assert_count(period) + assert_flag(keep_all) + assert_character(cols, null.ok = TRUE, any.missing = FALSE) type <- match.arg(type) - p <- epw_header$period$period[period] - if (type == "both") { - l <- merge_list(p$missing[[1L]], p$out_of_range[[1L]]) - } else { - l <- p[[type]][[1L]] - } + d <- get_epw_data(epw_data, epw_header, matched, period) + set(d, NULL, "line", seq(matched[period]$row + 8L, length.out = matched[period]$num)) - if (is.null(cols)) { - cols <- names(which(vlapply(l, function (x) length(x) > 0L))) - } else { - if (!has_name(p$missing[[1L]], cols)) { - abort("error_invaid_epw_data_column_name", - paste0("Invalid EPW data variable name found: ", collapse(cols[!cols %in% names(p[[type]][[1L]])])), - cols = cols - ) - } - l <- l[cols] - } + if (type == "both") type <- c("missing", "out_of_range") + + ln <- locate_epw_data_abnormal(d, cols, "missing" %chin% type, "out_of_range" %chin% type, merge = TRUE) + ln <- sort(unique(c(ln$missing, ln$out_of_range))) + + if (!length(ln)) verbose_info("No abnormal data found.") - l <- sort(unique(unlist(l, use.names = FALSE))) if (keep_all) { - d <- epw_data[l] + d <- d[J(ln), on = "line"] } else { - d <- epw_data[l, .SD, .SDcols = c("datetime", "year", "month", "day", "hour", "minute", cols)] + d <- d[J(ln), on = "line", .SD, .SDcols = c("line", "datetime", "year", "month", "day", "hour", "minute", cols)] } - if (!length(l)) verbose_info("No abnormal data found.") - - set(d, NULL, "line", l + 8L) - setcolorder(d, c("line", setdiff(names(d), "line"))) + setcolorder(d, "line") d } # }}} # get_epw_data_redundant {{{ -get_epw_data_redundant <- function (epw_data, epw_header) { - redundant <- get_epw_data_redundant_line(epw_data, epw_header, simplify = TRUE) - if (!length(redundant)) verbose_info("No redundant data found.") +get_epw_data_redundant <- function (epw_data, epw_header, matched, line = FALSE, revert = FALSE) { + add_rleid(epw_data) + rleid <- matched[, list(rleid = seq(row, length.out = num)), by = "index"]$rleid - d <- epw_data[redundant] - set(d, NULL, "line", redundant + 8L) - setcolorder(d, c("line", setdiff(names(d), "line"))) - d -} -# }}} -# get_epw_data_redundant_line {{{ -get_epw_data_redundant_line <- function (epw_data, epw_header, simplify = FALSE) { - p <- epw_header$period$period[order(from)] - res <- vector("list", nrow(p) + 1L) + line_redundant <- setdiff(epw_data$rleid, rleid) + if (!length(line_redundant)) verbose_info("No redundant data found.") - l <- epw_data[, .I] - n <- nrow(epw_data) - for (i in seq_len(nrow(p))) { - if (i == 1L) { - res[[i]] <- setdiff(l, seq(p$from[i], nrow(epw_data))) - } else if (i == nrow(p)) { - res[[i]] <- setdiff(seq(p$to[i - 1L] + 1L, p$to[i]), seq(p$from[i], p$to[i])) - res[[i + 1L]] <- setdiff(l, seq(1L, p$to[i])) - } else { - res[[i]] <- setdiff(seq(p$to[i - 1L] + 1L, p$to[i]), seq(p$from[i], p$to[i])) - } + if (revert) line_redundant <- setdiff(epw_data$rleid, line_redundant) + + if (line) { + set(epw_data, NULL, "rleid", NULL) + return(line_redudant) } - if (simplify) res <- unlist(res, use.names = FALSE) - res + d <- epw_data[line_redundant] + + # clean + set(epw_data, NULL, "rleid", NULL) + + set(d, NULL, "rleid", rleid + 8L) + setnames(d, "rleid", "line") + setcolorder(d, "line") + d[] } # }}} -# make_epw_data_na {{{ +# locate_epw_data_abnormal {{{ # Logic directly derived from WeatherManager.cc in EnergyPlus source code -make_epw_data_na <- function (epw_data, epw_header, period = NULL, - missing = FALSE, out_of_range = FALSE) { - mr <- merge_data_period_abnormal_index(epw_header, period, missing, out_of_range) +locate_epw_data_abnormal <- function (epw_data, field = NULL, missing = FALSE, out_of_range = FALSE, merge = FALSE) { + if (merge) { + line_miss <- integer() + line_range <- integer() + } else { + line_miss <- list() + line_range <- list() + } if (missing) { - epw_data <- make_epw_data_na_line(epw_data, mr$missing) + exist <- get_epw_data_range("exist", field = field) + line_miss <- check_epw_data_range(epw_data, exist, merge = merge) } if (out_of_range) { - epw_data <- make_epw_data_na_line(epw_data, mr$out_of_range) + valid <- get_epw_data_range("valid", field = field) + line_range <- check_epw_data_range(epw_data, valid, merge = merge) } - epw_data + + list(missing = line_miss, out_of_range = line_range) +} +# }}} +# match_epw_data_period {{{ +match_epw_data_period <- function (matched, period = NULL) { + if (is.null(period)) return(matched) + + assert_integerish(period, lower = 1L, any.missing = FALSE) + if (period > nrow(matched)) { + abort(paste0("Invalid data period index found. EPW contains only ", + nrow(matched), " data period(s) but ", surround(period), " is specified." + ), "epw_data_period_index" + ) + } + matched[period] } # }}} -# make_epw_data_na_line {{{ -make_epw_data_na_line <- function (epw_data, line_list) { - for (name in names(line_list)) { - if (length(line_list[[name]])) set(epw_data, line_list[[name]], name, NA) +# make_epw_data_na {{{ +# Logic directly derived from WeatherManager.cc in EnergyPlus source code +make_epw_data_na <- function (epw_data, epw_header, matched, period = NULL, + field = NULL, missing = FALSE, out_of_range = FALSE) { + if (!missing && !out_of_range) return(epw_data) + + matched <- match_epw_data_period(matched, period) + rleid <- matched[, list(rleid = seq(row, length.out = num)), by = "index"]$rleid + d <- epw_data[rleid] + + line <- locate_epw_data_abnormal(d, field, missing, out_of_range, merge = FALSE) + cols <- if (missing) names(line$missing) else names(line$out_of_range) + + for (name in cols) { + i <- c(line$missing[[name]], line$out_of_range[[name]]) + if (length(i)) set(epw_data, rleid[i], name, NA) } + epw_data } # }}} # fill_epw_data_abnormal {{{ -fill_epw_data_abnormal <- function (epw_data, epw_header, period = NULL, - missing = TRUE, out_of_range = TRUE, special = FALSE, - miss_na = FALSE, range_na = FALSE) { +fill_epw_data_abnormal <- function (epw_data, epw_header, matched, period = NULL, + field = NULL, missing = TRUE, out_of_range = TRUE, + special = FALSE, miss_na = FALSE, range_na = FALSE) { if (!missing && !out_of_range) return(epw_data) + # get data + matched <- match_epw_data_period(matched, period) + rleid <- matched[, list(rleid = seq(row, length.out = num)), by = "index"]$rleid + d <- epw_data[rleid] + + # get missing code + code <- get_epw_data_missing_code() + + # get all abnormal row indices + ln <- locate_epw_data_abnormal(d, field, missing, out_of_range, merge = FALSE) + + if (!special) { + for (name in names(code)) { + i <- c(ln$missing[[name]], ln$out_of_range[[name]]) + if (length(i)) set(epw_data, rleid[i], name, code[[name]]) + } + + return(epw_data) + } + + # get initial value for first missing value + init <- get_epw_data_init_value() + # get atmospheric pressure at current elevation - EPW_INIT_MISSING$atmospheric_pressure <- std_atm_press(epw_header$location$elevation) - - # get all abnormal row indices in specific periods - mr <- merge_data_period_abnormal_index(epw_header, period, missing = TRUE, out_of_range = TRUE) - m <- mr$missing - r <- mr$out_of_range + elev <- parse_epw_header_location(epw_header, EPW_CLASS$location)$elevation + if (is.na(elev)) { + valid <- validate_epw_header_basic(epw_header, EPW_CLASS$location, field = "Elevation") + assert_valid(valid, epw = TRUE) + } + atpres <- std_atm_press(epw_header$location$elevation) + m <- ln$missing + r <- ln$out_of_range # just in case - assert(have_same_len(m, r)) + if (missing & out_of_range) assert_same_len(m, r) - # add previous valid line {{{ - if (special) { + # add previous valid line index {{{ + if (missing) { for (nm in EPW_REPORT_MISSING$use_previous) { if (length(m[[nm]])) { if (length(r[[nm]])) { - comb <- sort(c(m[[nm]], r[[nm]])) - bound <- c(0L, diff(x)) != 1L - pre <- rep(comb[bound] - 1L, times = diff(c(bound, length(comb) + 1L))) - m[[nm]] <- sort(unique(c(m[[nm]], pre[m[[nm]] == comb]))) + comb <- sort(unique(c(m[[nm]], r[[nm]]))) } else { - m[[nm]] <- sort(c(m[[nm]], m[[nm]][c(0, diff(m[[nm]])) != 1L] - 1L)) + comb <- m[[nm]] } + bound <- c(0L, diff(comb)) != 1L + m[[nm]] <- sort(unique(c(m[[nm]], comb[bound] - 1L))) } } + } + + if (out_of_range) { for (nm in EPW_REPORT_RANGE$use_previous) { if (length(r[[nm]])) { if (length(m[[nm]])) { - comb <- sort(c(m[[nm]], r[[nm]])) - bound <- c(0L, diff(x)) != 1L - pre <- rep(comb[bound] - 1L, times = diff(c(bound, length(comb) + 1L))) - r[[nm]] <- sort(unique(c(r[[nm]], pre[r[[nm]] == comb]))) + comb <- sort(unique(c(m[[nm]], r[[nm]]))) } else { - r[[nm]] <- sort(c(r[[nm]], r[[nm]][c(0, diff(r[[nm]])) != 1L] - 1L)) + comb <- r[[nm]] } + bound <- c(0L, diff(comb)) != 1L + r[[nm]] <- sort(unique(c(r[[nm]], comb[bound] - 1L))) } } } # }}} if (missing) { - fill_epw_data_abnormal_line(epw_data, m, miss_na, special, "missing") + action <- get_epw_data_fill_action("missing") + fill_epw_data_abnormal_special(d, m, action, init, code, miss_na) } - if (out_of_range) { - fill_epw_data_abnormal_line(epw_data, r, range_na, special, "out_of_range") + action <- get_epw_data_fill_action("out_of_range") + fill_epw_data_abnormal_special(d, m, action, init, code, range_na) } + set(epw_data, rleid, names(d), d) epw_data } # }}} -# fill_epw_data_abnormal_line {{{ -fill_epw_data_abnormal_line <- function (epw_data, line_list, na_made, special = FALSE, type = c("missing", "out_of_range")) { - const <- switch(type, - missing = EPW_REPORT_MISSING, - out_of_range = EPW_REPORT_RANGE, - stop("Invalid abnormal type, should be either `missing` or `out_of_range`.") - ) +# fill_epw_data_abnormal_special {{{ +fill_epw_data_abnormal_special <- function (epw_data, loc, action, init_value, code, na_made = FALSE) { + # for each variable + for (name in names(loc)) { + if (!length(loc[[name]])) next - # no special - if (!special) { - for (name in names(line_list)) { - if (length(line_list[[name]])) set(epw_data, line_list[[name]], name, EPW_MISSING_CODE[[name]]) - } - } else { - # for each variable - for (name in names(line_list)) { - - # if there are missing values - if (length(line_list[[name]])) { - - # keep that column as it is if requested - if (name %chin% const$do_nothing) { - # - - # set to 0 if applicable - } else if (name %chin% const$use_zero) { - set(epw_data, line_list[[name]], name, 0) - - # set to previous value if applicable - } else if (name %chin% const$use_previous) { - l <- line_list[[name]] - - # if there is no previous valid line, set the first - # missing value to initial missing value - if (l[1L] == 0L) { - set(epw_data, l[2L], name, EPW_INIT_MISSING[[name]]) - l <- l[-1L] - } - - # already change missing to NAs - if (na_made) { - epw_data[l, - c(name) := get(name)[1L], - by = list(cumsum(!is.na(get(name)))) - ] - # still is presented as missing code - } else { - epw_data[l, - c(name) := get(name)[1L], - by = list(cumsum(get(name) != EPW_MISSING_CODE[[name]])) - ] - } - - # for others set to missing code - } else { - set(epw_data, line_list[[name]], name, EPW_MISSING_CODE[[name]]) - } + # keep that column as it is if requested + if (name %chin% action$do_nothing) { + # + + # set to 0 if applicable + } else if (name %chin% action$use_zero) { + set(epw_data, loc[[name]], name, 0) + + # set to previous value if applicable + } else if (name %chin% action$use_previous) { + l <- loc[[name]] + + # if there is no previous valid line, set the first + # missing value to initial missing value + if (l[1L] == 0L) { + set(epw_data, l[2L], name, init_value[[name]]) + l <- l[-1L] } + + # already change missing to NAs + if (na_made) { + setnafill(epw_data, "locf", cols = name) + + # still is presented as missing code + } else { + epw_data[l, c(name) := get(name)[1L], by = list(cumsum(get(name) != code[[name]]))] + } + + # for others set to missing code + } else { + set(epw_data, loc[[name]], name, code[[name]]) } } + epw_data } # }}} # add_epw_data_unit {{{ add_epw_data_unit <- function (epw_data) { - for (nm in names(EPW_UNIT)) { - set(epw_data, NULL, nm, units::set_units(epw_data[[nm]], EPW_UNIT[[nm]], mode = "standard")) + unit <- get_epw_data_unit() + + # change to standard SI units + u <- FIELD_UNIT_TABLE[J(unlist(unit)), on = "si_name", mult = "first"][ + !is.na(si_standard_name), si_name := si_standard_name]$si_name + unit <- setattr(as.list(u), "names", names(unit)) + + for (nm in names(unit)) { + set(epw_data, NULL, nm, units::set_units(epw_data[[nm]], unit[[nm]], mode = "standard")) } epw_data } # }}} # drop_epw_data_unit {{{ drop_epw_data_unit <- function (epw_data) { - for (nm in names(EPW_UNIT)) { + unit <- get_epw_data_unit() + for (nm in names(unit)) { if (inherits(epw_data[[nm]], "units")) { set(epw_data, NULL, nm, units::drop_units(epw_data[[nm]])) } @@ -2553,295 +1958,182 @@ drop_epw_data_unit <- function (epw_data) { } # }}} # purge_epw_data_redundant {{{ -purge_epw_data_redundant <- function (epw_data, epw_header) { - redundant <- get_epw_data_redundant_line(epw_data, epw_header) - l <- unlist(redundant, use.names = FALSE) - if (!length(l)) { +purge_epw_data_redundant <- function (epw_data, epw_header, matched) { + add_rleid(epw_data) + ln <- matched[, list(rleid = seq(row, length.out = num)), by = "index"] + + line_redundant <- setdiff(epw_data$rleid, ln$rleid) + if (!length(line_redundant)) { verbose_info("No redundant data found. Nothing to purge.") - return(list(header = epw_header, data = epw_data)) + + # clean + set(epw_data, NULL, "rleid", NULL) + + return(list(data = epw_data, matched = matched)) } - if (eplusr_option("verbose_info")) { - if (length(l) >= 10L) { - msg <- paste0(paste0("#", l[1L:10L], collapse = ", "), " and etc.") + if (in_verbose()) { + if (length(line_redundant) >= 10L) { + msg <- paste0(paste0("#", line_redundant[1L:10L], collapse = ", "), " and etc.") } else { - msg <- paste0("#", l) + msg <- paste0("#", line_redundant) } verbose_info("Deleting lines ", msg, " that are not used in any data period.") } - len <- vapply(redundant[-length(redundant)], length, integer(1L)) + data <- epw_data[ln, on = "rleid", nomatch = NULL] + data[, row := .I] + matched <- data[, list(row = row[[1L]], num = .N), by = "index"] - # no need to update - if (all(len == 0L)) return(list(header = epw_header, data = epw_data[-l])) - - p <- epw_header$period$period[order(from)] - - # update period data - for (i in seq_along(len)) { - offset <- len[[i]] - if (!length(offset)) next - p[i, `:=`( - from = from - offset, to = to - offset, - missing = list(list(lapply(missing[[1L]], "-", offset))), - out_of_range = list(list(lapply(out_of_range[[1L]], "-", offset))) - )] - } + # clean + set(epw_data, NULL, "rleid", NULL) + set(data, NULL, c("index", "row", "rleid"), NULL) - epw_header$period$period <- setorderv(p, "index") - list(header = epw_header, data = epw_data[-l]) + list(data = data, matched = matched) } # }}} -# get_epw_data {{{ -get_epw_data <- function (epw_data, epw_header, period = 1L, start_year = NULL, - align_wday = FALSE, tz = "UTC", update = FALSE) { - assert(is_flag(update)) - assert(is_scalar(tz)) - if (!is.null(start_year)) assert(is_count(start_year)) - assert(is_count(period)) - - period <- get_epw_data_period(epw_header, period) - p <- epw_header$period$period[period] - - # get data - d <- epw_data[p$from:p$to] - - can_update <- FALSE - - # use the year column - if (is.null(start_year)) { - if (!align_wday) { - set(d, NULL, "datetime", {year(d$datetime) <- d$year; d$datetime}) - } else { - can_update <- TRUE - - # align start day of week - start_year <- find_nearst_wday_year(d$datetime[[1L]], p$start_day_of_week, - lubridate::year(Sys.Date()), epw_header$holiday$leapyear - ) - set(d, NULL, "datetime", {year(d$datetime) <- start_year; d$datetime}) - - # get the start of next year - nextyear <- d[month == 12L & day == 31L & hour == 24L & minute == 0L, which = TRUE] - - # add one year - if (length(nextyear)) { - for (i in seq_along(nextyear)) { - if (is.na(nextyear[i+1])) { - s <- nextyear[i]:nrow(d) - } else { - s <- nextyear[i]:nextyear[i+1] - } - set(d, s, "datetime", {year(d$datetime[s]) <- start_year + i; d$datetime[s]}) - } - } - } - } else { - can_update <- TRUE - - # if real year and year argument is given, issue an warning - if (is_epwdate_type(p$start_day, "ymd")) { - s <- as_date(p$start_day) - lubridate::year(s) <- start_year - warn("warning_rewrite_epw_acutal_year", - paste0("Data period #", period, " ", surround(p$name), - " seems like a real-year data starting from ", - format(as_date(p$start_day)), " to ", - format(as_date(p$end_day)), ". ", - "The starting date will be overwriten as ", - format(s), "." - ) - ) - } - - set(d, NULL, "datetime1", d$datetime) - set(d, NULL, "datetime1", {year(d$datetime1) <- start_year;d$datetime1}) - - # get the start of next year - nextyear <- d[month == 12L & day == 31L & hour == 24L & minute == 0L, which = TRUE] - - # add one year - if (length(nextyear)) { - for (i in seq_along(nextyear)) { - if (is.na(nextyear[i+1])) { - s <- nextyear[[i]]:nrow(d) - } else { - s <- nextyear[[i]]:nextyear[[i+1]] - } - set(d, s, "datetime", {year(d$datetime1[s]) <- start_year + i; d$datetime1[s]}) - } - } - - # original data should not have any NA as this has been checked when - # parsing. NA will be introduced in cases when input year is a leap year: - # "2016-02-29" + lubridate::years(1) - if (any(is.na(d$datetime1))) { - invld <- d[is.na(datetime1)] - mes <- invld[, paste0("Original: ", datetime, " --> New year: ", - lubridate::year(datetime) + dis - )] - abort("error_invalid_epw_date_introduced", - paste0("Invalid date introduced with input start year:\n", - paste0(mes, collapse = "\n") - ) - ) - } - - set(d, NULL, "datetime", NULL) - setnames(d, "datetime1", "datetime") - setcolorder(d, c("datetime", setdiff(names(d), "datetime"))) - } - - if (tz != lubridate::tz(d$datetime[1L])) { - can_update <- TRUE - set(d, NULL, "datetime1", lubridate::force_tz(d$datetime, tz)) - - if (any(is.na(d$datetime1))) { - invld <- d[is.na(datetime1)] - mes <- invld[, paste0("Original: ", datetime, " --> New time zone: ", tz)] - abort("error_invalid_epw_date_introduced", - paste0("Invalid date introduced with input time zone:\n", - paste0(mes, collapse = "\n") - ) - ) - } - - set(d, NULL, "datetime", NULL) - setnames(d, "datetime1", "datetime") - setcolorder(d, c("datetime", setdiff(names(d), "datetime"))) - } - - if (update && can_update) set(d, NULL, "year", year(d$datetime)) - - d +# add_epw_data {{{ +#' @importFrom checkmate assert_data_frame assert_names assert_flag +add_epw_data <- function (epw_data, epw_header, matched, data, realyear = FALSE, + name = NULL, start_day_of_week = NULL, after = 0L, + warning = TRUE) { + merge_epw_new_data(epw_data, epw_header, matched, data, after, + reset = FALSE, realyear = realyear, name = name, + start_day_of_week = start_day_of_week, warning = warning + ) +} +# }}} +# set_epw_data {{{ +#' @importFrom checkmate assert_data_frame assert_names assert_flag +#' @importFrom checkmate assert_string assert_count +set_epw_data <- function (epw_data, epw_header, matched, data, realyear = FALSE, + name = NULL, start_day_of_week = NULL, period = 1L, + warning = TRUE) { + merge_epw_new_data(epw_data, epw_header, matched, data, period, + reset = TRUE, realyear = realyear, name = name, + start_day_of_week = start_day_of_week, warning = warning + ) } # }}} # del_epw_data {{{ -del_epw_data <- function (epw_data, epw_header, period) { - assert(is_count(period)) - period <- get_epw_data_period(epw_header, period) +#' @importFrom checkmate assert_count +del_epw_data <- function (epw_data, epw_header, matched, period) { + assert_count(period, positive = TRUE) + dp <- parse_epw_header_period(epw_header) + m <- match_epw_data_period(matched, period) # check if this is the only data period. # If so, stop. Since it makes no sense to create an EPW without any data # in it. - if (nrow(epw_header$period$period) == 1L) { - abort("error_epw_delete_only_period", - paste0("The EPW file contains only one data period named ", - surround(epw_header$period$period$name), ". It cannot be deleted ", - "since each EPW file should contain at least one data period." - ) - ) + if (nrow(matched) == 1L) { + abort(paste0("The EPW file contains only one data period named ", + surround(dp$period$name[period]), ". It cannot be deleted ", + "since each EPW file should contain at least one data period." + )) } - current <- epw_header$period$period[period] - other <- epw_header$period$period[-period] + val <- get_idf_table(get_epw_idd_env(), epw_header, EPW_CLASS$period) + prev <- (period - 1L) * 4L + 2L + val[J(1L), on = "index", value := as.character(nrow(matched) - 1L)] + val[index > prev, value := c(value[-(1:4)], rep(NA_character_, 4L))] - epw_data <- epw_data[-seq(current$from, current$to)] - epw_header$period$period <- other[, index := .I] + lst <- expand_idf_dots_literal(get_epw_idd_env(), epw_header, val, .default = FALSE) + epw_header <- set_idf_object(get_epw_idd_env(), epw_header, lst$object, lst$value, level = "final") - verbose_info("Data period #", current$index, " ", surround(current$name), - " has been successfully deleted from the EPW file." - ) + epw_data <- epw_data[-seq(m$row, length.out = m$num)] + matched <- matched[-period][, index := .I] - list(header = epw_header, data = epw_data) + verbose_info("Data period #", period, " ", surround(dp$period$name[period]), + " has been successfully deleted from the EPW file.") + + list(data = data, header = epw_header, matched = matched, period = m$index) } # }}} -# add_epw_data {{{ -add_epw_data <- function (epw_data, epw_header, data, realyear = FALSE, - name = NULL, start_day_of_week = NULL, after = 0L, - warning = TRUE) { - assert(is.data.frame(data)) - assert(has_name(data, setdiff(names(epw_data), c("year", "month", "day", "hour", "minute")))) - assert(is_flag(realyear)) - if (!is.null(start_day_of_week)) assert(is_wday(start_day_of_week)) - if (!is.null(name)) assert(is_string(name)) - - after <- as.integer(after) - assert(is_count(after, zero = TRUE)) - - # get data period - n <- nrow(epw_header$period$period) - # use nearest as template - if (after > n) after <- n - target_period <- if (after == 0L) 1L else after - other_periods <- seq_len(n) - - # get new name - if (is.null(name)) { - all_nm <- epw_header$period$period$name - num <- stri_match_first_regex(all_nm, "^data(\\d{0,})$", case_insensitive = TRUE)[, 2L] - num <- num[!is.na(num)] - if (!length(num)) { - name <- "Data" +# merge_epw_new_data {{{ +#' @importFrom checkmate assert_posixct +merge_epw_new_data <- function (epw_data, epw_header, matched, data, target_period, + reset = FALSE, realyear = FALSE, name = NULL, + start_day_of_week = NULL, warning = TRUE) { + # drop units + epw_data <- drop_epw_data_unit(epw_data) + + assert_data_frame(data) + assert_names(names(data), must.include = setdiff(names(epw_data), c("year", "month", "day", "hour", "minute"))) + assert_flag(reset) + assert_flag(realyear) + assert_flag(warning) + + # copy the original header in case error occurs + header <- list() + header$object <- copy(epw_header$object) + header$value <- copy(epw_header$value) + header$reference <- copy(epw_header$reference) + + holiday <- parse_epw_header_holiday(header) + period <- parse_epw_header_period(header) + + # get current data period and other periods {{{ + if (reset) { + p <- match_epw_data_period(period$period, target_period) + p_other <- period$period[-target_period] + } else { + target_period <- assert_count(target_period, coerce = TRUE) + n <- nrow(period$period) + + if (target_period > n) { + target_period <- n + 1L + p <- period$period[n][, index := index + 1L] + p_other <- period$period + } else if (target_period == 0L) { + target_period <- 1L + p <- period$period[1L] + p_other <- period$period[, index := index + 1L] } else { - num[stri_isempty(num)] <- "0" - name <- paste0("Data", max(as.integer(num)) + 1L) + p <- period$period[target_period][, index := index + 1L] + p_other <- period$period[index > target_period, index := index + 1L] } } + # }}} - lst <- check_epw_new_data(epw_data, epw_header, data, target_period, other_periods, - FALSE, realyear, name, start_day_of_week, warning - ) - - nm <- name - # update period index - if (after == 0L) { - lst$header$period$period[, index := index + 1L] - lst$header$period$period[name == nm, index := 1L] + # get new name {{{ + if (is.null(name)) { + if (reset) { + name <- p$name + } else { + all_nm <- period$period$name + num <- stri_match_first_regex(all_nm, "^data(\\d{0,})$", case_insensitive = TRUE)[, 2L] + num <- num[!is.na(num)] + if (!length(num)) { + name <- "Data" + } else { + num[stri_isempty(num)] <- "0" + name <- paste0("Data", max(as.integer(num)) + 1L) + } + } + # make sure input new name is not the same as others } else { - lst$header$period$period[index > target_period, index := index + 1L] - lst$header$period$period[name == nm, index := after + 1L] + if (stri_trans_tolower(name) %in% stri_trans_tolower(p_other$name)) { + abort(paste0("Input data period name cannot be the same as existing ones, i.e. ", + collapse(p_other$name) + )) + } + set(p, NULL, "name", name) } - setorderv(lst$header$period$period, "index") - - lst -} -# }}} -# set_epw_data {{{ -set_epw_data <- function (epw_data, epw_header, data, realyear = FALSE, - name = NULL, start_day_of_week = NULL, period = 1L, - warning = TRUE) { - assert(is.data.frame(data)) - assert(has_name(data, setdiff(names(epw_data), c("year", "month", "day", "hour", "minute")))) - assert(is_flag(realyear)) - if (!is.null(start_day_of_week)) assert(is_wday(start_day_of_week)) - if (!is.null(name)) assert(is_string(name)) - assert(is_count(period)) - - # get data period - target_period <- get_epw_data_period(epw_header, period) - other_periods <- epw_header$period$period[-period, index] - reset <- if (length(other_periods)) FALSE else TRUE - - check_epw_new_data(epw_data, epw_header, data, target_period, other_periods, - reset, realyear, name, start_day_of_week, warning - ) -} -# }}} -# check_epw_new_data {{{ -check_epw_new_data <- function (epw_data, epw_header, data, target_period, other_periods, - reset = FALSE, realyear = FALSE, name = NULL, - start_day_of_week = NULL, warning = TRUE) { - # get current data period and other periods - p <- epw_header$period$period[target_period] - p_other <- epw_header$period$period[other_periods] + # }}} # coerce input data into a data.table data <- as.data.table(data) - # add line indicator - set(data, NULL, "line", seq_len(nrow(data))) - # check datetime column type first, then others - assert(inherits(data$datetime, "POSIXct"), - msg = paste0("Column `datetime` of input data should be `POSIXct` class, not ", - surround(class(data$datetime)[[1L]]), " class." - ) - ) + assert_posixct(data$datetime, any.missing = FALSE) # change time zone of input datetime to "UTC" set(data, NULL, "datetime", force_tz(data$datetime, "UTC")) + # check other column types + type <- get_epw_data_type(setdiff(names(epw_data), c("datetime", "year", "month", "day", "hour", "minute"))) + data <- check_epw_data_type(data, unlist(type)) + # get start and end day # assume that datetime is sorted start <- data$datetime[1L] @@ -2850,43 +2142,49 @@ check_epw_new_data <- function (epw_data, epw_header, data, target_period, other # get time step and interval using first two rows {{{ step <- difftime(data$datetime[2L], start, units = "mins") if (60L %% as.numeric(step) != 0L){ - abort("error_invalid_epw_data_interval", - paste0( - "Invalid number of records per hour in input data. The difference ", - "between second and first datetime is ", format(step), ", leading to ", - "non-integral number of records per hour." - ) - ) + abort(paste0("Invalid number of records per hour in input data. The difference ", + "between second and first datetime is ", format(step), ", leading to ", + "non-integral number of records per hour." + )) } step <- as.numeric(step) if (reset) { interval <- as.integer(60L / step) } else { - interval <- epw_header$period$interval + interval <- period$interval if (interval != 60 / step) { - abort("error_conflict_epw_data_interval", - paste0( - "Invalid number of records per hour in input data. Value ", - "calculated between second and first datetime is ", - as.integer(60/step), " which is different from value ", - interval, " in the EPW file." - ) - ) + abort(paste0("Invalid number of records per hour in input data. Value ", + "calculated between second and first datetime is ", + as.integer(60/step), " which is different from value ", + interval, " in the EPW file." + )) } } # }}} + # check if the datetime is valid + expect_start <- make_datetime( + lubridate::year(start), lubridate::month(start), lubridate::mday(start), + # hour # minute + 0L, step + ) + if (start != expect_start) { + abort(paste0("Invalid starting date time found in input data. ", + "Expecting ", surround(expect_start), " but ", surround(start), " was found." + )) + } + # after cal interval, change to md format if not real year if (!realyear) { - start <- ymd_to_md(start) - end <- ymd_to_md(end) + start <- ymd_to_md(epw_date(start)) + end <- ymd_to_md(epw_date(end)) } # set start and and day set(p, NULL, c("start_day", "end_day"), list(epw_date(start), epw_date(end))) # get leap year {{{ if (!reset) { - leapyear <- epw_header$holiday$leapyear + leapyear <- holiday$leapyear # reset } else { if (realyear) { @@ -2903,165 +2201,113 @@ check_epw_new_data <- function (epw_data, epw_header, data, target_period, other } } # reset leap year indicator - epw_header$holiday$leapyear <- leapyear - } - # }}} - - # make sure input new name is not the same as others {{{ - if (!is.null(name)) { - if (!reset && stri_trans_tolower(name) %in% stri_trans_tolower(p_other$name)) { - abort("error_invalid_epw_data_period_name", - paste0("Input data period name cannot be the same as existing ones ", - "i.e. ", collapse(p_other$name) - ) - ) - } - set(p, NULL, "name", name) + id <- get_idf_value(get_epw_idd_env(), header, EPW_CLASS$holiday, field = 1L)$value_id + header$value[J(id), on = "value_id", value_chr := ifelse(leapyear, "Yes", "No")] } # }}} # if AMY data given, use the day of week of the first day if not explicitly specified {{{ if (is.null(start_day_of_week)) { if (realyear) { - set(p, NULL, "start_day_of_week", wday(start)) + start_day_of_week <- as.character(wday(start, TRUE)) } else { - set(p, NULL, "start_day_of_week", 7L) + start_day_of_week <- "Sunday" } } else { - set(p, NULL, "start_day_of_week", get_epw_wday(start_day_of_week)) + start_day_of_week <- get_epw_wday(start_day_of_week, TRUE) } # }}} - # match datetime - data <- match_epw_data_datetime(data, target_period, p$name, start, end, interval, - leapyear, realyear, check_minute = realyear + # update period data for futher checking {{{ + lst <- list() + lst[sprintf("Data Period %i Name/Description", p$index)] <- name + lst[sprintf("Data Period %i Start Day of Week", p$index)] <- start_day_of_week + lst[sprintf("Data Period %i Start Day", p$index)] <- format(epw_date(start)) + lst[sprintf("Data Period %i End Day", p$index)] <- format(epw_date(end)) + lst["Number of Records per Hour"] <- interval + + # shift other values + if (!reset) { + lst["Number of Data Periods"] <- n + 1L + lst[sprintf("Data Period %i Name/Description", p_other$index)] <- p_other$name + lst[sprintf("Data Period %i Start Day of Week", p_other$index)] <- p_other$start_day_of_week + lst[sprintf("Data Period %i Start Day", p_other$index)] <- format(p_other$start_day) + lst[sprintf("Data Period %i End Day", p_other$index)] <- format(p_other$end_day) + } + lst <- expand_idf_dots_value(get_epw_idd_env(), header, + ..(EPW_CLASS$period) := lst, .default = FALSE, .type = "object" ) + header <- set_idf_object(get_epw_idd_env(), header, lst$object, lst$value, empty = TRUE, level = "final") + parse_epw_header_period(header) + # }}} - # update datetime components - set(data, NULL, c("month", "day", "hour", "minute"), - create_epw_datetime_components(start, end, interval, leapyear = leapyear)[, -"year"] + # match datetime {{{ + # construct hour values + hour <- as.integer(lubridate::hour(data$datetime)) + hour[hour == 0L] <- 24L + set(data, NULL, c("year", "month", "day", "hour", "minute"), + list( + year = lubridate::year(data$datetime), + month = lubridate::month(data$datetime), + day = lubridate::mday(data$datetime), + hour = hour, minute = if (interval == 1L) 0L else step + ) ) - # make sure there is no overlapping with other periods {{{ - if (!reset) { - for (i in seq_len(nrow(p_other))) { - if (realyear) { - overlapped <- any(data$datetime %in% epw_data[p_other$from[i]:p_other$to[i], datetime]) - } else { - overlapped <- nrow(data[epw_data[p_other$from[i]:p_other$to[i]], on = c("month", "day"), mult = "first"]) - } - if (overlapped) { - abort("error_epw_data_overlap", - paste0("Failed to set target data period because date time in ", - "input data has overlapped with data period ", - p_other[i, paste0("#", index, " ", surround(name), - " [", start_day, ", ", end_day, "]" - )], "." - ) - ) - } - } - } - # }}} + m <- match_epw_data(data, header, target_period) - # check other column types {{{ - check_type <- function (type) { - fun <- switch(type, integer = is.integer, double = is.double, character = is.character) - chk <- data[, vapply(.SD, fun, logical(1L)), .SDcols = names(which(unlist(EPW_TYPE) == type))] - if (any(!chk)) { - err_type <- data[, vapply(.SD, typeof, character(1L)), .SDcols = names(which(!chk))] - abort(paste0("error_invalid_epw_data_", type, "_type"), - paste0("Invalid column data type found in input data:\n", - paste0(" #", rpad(seq_len(sum(!chk))), ": ", - "Column ", surround(names(which(!chk))), " should be ", - surround(type), " class, not ", surround(err_type), ".", - collapse = "\n" - ) - ) - ) - } - } - check_type("integer") - check_type("double") - check_type("character") + # update datetime components + set(data, NULL, c("year", "month", "day", "hour", "minute"), + create_epw_datetime_components(start, end, interval, leapyear = leapyear) + ) # }}} # set column order setcolorder(data, names(epw_data)) - # find lines contains NA with missing code - na <- find_epw_data_na_line(data, warning = warning, - period_name = paste0("#", p$index, " ", surround(p$name), - " (", 60/interval, " mins interval)" - ) - ) - data <- fill_epw_data_abnormal_line(data, na, FALSE, FALSE, "missing") - - abnormal <- find_epw_data_abnormal_line(data, warning = warning, - period_name = paste0("#", p$index, " ", surround(p$name), - " (", 60/interval, " mins interval)" - ) - ) + # update table {{{ + # drop units + data <- drop_epw_data_unit(data) - # update interval if necessary - epw_header$period$interval <- interval - # reset if (reset) { - previous <- after <- epw_data[0L] - - # set range - set(p, NULL, c("from", "to"), list(1L, nrow(data))) - set(p, NULL, "missing", list(abnormal[1L])) - set(p, NULL, "out_of_range", list(abnormal[2L])) - - # after update all data, reset period - epw_header$period$period <- p + m_prev <- matched[index == target_period] + data <- rbindlist(list( + # before the first line of previous data to reset + if (m_prev$row == 1L) data.table() else epw_data[1:(m_prev$row - 1L)], + data, + # after the last line of previous data to reset + if (nrow(epw_data) == (m_prev$row + m_prev$num - 1L)) data.table() else epw_data[(m_prev$row + m_prev$num):.N] + )) + + matched <- copy(matched)[J(p$index), on = "index", `:=`(row = m$row, num = m$num)] } else { - p_previous <- p_other[to < p$from] - p_after <- p_other[from > p$to] - p_other <- p_other[!index %in% c(p_previous$index, p_after$index)] - - if (!nrow(p_previous)) { - previous <- epw_data[0L] - } else { - previous <- epw_data[1L:max(p$from - 1L)] - } - - if (!nrow(p_after)) { - after <- epw_data[0L] + # after 0L + if (target_period == 1L) { + data <- rbindlist(list(data, epw_data)) + matched <- rbindlist(list(m, copy(matched)[, `:=`(index = index + 1L, row = row + m$num)])) + # after n + } else if (target_period == (n + 1L)) { + data <- rbindlist(list(epw_data, data)) + matched <- rbindlist(list(matched, m[, `:=`(index = target_period, row = matched[.N, row + num])])) } else { - after <- epw_data[max(p$to + 1L):nrow(epw_data)] - } - - # offset for later period - offset <- (p$to - p$from + 1L) - nrow(data) - - # have to offset all abnormal lines in other period - if (offset > 0L) { - if (nrow(p_after)) { - p_after[, `:=`( - from = from + offset, to = to + offset, - missing = list(list(lapply(missing[[1L]], "+", offset))), - out_of_range = list(list(lapply(out_of_range[[1L]], "+", offset))) - ), - by = "index" - ] - } - - p[, `:=`( - to = to + offset, - missing = list(list(lapply(missing[[1L]], "+", offset))), - out_of_range = list(list(lapply(out_of_range[[1L]], "+", offset))) - )] + m_prev <- matched[index == target_period] + data <- rbindlist(list( + # before the last line of target period + epw_data[1:(m_prev$row + m_prev$num - 1L)], + data, + # before the first line of next period + epw_data[(m_prev$row + m_prev$num):.N] + )) + matched <- rbindlist(list( + matched[index <= target_period], + m[, `:=`(index = target_period + 1L, row = m_prev$row + m_prev$num)], + matched[index > target_period][, `:=`(index = index + 1L, row = row + m$num)] + )) } - - epw_header$period$period <- setorderv(rbindlist(list(p_previous, p, p_after, p_other)), "index") } + # }}} - # clean - set(data, NULL, setdiff(names(data), names(epw_data)), NULL) - - list(header = epw_header, previous = previous, data = data, after = after) + list(data = data, header = header, matched = matched, period = p$index) } # }}} # find_nearst_wday_year {{{ @@ -3086,6 +2332,40 @@ find_nearst_wday_year <- function (date, week_day, year = NULL, leap_year = FALS year } # }}} +# create_epw_datetime_components {{{ +create_epw_datetime_components <- function (start, end, interval, tz = "UTC", leapyear = FALSE) { + if (is_epwdate(start)) start <- reset_epwdate_year(start, leapyear) + if (is_epwdate(end)) end <- reset_epwdate_year(end, leapyear) + + start <- as_date(start) + end <- as_date(end) + + step <- as.integer(60L / interval) + offset <- lubridate::minutes(step) + + s <- lubridate::force_tz(start + offset, tzone = tz) + e <- lubridate::force_tz(end + offset + lubridate::days(1L), tzone = tz) + + # get hour + h <- rep(1L:24L, each = interval, times = difftime(e, s, units = "days")) + + # get minute + start_min <- if (interval == 1L) 0L else step + m <- rep(seq(start_min, 60L, length.out = interval), times = difftime(e, s, units = "hours")) + + # get year, month and day + ymd <- rep(seq(as_date(s), as_date(e) - lubridate::days(1L), by = "day"), + each = 24 * interval + ) + + data.table( + year = as.integer(lubridate::year(ymd)), + month = as.integer(lubridate::month(ymd)), + day = as.integer(lubridate::mday(ymd)), + hour = h, minute = m + ) +} +# }}} # FORMAT # format_epw {{{ @@ -3097,140 +2377,47 @@ format_epw <- function (epw_data, epw_header, fmt_digit = TRUE, fill = FALSE, pu } # }}} # format_epw_header {{{ -format_epw_header <- function (epw_header) { - str <- EPW_HEADER - for (i in names(str)) { - str[i] <- paste( - str[[i]], - match.fun(paste0("format_epw_header_", i))(epw_header[[i]]), - sep = "," - ) - } - str -} -# }}} -# format_epw_header_location {{{ -format_epw_header_location <- function (location) { - location$latitude <- fmt_dbl(location$latitude) - location$longitude <- fmt_dbl(location$longitude) - location$time_zone <- fmt_int(location$time_zone) - location$elevation <- fmt_int(location$elevation) - paste0(unlist(location, use.names = FALSE), collapse = ",") -} -# }}} -# format_epw_header_design {{{ -format_epw_header_design <- function (design) { - if (length(design) == 0L) return("0") - res <- paste("1", design$source, "", sep = ",") - for (i in 2L:4L) { - res <- paste(res, - stri_trans_totitle(names(design)[i]), - if (i < 4L) { - paste( - design[[i]][1L], # month - paste0(fmt_dbl(unlist( - design[[i]][-c(1L, length(design[[i]]))], - use.names = FALSE), 1L), collapse = "," - ), - design[[i]][length(design[[i]])], # number of hours - sep = "," - ) - } else { - paste0(fmt_dbl(unlist(design[[i]], use.names = FALSE), 1L), collapse = ",") - }, - sep = "," - ) - } - res -} -# }}} -# format_epw_header_typical {{{ -format_epw_header_typical <- function (typical) { - if (length(typical) == 0L) return("0") - paste(nrow(typical), - typical[, paste( - name, - stri_trans_totitle(type), - format(start_day), - format(end_day), - sep = ",", - collapse = "," - )], - sep = "," - ) -} -# }}} -# format_epw_header_ground {{{ -format_epw_header_ground <- function (ground) { - if (length(ground) == 0L) return("0") - d <- dcast.data.table(copy(ground)[, temp := fmt_dbl(temperature)], - index + depth + soil_conductivity + soil_density + soil_specific_heat ~ month, - value.var = "temp" - ) - d[, res := paste( - round(depth, digits = 2), - ifelse(is.na(soil_conductivity), "", fmt_dbl(soil_conductivity)), - ifelse(is.na(soil_density), "", fmt_dbl(soil_density)), - ifelse(is.na(soil_specific_heat), "", fmt_dbl(soil_specific_heat)), - sep = "," - )] - d[, res := paste(res, do.call(function (...) paste(..., sep = ","), .SD), sep = ","), - .SDcols = as.character(1L:12L) - ] - paste(max(d$index), paste0(d$res, collapse = ","), sep = ",", collapse = ",") -} -# }}} -# format_epw_header_holiday {{{ -format_epw_header_holiday <- function (holiday) { - res <- paste(if (holiday$leapyear) "Yes" else "No", holiday$dst[1L], holiday$dst[2L], sep = ",") - if (nrow(holiday$holiday) == 0L) return(paste(res, "0", sep = ",")) - paste(res, holiday$holiday[, paste(name, day, sep = ",", collapse = ",")], sep = ",") -} -# }}} -# format_epw_header_comment1 {{{ -format_epw_header_comment1 <- function (comment1) { - paste(comment1, sep = ",", collapse = ",") -} -# }}} -# format_epw_header_comment2 {{{ -format_epw_header_comment2 <- format_epw_header_comment1 -# }}} -# format_epw_header_period {{{ -format_epw_header_period <- function (period) { - res <- paste(nrow(period$period), period$interval, sep = ",") - paste(res, - period$period[, paste( - name, - get_epw_wday(start_day_of_week, TRUE), - format(start_day, m_spc = TRUE), - format(end_day, m_spc = TRUE), - sep = ",", - collapse = "," - )], - sep = "," +format_epw_header <- function (header) { + header$value <- standardize_idf_value(get_epw_idd_env(), header, type = "choice") + fmt <- get_idf_string(get_epw_idd_env(), header, header = FALSE, comment = FALSE, + format = "new_top", leading = 0, sep_at = -1, flat = FALSE ) + fmt <- lapply(fmt$format$fmt, "[[", 2L) + + vcapply(fmt, function (s) { + # remove trailing semicolon + s[length(s)] <- stri_sub(s[length(s)], to = -2L) + + paste0(s, collapse = "") + }) } # }}} # format_epw_data {{{ -format_epw_data <- function (epw_data, epw_header, fmt_digit = TRUE, fill = FALSE, purge = FALSE, ...) { - if (purge) epw_data <- purge_epw_data_redundant(epw_data, epw_header) +format_epw_data <- function (epw_data, epw_header, fmt_digit = FALSE, fill = FALSE, purge = FALSE, ...) { + if (purge) epw_data <- purge_epw_data_redundant(epw_data, epw_header, matched) + d <- epw_data[, -"datetime"] - if (fill) d <- fill_epw_data_abnormal(d, epw_header, ...) - # round digits as WeatherConvertor - if (fmt_digit) { - for (nm in names(EPW_FORMAT)) { - set(d, NULL, nm, EPW_FORMAT[[nm]](d[[nm]])) - } - } + if (fill) d <- fill_epw_data_abnormal(d, epw_header, matched, ...) + + # # round digits as WeatherConvertor + # if (fmt_digit) { + # for (nm in names(EPW_FORMAT)) { + # set(d, NULL, nm, EPW_FORMAT[[nm]](d[[nm]])) + # } + # } d } # }}} +# format_epw_meta {{{ +format_epw_meta <- function (header) { + idd_env <- get_epw_idd_env() + + loc <- get_idf_value(idd_env, header, EPW_CLASS$location, property = c("field_name_us", "type_enum")) + loc <- setattr(get_value_list(loc), "names", loc$field_name_us) + leapyear <- get_idf_value(idd_env, header, EPW_CLASS$holiday, field = 1L)$value_chr + interval <- get_idf_value(idd_env, header, EPW_CLASS$period, field = 2L)$value_num -# PRINT -# print_epw_header {{{ -print_epw_header <- function (epw_header) { - cli::cat_rule("EnergyPlus Weather File", line = 2) # lat_lon {{{ lat_lon <- function(lat, longitude = FALSE) { sig <- if (longitude) c("E", "W") else c("N", "S") @@ -3241,54 +2428,45 @@ print_epw_header <- function (epw_header) { paste0(sig, " ", p1, "\u00B0", p2, "'") } # }}} - loc <- epw_header$location - cli::cat_line(sprintf("[Location ]: %s, %s, %s", loc$city, loc$state_province, loc$country)) - # format time zone into UTC offset - tz <- loc$time_zone - h <- abs(trunc(tz)) - m <- round((abs(tz) - h) * 60) - cli::cat_line(sprintf(" {%s}, {%s}, {UTC%s}", - lat_lon(loc$latitude), - lat_lon(loc$longitude, TRUE), - paste0(if (tz >= 0) "+" else "-", lpad(h, "0", 2L), ":", lpad(m, "0", 2L)) - )) - cli::cat_line(sprintf("[Elevation]: %.fm %s see level", abs(loc$elevation), if (loc$elevation >= 0) "above" else "below")) - cli::cat_line(sprintf("[Data Src ]: %s", loc$data_source)) - cli::cat_line(sprintf("[WMO Stat ]: %s", loc$wmo_number)) - cli::cat_line( "[Leap Year]: ", epw_header$holiday$leapyear) - cli::cat_line( "[Interval ]: ", (60 / epw_header$period$interval), " mins") - cli::cat_line() - cli::cat_rule("Data Periods") - print(epw_header$period$period[, - list(Name = name, - `StartDayOfWeek` = get_epw_wday(start_day_of_week, label = TRUE), - `StartDay` = start_day, `EndDay` = end_day)] + + # format location + c( + sprintf("[Location ]: %s, %s, %s", loc$city, loc$state_province, loc$country), + # format time zone into UTC offset + { + tz <- loc$time_zone + h <- abs(trunc(tz)) + m <- round((abs(tz) - h) * 60) + sprintf(" {%s}, {%s}, {UTC%s}", + lat_lon(loc$latitude), + lat_lon(loc$longitude, TRUE), + paste0(if (tz >= 0) "+" else "-", lpad(h, "0", 2L), ":", lpad(m, "0", 2L)) + ) + }, + sprintf("[Elevation]: %.fm %s see level", abs(loc$elevation), if (loc$elevation >= 0) "above" else "below"), + sprintf("[Data Src ]: %s", loc$data_source), + sprintf("[WMO Stat ]: %s", loc$wmo_number), + sprintf("[Leap Year]: %s", if (is.na(leapyear)) "Unknown" else if (tolower(leapyear) == "yes") "Yes" else "No"), + sprintf("[Interval ]: %s mins", 60 / interval) ) - cli::cat_line() - cli::cat_rule() - invisible(epw_header) } # }}} # SAVE # save_epw_file {{{ -save_epw_file <- function (epw_data, epw_header, path, overwrite = FALSE, +save_epw_file <- function (epw_data, epw_header, matched, path, overwrite = FALSE, fmt_digit = TRUE, fill = FALSE, purge = FALSE, ...) { if (!file.exists(path)) { new_file <- TRUE } else { new_file <- FALSE if (!overwrite) { - abort("error_not_overwrite_epw", - paste("Target EPW file already exists. Please set `overwrite` to", - "TRUE if you want to replace it." - ) - ) + abort("Target EPW file already exists. Please set 'overwrite' to 'TRUE' if you want to replace it.") } } l <- format_epw(epw_data, epw_header, fmt_digit = fmt_digit, fill = fill, purge = FALSE, ...) - write_lines(unlist(l$header, use.names = FALSE), path) + write_lines(l$header, path) fwrite(l$data, path, append = TRUE) if (!new_file && overwrite) { diff --git a/R/impl-idd.R b/R/impl-idd.R index fd1ee5ad2..270bd68dd 100644 --- a/R/impl-idd.R +++ b/R/impl-idd.R @@ -194,8 +194,12 @@ get_idd_field <- function (idd_env, class, field = NULL, property = NULL, all = } else { res <- get_idd_field_from_which(idd_env, class, field, underscore, no_ext, complete, all) } - if (has_names(res, "field_name_us")) set(res, NULL, "field_name_us", NULL) - clean_field_property(res, property %||% "") + + cols <- c("rleid", "class_id", "class_name", "field_id", "field_index", "field_name", "field_in") + if (length(col_del <- setdiff(names(res), c(cols, property)))) { + set(res, NULL, col_del, NULL) + } + res } # }}} @@ -406,6 +410,7 @@ get_idd_field_from_which <- function (idd_env, class, field, underscore = TRUE, set(dt_ext_join, NULL, col_prop, NULL) set(dt_join, NULL, col_prop, NULL) fld <- append_dt(dt_join[!is.na(field_id)], dt_ext_join) + setorderv(fld, "field_rleid") set(fld, NULL, "field_rleid", NULL) # }}} } else { @@ -430,17 +435,9 @@ get_idd_field_from_which <- function (idd_env, class, field, underscore = TRUE, # }}} } - set(fld, NULL, "field_name_us", NULL) fld } # }}} -# clean_field_property {{{ -clean_field_property <- function (dt, property) { - col_del <- setdiff(FIELD_COLS$property, property) - if (length(col_del)) set(dt, NULL, col_del, NULL) - dt -} -# }}} # REFERENCES # get_recursive_relation {{{ diff --git a/R/impl-idf.R b/R/impl-idf.R index 67de484a1..b1cd0be18 100644 --- a/R/impl-idf.R +++ b/R/impl-idf.R @@ -828,6 +828,54 @@ init_idf_value <- function (idd_env, idf_env, class, field = NULL, property = NU "value_id", "value_chr", "value_num")) } # }}} +# standardize_idf_value {{{ +#' Standardize Value Data +#' +#' @param idd_env An environment or list contains IDD tables including class, +#' field, and reference. +#' @param idf_env An environment or list contains IDF tables including object, +#' value, and reference. +#' @param class An integer vector of valid class indexes or a character vector +#' of valid class names. Default: `NULL`. +#' @param object An integer vector of valid object IDs or a character vector +#' of valid object names. Default: `NULL`. +#' @param field An integer vector of valid field indexes or a character +#' vector of valid field names (can be in in underscore style). `class` +#' and `field` should have the same length. +#' @param type A character vector to specify what type of values to be +#' standardized. Should be a subset of `c("choice", "reference")`. +#' Default: `c("choice", "reference")`. +#' +#' @return A data.table +#' @keywords internal +#' @export +standardize_idf_value <- function (idd_env, idf_env, class = NULL, object = NULL, field = NULL, type = c("choice", "reference")) { + type <- assert_subset(type, c("choice", "reference"), empty.ok = FALSE) + + prop <- "type_enum" + if ("choice" %chin% type) prop <- c(prop, "choice") + + val <- get_idf_value(idd_env, idf_env, class, object, field, property = prop) + + if ("choice" %chin% type && any(i <- val$type_enum == IDDFIELD_TYPE$choice)) { + val[i, value_chr := { + i <- apply2_int(stri_trans_tolower(value_chr), lapply(choice, stri_trans_tolower), chmatch) + std <- apply2_chr(choice, i, .subset2) + value_chr[!is.na(i)] <- apply2_chr(choice[!is.na(i)], i[!is.na(i)], .subset2) + value_chr + }] + } + + if ("reference" %chin% type && any(i <- val$type_enum == IDDFIELD_TYPE$object_list) && nrow(idf$reference)) { + ref <- idf_env$reference[J(val$value_id[i]), on = "value_id", nomatch = NULL] + ref[idf_env$value, on = c("src_value_id" = "value_id"), + `:=`(src_value_chr = i.value_chr, src_value_num = i.value_num)] + val[ref, on = "value_id", `:=`(value_chr = i.src_value_chr, value_num = i.src_value_num)] + } + + set(val, NULL, prop, NULL) +} +# }}} # DOTS EXPANSION # expand_idf_dots_name {{{ @@ -1035,7 +1083,7 @@ parse_dots_value <- function (..., .scalar = TRUE, .pair = FALSE, # indicate that LHS is a single name set(dt_in, i, "lhs_sgl", TRUE) # for 'c(Obj, Obj) := list()' - } else if (as.character(li[[2L]][[1L]]) %in% c("c", ".")) { + } else if (as.character(li[[2L]][[1L]]) %chin% c("c", ".")) { li[[2L]][[1L]] <- as.name("c") name <- eval(li[[2L]], envir = .env) name <- assert_valid_type(name, "ID | Name | Index") @@ -1046,8 +1094,16 @@ parse_dots_value <- function (..., .scalar = TRUE, .pair = FALSE, set(dt_in, i, "id", list(name)) set(dt_in, i, "name", list(rep(NA_character_, length(name)))) } + # for '..(Cls) := list()' + } else if (as.character(li[[2L]][[1L]]) == "..") { + li[[2L]][[1L]] <- as.name("c") + name <- eval(li[[2L]], envir = .env) + name <- assert_valid_type(name, "Name", len = 1L, type = "name") + set(dt_in, i, "name", list(name)) + # indicate that LHS is a single name + set(dt_in, i, "lhs_sgl", TRUE) } else { - abort("Assertion on 'Input' failed: LHS of ':=' must start with '.()' or 'c()'", "dots_ref_lhs") + abort("Assertion on 'Input' failed: LHS of ':=' must start with '.()', 'c()', or '..()'", "dots_ref_lhs") } li <- li[[3L]] @@ -1299,7 +1355,13 @@ parse_dots_value <- function (..., .scalar = TRUE, .pair = FALSE, #' with a valid class/object id/name. ID should be denoted in style #' `..ID`. There is a special element `.comment` in each list, which will #' be used as new comments of the object. If `.ref_assign` is `TRUE`, -#' `:=` can be used to group multiple id/name wrapped by `.()` or `c()`. +#' `:=` can be used to group ids/names: +#' +#' * When `.type` equals `"class"`, LHS multiple class indices/names should be +#' wrapped by `.()`, `c()`. +#' * When `.type` equals `"object"`, LHS multiple object ids/names should be +#' wrapped by `.()` or `c()`. LHS **SINGLE** class name should be +#' wrapped by `..()`. #' #' @param .type Should be either `"class"` or `"object"`. If `"class"`, #' id/name of each input will be treated as class index/name. If `"object"`, @@ -1639,7 +1701,7 @@ expand_idf_dots_value <- function (idd_env, idf_env, ..., add_joined_cols(idf_env$object, cls_val, "object_id", "object_name") cls_val[idf_env$value, on = c("object_id", "field_id"), value_id := i.value_id] } - setorderv(cls_val, c("rleid", "object_id")) + setorderv(cls_val, c("rleid", "object_id", "field_id")) } # combine empty @@ -2094,7 +2156,6 @@ expand_idf_dots_object <- function (idd_env, idf_env, ..., .unique = TRUE, .stri #' @export expand_idf_dots_literal <- function (idd_env, idf_env, ..., .default = TRUE, .exact = FALSE) { l <- list(...) - ver <- standardize_ver(get_idf_value(idd_env, idf_env, "Version")$value_chr) assert_list(l, c("character", "data.frame"), .var.name = "Input", min.len = 1L) @@ -2126,6 +2187,7 @@ expand_idf_dots_literal <- function (idd_env, idf_env, ..., .default = TRUE, .ex same_ver <- TRUE # parse as an IDF file + ver <- standardize_ver(get_idf_value(idd_env, idf_env, "Version")$value_chr) parsed <- withCallingHandlers( parse_idf_file(chr_one, idd = ver, ref = FALSE), @@ -2492,19 +2554,6 @@ expand_idf_regex <- function (idd_env, idf_env, pattern, replacement = NULL, } # }}} -# ASSERT -# assert_valid {{{ -assert_valid <- function (validity, action) { - if (count_check_error(validity)) { - m <- paste0(capture.output(print_validity(validity)), collapse = "\n") - t <- paste0("Failed to ", action ," object(s).") - abort(paste0(t, "\n\n", m), class = "validity_check") - } - - TRUE -} -# }}} - # OBJECT MUNIPULATION # dup_idf_object {{{ #' Duplicate existing objects @@ -2531,7 +2580,7 @@ dup_idf_object <- function (idd_env, idf_env, dt_object, level = eplusr_option(" set(dt_object, NULL, "new_object_name_lower", stri_trans_tolower(dt_object$new_object_name)) # stop if try to dup version - if (any(invld <- dt_object$class_id == 1L)) { + if (any(invld <- dt_object$class_name == "Version")) { abort(paste0("Duplicating 'Version' object is prohibited.\n", paste0(dt_object[invld, sprintf(" #%s| Object ID [%i] --> Class 'Version'", lpad(rleid, "0"), object_id)], collapse = "\n")), @@ -2637,7 +2686,7 @@ add_idf_object <- function (idd_env, idf_env, dt_object, dt_value, level = eplusr_option("validate_level")) { chk <- level_checks(level) # stop if try to add version - if (any(invld <- dt_object$class_id == 1L)) { + if (any(invld <- dt_object$class_name == "Version")) { abort(paste0("Adding 'Version' object is prohibited. Invalid input:\n", paste0(sprintf(" #%s| Class 'Version'", lpad(dt_object$rleid[invld], "0")), collapse = "\n")), "add_version") @@ -2776,7 +2825,7 @@ add_idf_object <- function (idd_env, idf_env, dt_object, dt_value, set_idf_object <- function (idd_env, idf_env, dt_object, dt_value, empty = FALSE, level = eplusr_option("validate_level")) { chk <- level_checks(level) # stop if try to modify version - if (any(invld <- dt_object$class_id == 1L)) { + if (any(invld <- dt_object$class_name == "Version")) { abort(paste0("Modifying 'Version' object is prohibited. Invalid input:\n", paste0(sprintf(" #%s| Class 'Version'", lpad(dt_object$rleid[invld], "0")), collapse = "\n")), "set_version") @@ -2883,7 +2932,7 @@ del_idf_object <- function (idd_env, idf_env, dt_object, ref_to = FALSE, ref_by chk <- level_checks(level) # stop if try to delete version - if (any(invld <- dt_object$class_id == 1L)) { + if (any(invld <- dt_object$class_name == "Version")) { abort(paste0("Deleting 'Version' object is prohibited.\n", paste0(dt_object[invld, sprintf(" #%s| Object ID [%i] --> Class 'Version'", lpad(rleid, "0"), object_id)], collapse = "\n")), @@ -3891,6 +3940,75 @@ read_idfeditor_copy <- function (idd_env, idf_env, version = NULL, in_ip = FALSE # TABLE # get_idf_table {{{ +#' Extract value data in a data.table +#' +#' @param idd_env An environment or list contains IDD tables including class, +#' field, and reference. +#' @param idf_env An environment or list contains IDF tables including object, +#' value, and reference. +#' @param class An integer vector of valid class indexes or a character vector +#' of valid class names. Default: `NULL`. +#' @param object An integer vector of valid object IDs or a character vector +#' of valid object names. Default: `NULL`. +#' @param string_value If `TRUE`, all field values are returned as +#' character. If `FALSE`, `value` column in returned +#' [data.table][data.table::data.table()] is a list column with +#' each value stored as corresponding type. Note that if the +#' value of numeric field is set to `"Autosize"` or +#' `"Autocalculate"`, it is left as it is, leaving the returned +#' type being a string instead of a number. Default: `TRUE`. +#' @param unit Only applicable when `string_value` is `FALSE`. If +#' `TRUE`, values of numeric fields are assigned with units using +#' [units::set_units()] if applicable. Default: `FALSE`. +#' @param wide Only applicable if target objects belong to a same class. +#' If `TRUE`, a wide table will be returned, i.e. first three +#' columns are always `id`, `name` and `class`, and then every +#' field in a separate column. Note that this requires all +#' objects specified must from the same class. +#' Default: `FALSE`. +#' @param align If `TRUE`, all objects in the same class will have the +#' same field number. The number of fields is the same as the +#' object that have the most fields among objects specified. +#' Default: `FALSE`. +#' @param all If `TRUE`, all available fields defined in IDD for the +#' class that objects belong to will be returned. Default: +#' `FALSE`. +#' @param group_ext Should be one of `"none"`, `"group"` or `"index"`. +#' If not `"none"`, `value` column in returned +#' [data.table::data.table()] will be converted into a list. +#' If `"group"`, values from extensible fields will be grouped by the +#' extensible group they belong to. For example, coordinate +#' values of each vertex in class `BuildingSurface:Detailed` will +#' be put into a list. If `"index"`, values from extensible fields +#' will be grouped by the extensible field indice they belong to. +#' For example, coordinate values of all x coordinates will be +#' put into a list. If `"none"`, nothing special will be done. +#' Default: `"none"`. +#' @param force If `TRUE`, `wide` can be `TRUE` even though there are +#' multiple classes in input. This can result in a data.table +#' with lots of columns. But may be useful when you know that +#' target classes have the exact same fields, e.g. +#' `Ceiling:Adiabatic` and `Floor:Adiabatic`. Default: `FALSE`. +#' @param init If `TRUE`, a table for new object input will be returned +#' with all values filled with defaults. In this case, `object` +#' input will be ignored. The `id` column will be filled with +#' possible new object IDs. Default: `FALSE`. +#' +#' @return A [data.table][data.table::data.table()] with 6 columns (if +#' `wide` is `FALSE`) or at least 5 columns (if `wide` is `TRUE`). +#' +#' When `wide` is `FALSE`, the 5 columns are: +#' +#' * `id`: Integer type. Object IDs. +#' * `name`: Character type. Object names. +#' * `class`: Character type. Current class name. +#' * `index`: Integer type. Field indexes. +#' * `field`: Character type. Field names. +#' * `value`: Character type if `string_value` is `TRUE` or list type if +#' `string_value` is `FALSE` or `group_ext` is not `"none"`. Field values. +#' +#' @keywords internal +#' @export get_idf_table <- function (idd_env, idf_env, class = NULL, object = NULL, string_value = TRUE, unit = FALSE, wide = FALSE, align = FALSE, all = FALSE, group_ext = c("none", "group", "index"), @@ -4093,7 +4211,7 @@ dt_to_load <- function (dt, string_value = TRUE) { get_idf_string <- function (idd_env, idf_env, dt_order = NULL, class = NULL, object = NULL, in_ip = FALSE, comment = TRUE, header = TRUE, format = c("sorted", "new_top", "new_bot"), - leading = 4L, sep_at = 29L) { + leading = 4L, sep_at = 29L, flat = TRUE) { format <- match.arg(format) # IP - SI conversion @@ -4132,6 +4250,8 @@ get_idf_string <- function (idd_env, idf_env, dt_order = NULL, class = NULL, obj if (from != to) idf_env$value <- value + if (!flat) return(fmt) + if (format == "sorted") { combine_fmt <- function (lst) { head <- if (is.null(lst[[1L]])) "" else c("", lst[[1L]], "") diff --git a/R/impl.R b/R/impl.R index 7690d1fab..6ca6ea2dc 100644 --- a/R/impl.R +++ b/R/impl.R @@ -206,9 +206,11 @@ errormsg_field_index <- function (dt) { dt[min_fields == 0L, msg := paste0(msg, " Field index should be no more than ", num_fields, ".")] - dt[min_fields > 0L, msg := paste0(msg, + dt[min_fields > 0L & min_fields < num_fields, msg := paste0(msg, " Field index should be no less than ", min_fields, " and no more than ", num_fields, ".")] + dt[min_fields > 0L & min_fields == num_fields, msg := paste0(msg, + " Field index should be equal to ", min_fields, ".")] paste0(dt$msg, collapse = "\n") } @@ -277,3 +279,18 @@ assert_valid_type <- function (x, name = NULL, len = NULL, null.ok = FALSE, lowe x } # }}} +# assert_valid {{{ +assert_valid <- function (validity, action = NULL, epw = FALSE) { + if (count_check_error(validity)) { + m <- paste0(format_validity(validity, epw = epw), collapse = "\n") + if (is.null(action)) { + abort(m, class = "validity_check", data = validity) + } else { + t <- paste("Failed to", action , if (epw) "header." else "object(s).") + abort(paste0(t, "\n\n", m), class = "validity_check", data = validity) + } + } + + TRUE +} +# }}} diff --git a/R/options.R b/R/options.R index 38ebade2e..c2bcf6c20 100644 --- a/R/options.R +++ b/R/options.R @@ -8,6 +8,7 @@ NULL # for storing internal data .globals$eplus <- list() .globals$idd <- list() +.globals$epw <- list() .globals$color <- has_color() # }}} diff --git a/R/parse.R b/R/parse.R index 0a92ae128..6f7b8fce4 100644 --- a/R/parse.R +++ b/R/parse.R @@ -27,7 +27,10 @@ IDD_SLASHKEY <- list ( flat = c("field", "required-field", "units", "ip-units", "unitsbasedonfield", "minimum", "minimum>", "maximum", "maximum<", "default", "autosizable", "autocalculatable", "type", - "external-list", "begin-extensible"), + "external-list", "begin-extensible", + # EPW specific + "missing", "exist-minimum", "exist-minimum>", "exist-maximum", "exist-maximum<" + ), nest = c("note", "key", "object-list", "reference", "reference-class-name") ), @@ -36,9 +39,12 @@ IDD_SLASHKEY <- list ( "unitsbasedonfield", "autosizable", "autocalculatable", "begin-extensible", "deprecated", "obsolete", "retaincase"), int = c("min-fields", "extensible"), - dbl = c("minimum", "minimum>", "maximum", "maximum<"), + dbl = c("minimum", "minimum>", "maximum", "maximum<", + # EPW specific + "exist-minimum", "exist-minimum>", "exist-maximum", "exist-maximum<" + ), chr = c("group", "format", "field", "units", "ip-units", "default", "type", - "external-list"), + "external-list", "missing"), lst = c("memo", "reference-class-name", "note", "key", "object-list", "reference") ) @@ -84,14 +90,17 @@ FIELD_COLS <- list( "type_enum", "src_enum", "type", "autosizable", "autocalculatable", "has_range", "maximum", "minimum", "lower_incbounds", "upper_incbounds", - "default_chr", "default_num", "choice", "note" + "default_chr", "default_num", "choice", "note", + # EPW specific + "missing_chr", "missing_num", + "has_exist", "exist_maximum", "exist_minimum", "exist_lower_incbounds", "exist_upper_incbounds" ) ) # nocov end # }}} # parse_idd_file {{{ -parse_idd_file <- function(path) { +parse_idd_file <- function(path, epw = FALSE) { # read idd string, get idd version and build idd_dt <- read_lines(path) @@ -104,6 +113,7 @@ parse_idd_file <- function(path) { # type enum type_enum <- list(unknown = 0L, slash = 1L, group = 2L, class = 3L, field = 4L, field_last = 5L) + # idd_dt[slash_key == "exist-minimum>"] # separate lines into bodies, slash keys and slash values idd_dt <- sep_idd_lines(idd_dt) @@ -133,7 +143,7 @@ parse_idd_file <- function(path) { ) # complete property columns - dt_field <- complete_property(dt_field, "field", dt_class) + dt_field <- complete_property(dt_field, "field", dt_class, epw = epw) dt_class <- complete_property(dt_class, "class", dt_field) # ConnectorList references are missing until v9.1 @@ -203,7 +213,7 @@ parse_idf_file <- function (path, idd = NULL, ref = TRUE) { idf_dt <- dt$left # object table - dt <- sep_object_table(idf_dt, type_enum, idd_ver, idd_env) + dt <- sep_object_table(idf_dt, type_enum, idd_env) dt_object <- dt$object idf_dt <- dt$left @@ -354,7 +364,7 @@ sep_idd_lines <- function (dt, col = "string") { # b) for numeric value slash with comments, e.g. "\extensible:<#> -some comments" # https://stackoverflow.com/questions/3575331/how-do-extract-decimal-number-from-string-in-c-sharp/3575807 dt[J(c(IDD_SLASHKEY$type$int, IDD_SLASHKEY$type$dbl)), on = "slash_key", - `:=`(slash_value = stri_extract_first_regex(slash_value, "[-+]?[0-9]*\\.?[0-9]+(?:[eE][-+]?[0-9]+)?")) + `:=`(slash_value = stri_extract_first_regex(slash_value, "[-+]?([0-9]*\\.?[0-9]+(?:[eE][-+]?[0-9]+)?|Inf)")) ] # change all values of reference, object-list and refercne-class-name to @@ -697,7 +707,7 @@ dcast_slash <- function (dt, id, keys, keep = NULL) { # }}} # complete_property {{{ -complete_property <- function (dt, type, ref) { +complete_property <- function (dt, type, ref, epw = FALSE) { type <- match.arg(type, c("class", "field")) keys <- switch(type, class = IDD_SLASHKEY$class, field = IDD_SLASHKEY$field) @@ -726,7 +736,7 @@ complete_property <- function (dt, type, ref) { slash_as_type(key)(res) } - # convert proerty column types + # convert property column types types <- unlist(IDD_SLASHKEY$type, use.names = FALSE) for (key in intersect(names(dt), types)) { if (!slash_is_type(key)(dt[[key]])) { @@ -742,7 +752,7 @@ complete_property <- function (dt, type, ref) { dt <- switch(type, class = parse_class_property(dt, ref), - field = parse_field_property(dt, ref) + field = parse_field_property(dt, ref, epw = epw) ) dt @@ -799,7 +809,7 @@ parse_class_property <- function (dt, ref) { # }}} # parse_field_property {{{ -parse_field_property <- function (dt, ref) { +parse_field_property <- function (dt, ref, epw = FALSE) { # rename column names to lower case nms <- stri_replace_all_fixed(names(dt), "-", "_") setnames(dt, nms) @@ -834,6 +844,14 @@ parse_field_property <- function (dt, ref) { # parse field default dt <- parse_field_property_default(dt) + # EPW specific + if (epw) { + # parse EPW missing field + dt <- parse_field_property_missing(dt) + # parse EPW range of existing field + dt <- parse_field_property_exist(dt) + } + # add lower underscore name set(dt, NULL, "field_name_us", stri_trans_tolower(underscore_name(dt$field_name))) @@ -934,16 +952,52 @@ parse_field_property_default <- function (dt) { } # }}} +# parse_field_property_missing {{{ +parse_field_property_missing <- function (dt) { + set(dt, NULL, "missing_num", NA_real_) + set(dt, NULL, "missing_chr", dt$missing) + dt[type_enum <= IDDFIELD_TYPE$real, `:=`(missing_num = suppressWarnings(as.double(missing)))] + dt +} +# }}} + # parse_field_property_range {{{ parse_field_property_range <- function (dt) { set(dt, NULL, c("has_range", "lower_incbounds", "upper_incbounds"), FALSE) - dt[!is.na(minimum), `:=`(has_range = TRUE, lower_incbounds = TRUE)] - dt[!is.na(maximum), `:=`(has_range = TRUE, upper_incbounds = TRUE)] - dt[!is.na(`minimum>`), `:=`(has_range = TRUE, minimum = `minimum>`)] - dt[!is.na(`maximum<`), `:=`(has_range = TRUE, maximum = `maximum<`)] + setnames(dt, c("minimum>", "maximum<"), c("minimum_u", "maximum_l")) + dt[!J(NA_real_), on = "minimum", `:=`(has_range = TRUE, lower_incbounds = TRUE)] + dt[!J(NA_real_), on = "maximum", `:=`(has_range = TRUE, upper_incbounds = TRUE)] + dt[!J(NA_real_), on = "minimum_u", `:=`(has_range = TRUE, minimum = minimum_u)] + dt[!J(NA_real_), on = "maximum_l", `:=`(has_range = TRUE, maximum = maximum_l)] - set(dt, NULL, c("minimum>", "maximum<"), NULL) + set(dt, NULL, c("minimum_u", "maximum_l"), NULL) + dt +} +# }}} + +# parse_field_property_exist {{{ +parse_field_property_exist <- function (dt) { + set(dt, NULL, c("has_exist", "exist_lower_incbounds", "exist_upper_incbounds"), FALSE) + + setnames(dt, c("exist_minimum>", "exist_maximum<"), c("exist_minimum_u", "exist_maximum_l")) + + dt[!J(NA_real_), on = "exist_minimum", `:=`(has_exist = TRUE, exist_lower_incbounds = TRUE)] + dt[!J(NA_real_), on = "exist_maximum", `:=`(has_exist = TRUE, exist_upper_incbounds = TRUE)] + dt[!J(NA_real_), on = "exist_minimum_u", `:=`(has_exist = TRUE, + exist_minimum = exist_minimum_u, exist_lower_incbounds = FALSE)] + dt[!J(NA_real_), on = "exist_maximum_l", `:=`(has_exist = TRUE, + exist_maximum = exist_maximum_l, exist_upper_incbounds = FALSE)] + + # by default use minimum and missing code as the lower and upper bound + dt[!is.na(minimum) & is.na(exist_minimum), `:=`( + has_exist = TRUE, exist_minimum = minimum, exist_lower_incbounds = lower_incbounds + )] + dt[!is.na(missing_num) & is.na(exist_maximum), `:=`( + has_exist = TRUE, exist_maximum = missing_num, exist_upper_incbounds = FALSE + )] + + set(dt, NULL, c("exist_minimum_u", "exist_maximum_l"), NULL) dt } # }}} @@ -1157,7 +1211,7 @@ sep_header_options <- function (dt, type_enum) { # }}} # sep_object_table {{{ -sep_object_table <- function (dt, type_enum, version, idd) { +sep_object_table <- function (dt, type_enum, idd) { # object id left <- dt[J(type_enum$value_last), on = "type", list(line, object_id = seq_along(line)), nomatch = 0L] dt <- left[dt, on = "line", roll = -Inf] @@ -1243,12 +1297,12 @@ sep_object_table <- function (dt, type_enum, version, idd) { # }}} # get_value_table {{{ -get_value_table <- function (dt, idd) { +get_value_table <- function (dt, idd, escape = FALSE) { # count value number per line set(dt, NULL, "value_count", stri_count_fixed(dt$body, ",") + stri_endswith_fixed(dt$body, ";")) # in case there are multiple semicolon in one line - if (any(stri_count_fixed(dt$body, ";") > 1L)) { + if (any(stri_count_fixed(dt$body, ";") > 1L) && !escape) { parse_error("idf", "Invalid line found", dt[stri_count_fixed(body, ";") > 1L], subtype = "line") } @@ -1318,7 +1372,7 @@ get_value_table <- function (dt, idd) { # bind columns set(fld, NULL, c("rleid", "field_in"), NULL) - dt <- unique(fld, by = "field_id")[dt, on = c("class_id", "field_index")] + dt <- dt[unique(fld, by = "field_id"), on = c("class_id", "field_index")] # fill data for missing fields dt[is.na(line), `:=`(value_id = new_id(dt, "value_id", length(value_id)))] @@ -1327,6 +1381,7 @@ get_value_table <- function (dt, idd) { dt[type_enum <= IDDFIELD_TYPE$real, `:=`(value_num = suppressWarnings(as.numeric(value_chr)))] # update value_chr upon the numeric value dt[!is.na(value_num), `:=`(value_chr = as.character(value_num))] + setnafill(dt, "locf", cols = "object_id") # only keep useful columns nms <- c("value_id", "value_chr", "value_num", "object_id", "field_id", @@ -1485,16 +1540,18 @@ get_value_reference_map <- function (idd_env, src, value, all = TRUE) { # parse_issue {{{ parse_warn <- function (type = c("idf", "idd", "err", "epw"), title, data = NULL, - num = NULL, prefix = NULL, post = NULL, subtype = NULL) { - parse_issue(type, title, data, num, prefix, post, stop = FALSE, subtype = subtype) + num = NULL, prefix = NULL, suffix = NULL, post = NULL, + stop = TRUE, subtype = NULL, loc_name = "Line") { + parse_issue(type, title, data, num, prefix, suffix, post, stop = FALSE, subtype, loc_name) } parse_error <- function (type = c("idf", "idd", "err", "epw"), title, data = NULL, - num = NULL, prefix = NULL, post = NULL, subtype = NULL) { - parse_issue(type, title, data, num, prefix, post, stop = TRUE, subtype = subtype) + num = NULL, prefix = NULL, suffix = NULL, post = NULL, + stop = TRUE, subtype = NULL, loc_name = "Line") { + parse_issue(type, title, data, num, prefix, suffix, post, stop = TRUE, subtype, loc_name) } -parse_issue <- function (type = c("idf", "idd", "err", "epw"), - title, data = NULL, num = NULL, prefix = NULL, post = NULL, - stop = TRUE, subtype = NULL) { +parse_issue <- function (type = c("idf", "idd", "err", "epw"), title, data = NULL, + num = NULL, prefix = NULL, suffix = NULL, post = NULL, + stop = TRUE, subtype = NULL, loc_name = "Line") { start_rule <- cli::rule(line = 2L) @@ -1504,10 +1561,9 @@ parse_issue <- function (type = c("idf", "idd", "err", "epw"), num <- nrow(data) } assert_names(names(data), must.include = c("line", "string")) - mes <- paste0(data$msg_each, "Line ", lpad(data$line), ": ", data$string) - if (!is.null(prefix)) { - mes <- paste0(prefix, mes) - } + mes <- paste0(data$msg_each, loc_name, " ", lpad(data$line), ": ", data$string) + if (!is.null(prefix)) mes <- paste0(prefix, mes) + if (!is.null(suffix)) mes <- paste0(mes, suffix) # only show the first 15 message if (length(mes) > 10L) { diff --git a/R/units.R b/R/units.R index a9940765e..d6d71ed1a 100644 --- a/R/units.R +++ b/R/units.R @@ -8,8 +8,9 @@ reg_custom_units <- function () { { install_symbolic_unit("person") install_symbolic_unit("dollar") - install_conversion_constant("Wh", "J", 3.6E3) + install_symbolic_unit("thousandths") install_conversion_constant("inH2O", "inch_H2O_39F", 1) + TRUE }, warning = function (w) NULL, error = function (e) NULL @@ -115,7 +116,9 @@ FIELD_UNIT_TABLE <- fread( K/m K/m F/ft degF/ft W/s W/s W/s W/s kmol kmol kmol kmol - J J Wh Wh + J J Wh W*hr + Wh/m2 W*h/m^2 Wh/m2 W*hr/m^2 + cd/m2 cd/m^2 cd/m2 cd/m^2 GJ GJ ton-hrs ton*hr days days days days kg/m2 kg/m2 lb/ft2 lb/ft^2 diff --git a/R/validate.R b/R/validate.R index c2392f0c4..dd64c6950 100644 --- a/R/validate.R +++ b/R/validate.R @@ -112,6 +112,7 @@ exclude_invalid <- function (env_in, invalid, on) { #' #' # 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, @@ -119,18 +120,16 @@ custom_validate <- function ( type = FALSE, choice = FALSE, range = FALSE, reference = FALSE ) { - assert( - is_flag(required_object), - is_flag(unique_object), - is_flag(unique_name), - is_flag(extensible), - is_flag(required_field), - is_flag(auto_field), - is_flag(type), - is_flag(choice), - is_flag(range), - is_flag(reference) - ) + 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, @@ -166,10 +165,11 @@ custom_validate <- function ( #' 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 (is_string(level)) { - level <- match.arg(level, c("none", "draft", "final")) + if (test_string(level)) { + level <- assert_choice(level, c("none", "draft", "final")) if (level == "none") { custom_validate() } else if (level == "draft") { @@ -184,9 +184,8 @@ level_checks <- function (level = eplusr_option("validate_level")) { type = TRUE, choice = TRUE, range = TRUE, reference = TRUE ) } - } else { - assert(is.list(level), msg = "`level` should be a string or a list.") - assert(has_name(level, names(custom_validate()))) + } 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, @@ -199,6 +198,8 @@ level_checks <- function (level = eplusr_option("validate_level")) { range = level$range, reference = level$reference ) + } else { + stop("'level' must be a string or a list") } } # }}} @@ -230,35 +231,37 @@ validate_on_level <- function (idd_env, idf_env, dt_object = NULL, dt_value = NU } # }}} # 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. +#' 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, @@ -283,7 +286,7 @@ validate_objects <- function 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", + c("class_id", "class_name", "object_name", "field_name", "field_index", "type_enum", "units", "ip_units"), NULL), add = TRUE @@ -292,12 +295,11 @@ validate_objects <- function check_whole <- TRUE } else { check_whole <- FALSE - add_joined_cols(idd_env$field, dt_value, "field_id", c("type_enum", "ip_units", "units")) } # add field attributes used for validating {{{ # add field index - cols_add <- character(0) + 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") @@ -314,9 +316,9 @@ validate_objects <- function # to check reference if (isTRUE(reference)) cols_add <- c(cols_add, "src_enum") - cols_add <- setdiff(unique(cols_add), names(dt_value)) + cols_add <- setdiff(cols_add, names(dt_value)) if (length(cols_add)) { - dt_value <- add_joined_cols(idd_env$field, dt_value, "field_id", cols_add) + dt_value <- add_field_property(idd_env, dt_value, cols_add) on.exit(set(dt_value, NULL, cols_add, NULL), add = TRUE) } # }}} @@ -589,7 +591,7 @@ check_invalid_reference <- function (idd_env, idf_env, env_in) { 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$reference, + 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) @@ -653,8 +655,8 @@ count_check_error <- function (validity) { } # }}} -# print_validity: print all validity results {{{ -print_validity <- function (validity) { +# 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) @@ -662,28 +664,33 @@ print_validity <- function (validity) { error_type <- names(which(error_num_per > 0L)) if (error_num == 0L) { - cli::cat_line(" ", cli::symbol$tick, " ", "No error found.") - return() + return(paste0(" ", cli::symbol$tick, " ", "No error found.")) } - cli::cat_line(" ", cli::symbol$cross, " [", error_num, "] ", - "Errors found during validation.") - cli::cat_rule(line = 2) + header <- c( + paste0(" ", cli::symbol$cross, " [", error_num, "] ", + "Errors found during validation."), + cli::rule(line = 2, width = cli::console_width() - 2L) + ) - mapply(print_single_validity, type = error_type, - MoreArgs = list(single_validity = validity[error_type])) + detail <- mapply(format_single_validity, type = error_type, + MoreArgs = list(single_validity = validity[error_type], epw = epw), + SIMPLIFY = FALSE, USE.NAMES = FALSE + ) - cli::cat_line() + c(header, unlist(detail, FALSE, FALSE)) } # }}} -# print_single_validity: print a single validity result {{{ -print_single_validity <- function (single_validity, type) { +# 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 = "Missing Required Object", - duplicate_object = "Duplicated Unique Object", - conflict_name = "Conflicted Object Names", + missing_object = paste("Missing Required", obj), + duplicate_object = paste("Duplicated Unique", obj), + conflict_name = paste0("Conflicted", obj, "Names"), incomplete_extensible = "Incomplete Extensible Group", missing_value = "Missing Required Field", invalid_autosize = "Invalid Autosize Field", @@ -697,9 +704,9 @@ print_single_validity <- function (single_validity, type) { ) bullet <- switch(type, - missing_object = "Objects below are required but not exist:", - duplicate_object = "Objects should be unique but have multiple instances:", - conflict_name = "Objects below have the same name:", + 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`:", @@ -711,29 +718,40 @@ print_single_validity <- function (single_validity, type) { invalid_range = "Fields below exceed prescribed ranges:", invalid_reference = "Fields below are not one of valid references:") - cli::cat_line() - cli::cat_rule(paste0("[", error_num, "] ", title)) - cli::cat_line(" ", bullet, "\n") + out <- c("", + cli::rule(paste0("[", error_num, "] ", title), width = cli::console_width() - 2L), + paste0(" ", bullet), + "" + ) if (type == "missing_object") { - cli::cat_line(paste0(" * ", surround(single_validity[[type]]))) - } else { - cli::cat_line( - paste0(" ", - unlist( - format_objects(single_validity[[type]], - c("class", "object", "value"), brief = FALSE)$out, - use.names = FALSE - ) - ) - ) + 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, ...) { - print_validity(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) } # }}} diff --git a/inst/extdata/epw.idd b/inst/extdata/epw.idd new file mode 100644 index 000000000..b2a6c6edd --- /dev/null +++ b/inst/extdata/epw.idd @@ -0,0 +1,904 @@ +!IDD_Version 1.0.0 +!IDD_BUILD 2020-07-20 +! ************************************************************************** +! EnergyPlus Weather Format Specification +! +! Adopted from EnergyPlus Weather File (EPW) Data Dictionary from +! "AuxillaryPrograms.PDF" +! +! Specifical field-level comments +! -------------------- +! In addition, the following special comments are added compared to a normal +! EnergyPlus Input Data Dictionary (IDD). +! +! Field-level comments: +! +! \missing Missing code. +! +! \exist-minimum Minimum that includes the following value to be treated +! as existing. Otherwise EnergyPlus will treat it as a missing +! value even though it does not equal to the missing code. +! +! \exist-minimum> Minimum that must be > than the following value to be treated +! as existing. Otherwise EnergyPlus will treat it as a missing +! value even though it does not equal to the missing code. +! +! \exist-maximum Maximum that includes the following value to be treated +! as existing. Otherwise EnergyPlus will treat it as a missing +! value even though it does not equal to the missing code. +! +! \exist-minimum< Maximum that must be < than the following value to be treated +! as existing. Otherwise EnergyPlus will treat it as a missing +! value even though it does not equal to the missing code. +! +! ************************************************************************** + +\group Header + +LOCATION, + \memo The Location header record duplicates the information required for the + \memo Location Object. When only a Run Period object is used (i.e. a weather + \memo file), then the Location Object IS not needed. When a Run Period and + \memo Design Day objects are entered, then the Location on the weather file + \memo (as described previously) is used and overrides any Location Object + \memo entry. + \unique-object + \required-object + \min-fields 9 + A1, \field City + \type alpha + \required-field + A2, \field State Province + \type alpha + \required-field + A3, \field Country + \type alpha + \required-field + A4, \field Data Source + \type alpha + \required-field + A5, \field WMO Number + \note Usually a 6 digit field. Used as alpha in EnergyPlus + \type alpha + \required-field + N2, \field Latitude + \note + is North, - is South, degree minutes represented in decimal (i.e. 30 minutes is .5) + \units deg + \minimum -90.0 + \maximum +90.0 + \default 0.0 + \type real + \required-field + N3, \field Longitude + \note - is West, + is East, degree minutes represented in decimal (i.e. 30 minutes is .5) + \type real + \units deg + \minimum -180.0 + \maximum +180.0 + \default 0.0 + \required-field + N4, \field Time Zone + \note Time relative to GMT. + \units hour + \minimum -12.0 + \maximum +12.0 + \default 0.0 + \type real + \required-field + N5; \field Elevation + \units m + \minimum -1000.0 + \maximum< +9999.9 + \default 0.0 + \type real + \required-field + +DESIGN CONDITIONS, + \memo The Design Conditions header record encapsulates matching (using WMO# + \memo World Meteorological Organization Station Number) design conditions + \memo for a weather file location. Currently only those design conditions + \memo contained in the ASHRAE Handbook of Fundamentals 2009 are contained + \memo in the weather files. These conditions can be used as desired. In + \memo addition, Design Day definition files have been created of all World, + \memo Canada, and United States Design Conditions. These files are available + \memo in the DataSet folder of the EnergyPlus installation. + \unique-object + \required-object + \min-fields 1 + \extensible: 66 + N1, \field Number of Design Conditions + \type integer + \minimum 0 + \default 0 + \required-field + A1, \field Design Condition Source + \type alpha + \note Current sources are ASHRAE HOF 2009 US Design Conditions, Canadian Design Conditions + \note and World Design Conditions + A2, \field Seperator + \type alpha + \note An empty seperator. Not actual design condition data + A3, \field Condition 1 Heating Design Condition Type + \type choice + \key Heating + \default Heating + \begin-extensible + N2, \field Condition 1 Coldest Month + \type integer + \minimum 1 + \maximum 12 + N3, \field Condition 1 99.6% Heating Dry-Bulb Temperature + \note Dry-bulb temperature corresponding to 99.6% annual cumulative + \note frequency of occurrence (cold conditions) + \units C + \type real + N4, \field Condition 1 90.0% Heating Dry-Bulb Temperature + \note Dry-bulb temperature corresponding to 90.0% annual cumulative + \note frequency of occurrence (cold conditions) + \units C + \type real + N5, \field Condition 1 99.6% Heating Dew-point Temperature + \note Dew-point temperature corresponding to 99.6% annual cumulative + \note frequency of occurrence (cold conditions) + \units C + \type real + N6, \field Condition 1 Humidification Ratio for 99.6% Heating Dew-point Temperature + \note Humidity ratio, calculated at standard atmospheric pressure + \note at elevation of station, corresponding to + \note Dew-point temperature corresponding to 99.6% annual cumulative + \note frequency of occurrence (cold conditions) + \type real + \units gWater/kgDryAir + \minimum 0 + N7, \field Condition 1 Mean Coincident Dry-Bulb Temperature for 99.6% Heating Dew-point Temperature + \note Mean coincident Dry-Bulb temperature corresponding to + \note Dew-point temperature corresponding to 99.6% annual cumulative + \note frequency of occurrence (cold conditions) + \units C + \type real + N8, \field Condition 1 Heating Dew-point Temperature 90.0% + \note Dew-point temperature corresponding to 90.0% annual cumulative + \note frequency of occurrence (cold conditions) + \units C + \type real + N9, \field Condition 1 Humidification ratio for 90.0% Heating Dew-point Temperature + \note humidity ratio, calculated at standard atmospheric pressure + \note at elevation of station, corresponding to + \note Dew-point temperature corresponding to 90.0% annual cumulative + \note frequency of occurrence (cold conditions) + \type real + \units gWater/kgDryAir + \minimum 0 + N10, \field Condition 1 Mean Coincident Dry-Bulb Temperature for 90.0% Heating Dew-point Temperature + \note mean coincident Dry-Bulb temperature corresponding to + \note Dew-point temperature corresponding to 90.0% annual cumulative + \note frequency of occurrence (cold conditions) + \units C + \type real + N11, \field Condition 1 Heating Wind Speed 0.4% + \units m/s + \type real + \minimum 0 + N12, \field Condition 1 Mean Coincident Dry-Bulb Temperature for 0.4% Heating Wind Speed + \note Mean coincident dry-bulb temperature to wind speed corresponding to 0.4% cumulative frequency for coldest month + \units C + \type real + N13, \field Condition 1 Heating Wind Speed 1.0% + \note Wind speed corresponding to 1.0% cumulative frequency + \note of occurrence for coldest month; + \units m/s + \type real + \minimum 0 + N14, \field Condition 1 Mean Coincident Dry-Bulb Temperature for 1.0% Heating Wind Speed + \note Mean coincident dry-bulb temperature to wind speed corresponding to 1.0% cumulative frequency for coldest month + \units C + \type real + N15, \field Condition 1 Mean Coincident Wind Speed for 99.6% Heating Dry-Bulb Temperature + \note Mean wind speed coincident with 99.6% dry-bulb temperature + \units m/s + \type real + \minimum 0 + N16, \field Condition 1 Wind Most Frequent Wind Direction for 99.6 Heating Dry-Bulb Temperature + \note Most frequent wind direction corresponding to mean wind speed coincident with 99.6% dry-bulb temperature + \note degrees from north (east = 90 deg) + \units deg + \type real + \minimum -360 + \maximum +360 + A4, \field Condition 1 Cooling Design Condition Type + \type choice + \key Cooling + \default Cooling + N17, \field Condition 1 Hottest Month + \type integer + \minimum 1 + \maximum 12 + N18, \field Condition 1 Daily Temperature Range for Hottest Month + \note Daily temperature range for hottest month + \note [defined as mean of the difference between daily maximum + \note and daily minimum dry-bulb temperatures for hottest month] + \units C + \type real + \minimum 0 + N19, \field Condition 1 0.4% Cooling Dry-Bulb Temperature + \note Dry-bulb temperature corresponding to 0.4% annual cumulative frequency of occurrence (warm conditions) + \units C + \type real + N20, \field Condition 1 Mean Coincident Wet-Bulb Temperature for 0.4% Cooling Dry-Bulb Temperature + \note Mean coincident wet-bulb temperature to + \note Dry-bulb temperature corresponding to 0.4% annual cumulative frequency of occurrence (warm conditions) + \units C + \type real + N21, \field Condition 1 1.0% Cooling Dry-Bulb Temperature + \note Dry-bulb temperature corresponding to 1.0% annual cumulative frequency of occurrence (warm conditions) + \units C + \type real + N22, \field Condition 1 Mean Coincident Wet-Bulb Temperature for 1.0% Cooling Dry-Bulb Temperature + \note Mean coincident wet-bulb temperature to + \note Dry-bulb temperature corresponding to 1.0% annual cumulative frequency of occurrence (warm conditions) + \units C + \type real + N23, \field Condition 1 2.0% Cooling Dry-Bulb Temperature + \note Mean coincident wet-bulb temperature to + \note Dry-bulb temperature corresponding to 2.0% annual cumulative frequency of occurrence (warm conditions) + \units C + \type real + N24, \field Condition 1 Mean Coincident Wet-Bulb Temperature for 2.0% Cooling Dry-Bulb Temperature + \note mean coincident wet-bulb temperature to + \note Dry-bulb temperature corresponding to 2.0% annual cumulative frequency of occurrence (warm conditions) + \units C + \type real + N25, \field Condition 1 0.4% Cooling Wet-Bulb Temperature + \note Wet-bulb temperature corresponding to 0.4% annual cumulative frequency of occurrence + \units C + \type real + N26, \field Condition 1 Mean Coincident Dry-Bulb Temperature for 0.4% Cooling Wet-Bulb Temperature + \note Mean coincident dry-bulb temperature to + \note Wet-bulb temperature corresponding to 0.4% annual cumulative frequency of occurrence + \units C + \type real + N27, \field Condition 1 1.0% Cooling Wet-Bulb Temperature + \note Wet-bulb temperature corresponding to 1.0% annual cumulative frequency of occurrence + \units C + \type real + N28, \field Condition 1 Mean Coincident Dry-Bulb Temperature for 1.0% Cooling Wet-Bulb Temperature + \note Mean coincident dry-bulb temperature to + \note Wet-bulb temperature corresponding to 1.0% annual cumulative frequency of occurrence + \units C + \type real + N29, \field Condition 1 2.0% Cooling Wet-Bulb Temperature + \note Wet-bulb temperature corresponding to 2.0% annual cumulative frequency of occurrence + \units C + \type real + N30, \field Condition 1 Mean Coincident Dry-Bulb Temperature for 2.0% Cooling Wet-Bulb Temperature + \note mean coincident dry-bulb temperature to + \note Wet-bulb temperature corresponding to 2.0% annual cumulative frequency of occurrence + \units C + \type real + N31, \field Condition 1 Mean Coincident Wind Speed for 0.4% Cooling Dry-Bulb Temperature + \note Mean wind speed coincident with 0.4% dry-bulb temperature + \units m/s + \type real + \minimum 0 + N32, \field Condition 1 Most Frequent Wind Direction for 0.4% Cooling Dry-Bulb Temperature + \note Corresponding most frequent wind direction + \note Mean wind speed coincident with 0.4% dry-bulb temperature + \note degrees true from north (east = 90 deg) + \units deg + \type real + \minimum -360 + \maximum +360 + N33, \field Condition 1 Condition 1 0.4% Cooling Dew-point Temperature + \note Dew-point temperature corresponding to 0.4% annual cumulative frequency of occurrence + \units C + \type real + N34, \field Condition 1 Humidity Ratio for 0.4% Cooling Dew-point Temperature + \note Humidity ratio corresponding to + \note Dew-point temperature corresponding to 0.4% annual cumulative frequency of occurrence + \units + \type real + \units gWater/kgDryAir + \minimum 0 + N35, \field Condition 1 Mean Coincident Dry-Bulb Temperature for 0.4% Cooling Dew-point Temperature + \note Mean coincident dry-bulb temperature to + \note Dew-point temperature corresponding to 0.4% annual cumulative frequency of occurrence + \units C + \type real + N36, \field Condition 1 1.0% Cooling Dew-point Temperature + \note Dew-point temperature corresponding to 1.0% annual cumulative frequency of occurrence + \units C + \type real + N37, \field Condition 1 Humidity Ratio for 1.0% Cooling Dew-point Temperature + \note Humidity ratio corresponding to + \note Dew-point temperature corresponding to 1.0,% annual cumulative frequency of occurrence + \note calculated at the standard atmospheric pressure at elevation of station + \units + \type real + \units gWater/kgDryAir + \minimum 0 + N38, \field Condition 1 Mean Coincident Dry-Bulb Temperature for 1.0% Cooling Dew-point Temperature + \note Mean coincident dry-bulb temperature to + \note Dew-point temperature corresponding to 1.0% annual cumulative frequency of occurrence + \units C + \type real + N39, \field Condition 1 2.0% Cooling Dew-point Temperature + \note Dew-point temperature corresponding to 2.0% annual cumulative frequency of occurrence + \units C + \type real + N40, \field Condition 1 Humidity Ratio for 2.0% Cooling Dew-point Temperature + \note Humidity ratio corresponding to + \note Dew-point temperature corresponding to 2.0% annual cumulative frequency of occurrence + \note calculated at the standard atmospheric pressure at elevation of station + \units + \type real + \units gWater/kgDryAir + \minimum 0 + N41, \field Condition 1 Mean Coincident Dry-Bulb Temperature for 2.0% Cooling Dew-point Temperature + \note Mean coincident dry-bulb temperature to + \note Dew-point temperature corresponding to 2.0% annual cumulative frequency of occurrence + \units C + \type real + N42, \field Condition 1 0.4 Cooling Enthalpy + \note Enthalpy corresponding to 0.4% annual cumulative frequency of occurrence + \units kJ/kg + \type real + \minimum> 0 + N43, \field Condition 1 Mean Coincident Dry-Bulb Temperature for 0.4% Cooling Enthalpy + \note Mean coincident dry-bulb temperature to + \note Enthalpy corresponding to 0.4% annual cumulative frequency of occurrence + \units C + \type real + N44, \field Condition 1 1.0 Cooling Enthalpy + \note Enthalpy corresponding to 1.0% annual cumulative frequency of occurrence + \units kJ/kg + \type real + \minimum> 0 + N45, \field Condition 1 Mean Coincident Dry-Bulb Temperature for 1.0% Cooling Enthalpy + \note Mean coincident dry-bulb temperature to + \note Enthalpy corresponding to 1.0% annual cumulative frequency of occurrence + \units C + \type real + N46, \field Condition 1 2.0% Cooling Enthalpy + \note Mean coincident dry-bulb temperature to + \note Enthalpy corresponding to 2.0% annual cumulative frequency of occurrence + \units kJ/kg + \type real + \minimum> 0 + N47, \field Condition 1 Mean Coincident Dry-Bulb Temperature for 2.0% Cooling Enthalpy + \note mean coincident dry-bulb temperature to + \note Enthalpy corresponding to 2.0% annual cumulative frequency of occurrence + \units C + \type real + N48, \field Condition 1 Number of Hours (>= 8AM & <= 4PM) with Dry-Bulb Temperature in [12.8, 20.6] C + \note Number of hours between 8 AM and 4 PM (inclusive) with dry-bulb temperature between 12.8 and 20.6 C + \type real + \minimum 0 + A5, \field Condition 1 Extreme Design Condition Type + \type choice + \key Extremes + \default Extremes + N49, \field Condition 1 1.0% Extreme Wind Speed + \note Wind speed corresponding to 1.0% annual cumulative frequency of occurrence + \units m/s + \type real + \minimum 0 + N50, \field Condition 1 2.5% Extreme Wind Speed + \note Wind speed corresponding to 2.5% annual cumulative frequency of occurrence + \units m/s + \type real + \minimum 0 + N51, \field Condition 1 5.0% Extreme Wind Speed + \note Wind speed corresponding 5.0% annual cumulative frequency of occurrence + \units m/s + \type real + \minimum 0 + N52, \field Condition 1 Extreme Maximum Wet-Bulb Temperature + \units C + \type real + N53, \field Condition 1 Mean of Extreme Annual Minimum Dry-Bulb Temperature + \units C + \type real + N54, \field Condition 1 Mean of Extreme Annual Maximum Dry-Bulb Temperature + \units C + \type real + N55, \field Condition 1 Standard Deviation of Extreme Annual Minimum Dry-Bulb Temperature + \units C + \type real + \minimum 0 + N56, \field Condition 1 Standard Deviation of Extreme Annual Maximum Dry-Bulb Temperature + \units C + \type real + \minimum 0 + N57, \field Condition 1 5-Year Return Period Value for Minimum Extreme Dry-Bulb Temperature + \units C + \type real + N58, \field Condition 1 5-Year Return Period Value for Maximum Extreme Dry-Bulb Temperature + \units C + \type real + N59, \field Condition 1 10-Year Return Period Value for Minimum Extreme Dry-Bulb Temperature + \units C + \type real + N60, \field Condition 1 10-Year Return Period Value for Maximum Extreme Dry-Bulb Temperature + \units C + \type real + N61, \field Condition 1 20-Year Return Period Value for Minimum Extreme Dry-Bulb Temperature + \units C + \type real + N62, \field Condition 1 20-Year Return Period Value for Maximum Extreme Dry-Bulb Temperature + \units C + \type real + N63, \field Condition 1 50-Year Return Period Value for Minimum Extreme Dry-Bulb Temperature + \units C + \type real + N64; \field Condition 1 50-Year Return Period Value for Maximum Extreme Dry-Bulb Temperature + \units C + \type real + +TYPICAL/EXTREME PERIODS, + \memo Using a heuristic method, the weather converter can determine typical + \memo and extreme weather periods for full year weather files. These will + \memo then be shown on the Typical/Extreme Periods header record. These are + \memo also reported in the statistical report output from the Weather + \memo Converter. + \unique-object + \required-object + \min-fields 1 + \extensible: 4 + N1, \field Number of Typical/Extreme Periods + \type integer + \minimum 0 + \default 0 + \required-field + A1, \field Typical/Extreme Period 1 Name + \type alpha + \begin-extensible + A2, \field Typical/Extreme Period 1 Type + \type choice + \key Extreme + \key Typical + A3, \field Period 1 Start Day + \type alpha + A4; \field Period 1 End Day + \type alpha + +GROUND TEMPERATURES, + \memo The weather converter program can use a full year weather data file to + \memo calculate "undisturbed" ground temperatures based on temperatures. + \memo Since an important part of soil heat transfer includes soil properties + \memo such as conductivity, density and specific heat AND these cannot be + \memo calculated from simple weather observations, this header record is + \memo provided primarilyfor user information. However, with the FC + \memo construction option, these are automatically selected (0.5m depth) for + \memo use if the user does not include values in the + \memo Site:GroundTemperature:FcfactorMethod object. + \unique-object + \required-object + \min-fields 1 + \extensible: 16 + N1, \field Number of Ground Temperature Depths + \type integer + \minimum 0 + \required-field + N2, \field Depth 1 Ground Temperature + \type real + \units m + \minimum 0 + \begin-extensible + N3, \field Depth 1 Soil Conductivity + \type real + \units W/m-K, + \minimum> 0 + N4, \field Depth 1 Soil Density + \type real + \units kg/m3 + \minimum> 0 + N5, \field Depth 1 Soil Specific Heat + \type real + \units J/kg-K, + \minimum> 0 + N6, \field Depth 1 January Average Ground Temperature + \type real + \units C + N7, \field Depth 1 February Average Ground Temperature + \type real + \units C + N8, \field Depth 1 March Average Ground Temperature + \type real + \units C + N9, \field Depth 1 April Average Ground Temperature + \type real + \units C + N10, \field Depth 1 May Average Ground Temperature + \type real + \units C + N11, \field Depth 1 June Average Ground Temperature + \type real + \units C + N12, \field Depth 1 July Average Ground Temperature + \type real + \units C + N13, \field Depth 1 August Average Ground Temperature + \type real + \units C + N14, \field Depth 1 September Average Ground Temperature + \type real + \units C + N15, \field Depth 1 October Average Ground Temperature + \type real + \units C + N16, \field Depth 1 November Average Ground Temperature + \type real + \units C + N17; \field Depth 1 December Average Ground Temperature + \type real + \units C + +HOLIDAYS/DAYLIGHT SAVINGS, + \memo The Holidays/Daylight Saving header record details the start and end + \memo dates of Daylight Saving Time and other special days such as might be + \memo recorded for the weather file. These can be used by keying "Yes" for + \memo appropriate fields in the Run Period Object. + \memo Note: EnergyPlus processed weather files available on the EnergyPlus + \memo website: have neither special days specified nor daylight saving + \memo period. + \unique-object + \required-object + \min-fields 4 + \extensible: 2 + A1, \field LeapYear Observed + \note Yes if Leap Year will be observed for this file + \note No if Leap Year days (29 Feb) should be ignored in this file + \type choice + \key Yes + \key No + \default No + \required-field + A2, \field Daylight Saving Start Day + \type alpha + \default 0 + \required-field + A3, \field Daylight Saving End Day + \type alpha + \default 0 + \required-field + N1, \field Number of Holidays + \type integer + \minimum 0 + \default 0 + \required-field + A4, \field Holiday 1 Name + \type alpha + \begin-extensible + A5; \field Holiday 1 Day + \type alpha + +COMMENTS 1, + \memo The Comment header records may provide additional information about + \memo the weather data source or other information which may not fit in + \memo other header record formats. + \unique-object + \required-object + \extensible: 1 + A1; \field Comments + \type alpha + \begin-extensible + +COMMENTS 2, + \memo The Comment header records may provide additional information about + \memo the weather data source or other information which may not fit in + \memo other header record formats. + \unique-object + \required-object + \extensible: 1 + A1; \field Comments + \type alpha + \begin-extensible + +DATA PERIODS, + \memo A weather file may contain several "data periods" though this is not + \memo required (and, in fact, may be detrimental). In addition, a weather + \memo file may contain multiple records per hour BUT these must match the + \memo Number of Time Steps In Hour for the simulation. Multiple interval + \memo data files can be valued when you want to be sure of the weather + \memo values for each time step (rather than relying on "interpolated"" + \memo weather data). A weather file may also contain several consecutive + \memo years of weather data. EnergyPlus will automatically process the extra + \memo years when the Number of Years field is used in the RunPeriod object. + \memo Sorry - there is no way to jump into a year in the middle of the EPW + \memo file. Note that a Run Period object may not cross Data Period + \memo boundary lines. + \required-object + \unique-object + \min-fields 6 + \extensible: 4 + N1, \field Number of Data Periods + \type integer + \minimum 1 + \default 1 + \required-field + N2, \field Number of Records per Hour + \type integer + \minimum 1 + \default 1 + \required-field + A1, \field Data Period 1 Name/Description + \type alpha + \begin-extensible + \required-field + A2, \field Data Period 1 Start Day of Week + \type choice + \key Sunday + \key Monday + \key Tuesday + \key Wednesday + \key Thursday + \key Friday + \key Saturday + \required-field + A3, \field Data Period 1 Start Day + \type alpha + \required-field + A4; \field Data Period 1 End Day + \type alpha + \required-field + +\group Data + +WEATHER DATA, + \memo Core weather data + \min-fields: 35 + N1, \field Year + \type integer + \required-field + N2, \field Month + \type integer + \minimum 1 + \maximum 12 + \required-field + N3, \field Day + \type integer + \minimum 1 + \maximum 31 + \required-field + N4, \field Hour + \type integer + \minimum 1 + \maximum 24 + \required-field + N5, \field Minute + \type integer + \minimum 0 + \maximum 60 + \required-field + A1, \field Data Source + \type alpha + \note Initial day of weather file is checked by EnergyPlus for validity. + \note Each field is checked for "missing" as shown below. Reasonable + \note values, calculated values or the last "good" value is substituted. + \required-field + N6, \field Dry Bulb Temperature + \type real + \units C + \minimum> -90 + \maximum< 70 + \missing 99.9 + \default 6.0 + \exist-minimum> -Inf + \required-field + N7, \field Dew Point Temperature + \type real + \units C + \minimum> -90 + \maximum< 70 + \missing 99.9 + \default 3.0 + \exist-minimum> -Inf + \required-field + N8, \field Relative Humidity + \type real + \units % + \minimum 0 + \maximum 110 + \missing 999 + \default 50 + \required-field + N9, \field Atmospheric Pressure + \type real + \units Pa + \minimum> 31000 + \maximum 120000 + \missing 999999 + \exist-minimum 0 + \required-field + N10, \field Extraterrestrial Horizontal Radiation + \type real + \units Wh/m2 + \minimum 0 + \missing 9999 + \required-field + N11, \field Extraterrestrial Direct Normal Radiation + \type real + \units Wh/m2 + \minimum 0 + \missing 9999 + \required-field + N12, \field Horizontal Infrared Radiation Intensity from Sky + \type real + \units Wh/m2 + \minimum 0 + \missing 9999 + \required-field + N13, \field Global Horizontal Radiation + \type real + \units Wh/m2 + \minimum 0 + \missing 9999 + \required-field + N14, \field Direct Normal Radiation + \type real + \units Wh/m2 + \minimum 0 + \missing 9999 + \required-field + N15, \field Diffuse Horizontal Radiation + \type real + \units Wh/m2 + \minimum 0 + \missing 9999 + \required-field + N16, \field Global Horizontal Illuminance + \note will be missing if >= 999900 + \type real + \units lux + \minimum 0 + \maximum 999900 + \missing 999999 + \required-field + N17, \field Direct Normal Illuminance + \note will be missing if >= 999900 + \type real + \units lux + \minimum 0 + \maximum 999900 + \missing 999999 + \required-field + N18, \field Diffuse Horizontal Illuminance + \note will be missing if >= 999900 + \type real + \units lux + \minimum 0 + \maximum 999900 + \missing 999999 + \required-field + N19, \field Zenith Luminance + \note will be missing if >= 9999 + \type real + \units cd/m2 + \minimum 0 + \missing 9999 + \required-field + N20, \field Wind Direction + \type real + \units deg + \minimum 0 + \maximum 360 + \missing 999 + \default 180 + \exist-maximum 360 + \required-field + N21, \field Wind Speed + \type real + \units m/s + \minimum 0 + \maximum 40 + \missing 999 + \default 2.5 + \required-field + N22, \field Total Sky Cover + \type integer + \note This is the value for total sky cover (tenths of coverage). (i.e. + \note 1 is 1/10 covered. 10 is total coverage). (Amount of sky dome in + \note tenths covered by clouds or obscuring phenomena at the hour + \note indicated at the time indicated.) + \minimum 0 + \maximum 10 + \missing 99 + \default 5 + \required-field + N23, \field Opaque Sky Cover + \note This is the value for opaque sky cover (tenths of coverage). (i.e. + \note 1 is 1/10 covered. 10 is total coverage). (Amount of sky dome in + \note tenths covered by clouds or obscuring phenomena that prevent + \note observing the sky or higher cloud layers at the time indicated.) + \note This is not used unless the field for Horizontal Infrared + \note Radiation Intensity is missing and then it is used to calculate + \note Horizontal Infrared Radiation Intensity + \type integer + \minimum 0 + \maximum 10 + \missing 99 + \default 5 + \required-field + N24, \field Visibility + \note This is the value for visibility in km. (Horizontal visibility at + \note the time indicated.) + \type real + \units km + \minimum 0 + \missing 9999 + \default 777.7 + \required-field + N25, \field Ceiling Height + \note This is the value for ceiling height in m. + \note (77777 is unlimited ceiling height. 88888 is cirroform ceiling.) + \note It is not currently used in EnergyPlus calculations. + \type real + \units m + \minimum 0 + \missing 99999 + \default 77777 + \required-field + N26, \field Present Weather Observation + \note If the value of the field is 0, then the observed weather codes + \note are taken from the following field. + \note If the value of the field is 9, then "missing" weather is assumed. + \note Since the primary use of these fields (Present Weather Observation + \note and Present Weather Codes) is for rain/wet surfaces, a missing + \note observation field or a missing weather code implies "no rain". + \type integer + \minimum 0 + \maximum 9 + \missing 9 + \required-field + A2, \field Present Weather Codes + \type alpha + \missing 999999999 + \required-field + N27, \field Precipitable Water + \type real + \units mm + \minimum 0 + \missing 999 + \default 0 + \required-field + N28, \field Aerosol Optical Depth + \type real + \units thousandths + \minimum 0 + \missing 0.999 + \default 0 + \required-field + N29, \field Snow Depth + \type real + \units cm + \minimum 0 + \missing 999 + \required-field + N30, \field Days Since Last Snow + \type integer + \units day + \minimum 0 + \missing 99 + \default 88 + \required-field + N31, \field Albedo + \type real + \minimum 0 + \missing 999 + \default 0.0 + \required-field + N32, \field Liquid Precip Depth + \note Liquid Precipitation Depth + \type real + \units mm + \minimum 0 + \missing 999 + \default 0.0 + \required-field + N33; \field Liquid Precip Rate + \note Liquid Precipitation Rate + \type real + \units hour + \minimum 0 + \missing 99 + \required-field diff --git a/man/Epw.Rd b/man/Epw.Rd index 85fb5e621..a7d2736a9 100644 --- a/man/Epw.Rd +++ b/man/Epw.Rd @@ -101,6 +101,16 @@ epw$path() } +## ------------------------------------------------ +## Method `Epw$definition` +## ------------------------------------------------ + +\dontrun{ +# get path +epw$definition("LOCATION") +} + + ## ------------------------------------------------ ## Method `Epw$location` ## ------------------------------------------------ @@ -428,6 +438,7 @@ Hongyuan Jia \itemize{ \item \href{#method-new}{\code{Epw$new()}} \item \href{#method-path}{\code{Epw$path()}} +\item \href{#method-definition}{\code{Epw$definition()}} \item \href{#method-location}{\code{Epw$location()}} \item \href{#method-design_condition}{\code{Epw$design_condition()}} \item \href{#method-typical_extreme_period}{\code{Epw$typical_extreme_period()}} @@ -483,7 +494,7 @@ out-of-range data are found. Default: \code{TRUE}.} } \subsection{Details}{ It takes an EnergyPlus Weather File (EPW) as input and returns an -\code{EPW} object. +\code{Epw} object. } \subsection{Returns}{ @@ -545,6 +556,52 @@ epw$path() } +} +\if{html}{\out{
}} +\if{html}{\out{}} +\subsection{Method \code{definition()}}{ +Get the \link{IddObject} object for specified EPW class. +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{Epw$definition(class)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{class}}{A single string.} +} +\if{html}{\out{
}} +} +\subsection{Details}{ +\verb{$definition()} returns an \link{IddObject} of given EPW class. \link{IddObject} +contains all data used for parsing that EPW class. + +Currently, all supported EPW classes are: +\itemize{ +\item \code{LOCATION} +\item \verb{DESIGN CONDITIONS} +\item \verb{TYPICAL/EXTREME PERIODS} +\item \verb{GROUND TEMPERATURES} +\item \verb{HOLIDAYS/DAYLIGHT SAVINGS} +\item \verb{COMMENTS 1} +\item \verb{COMMENTS 2} +\item \verb{DATA PERIODS} +\item \verb{WEATHER DATA} +} +} + +\subsection{Examples}{ +\if{html}{\out{
}} +\preformatted{\dontrun{ +# get path +epw$definition("LOCATION") +} + +} +\if{html}{\out{
}} + +} + } \if{html}{\out{
}} \if{html}{\out{}} @@ -637,7 +694,7 @@ header in a list format with 4 elements: \item \code{source}: A string of source field \item \code{heating}: A list, usually of length 16, of the heading design conditions \item \code{cooling}: A list, usually of length 32, of the cooling design conditions -\item \code{extreme}: A list, usually of length 16, of the extreme design conditions +\item \code{extremes}: A list, usually of length 16, of the extreme design conditions } For the meaning of each element, please see ASHRAE Handbook of Fundamentals. @@ -706,20 +763,20 @@ Get GROUND TEMPERATURE header \subsection{Details}{ \verb{$ground_temperature()} returns the parsed values of \verb{GROUND TEMPERATURE} -header in a \link[data.table:data.table]{data.table} format with 7 columns: +header in a \link[data.table:data.table]{data.table} format with 17 columns: \itemize{ \item \code{index}: Integer type. The index of ground temperature record \item \code{depth}: Numeric type. The depth of the ground temperature is measured -\item \code{month}: Integer type. The month when the ground temperature is measured \item \code{soil_conductivity}: Numeric type. The soil conductivity at measured depth \item \code{soil_density}: Numeric type. The soil density at measured depth \item \verb{soil_specific heat}: Numeric type. The soil specific heat at measured depth -\item \code{temperature}: Numeric type. The measured group temperature +\item \code{January} to \code{December}: Numeric type. The measured group +temperature for each month. } } \subsection{Returns}{ -A \code{\link[data.table:data.table]{data.table::data.table()}} with 7 columns. +A \code{\link[data.table:data.table]{data.table::data.table()}} with 17 columns. } \subsection{Examples}{ \if{html}{\out{
}} @@ -991,7 +1048,7 @@ A \link[data.table:data.table]{data.table} with 5 columns: \itemize{ \item \code{index}: Integer type. The index of data period. \item \code{name}: Character type. The name of data period. -\item \code{start_day_of_week}: Integer type. The start day of week of data period. +\item \code{start_day_of_week}: Character type. The start day of week of data period. \item \code{start_day}: Date (EpwDate) type. The start day of data period. \item \code{end_day}: Date (EpwDate) type. The end day of data period. } @@ -1182,7 +1239,8 @@ Get weather data start_year = NULL, align_wday = TRUE, tz = "UTC", - update = FALSE + update = FALSE, + line = FALSE )}\if{html}{\out{
}} } @@ -1212,6 +1270,10 @@ All valid time zone names can be obtained using the newly created \code{datetime} column using \code{start_year}. If \code{FALSE}, original year data in the \code{Epw} object is kept. Default: \code{FALSE}.} + +\item{\code{line}}{If \code{TRUE}, a column named \code{line} is prepended indicating +the line numbers where data occur in the actual EPW file. +Default: \code{FALSE}.} } \if{html}{\out{}} } @@ -1293,8 +1355,8 @@ described above.} \item{\code{cols}}{A character vector identifying what data columns, i.e. all columns except \code{datetime}, \code{year}, \code{month}, \code{day}, \code{hour} -and \code{minute}, to search abnormal values. If \code{NULL}, all data -columns are used. Default: \code{NULL}.} +\code{minute}, and character columns, to search abnormal values. If +\code{NULL}, all data columns are used. Default: \code{NULL}.} \item{\code{keep_all}}{If \code{TRUE}, all columns are returned. If \code{FALSE}, only \code{line}, \code{datetime}, \code{year}, \code{month}, \code{day}, \code{hour} and @@ -1391,18 +1453,12 @@ epw$redundant_data() \subsection{Method \code{make_na()}}{ Convert abnormal data into NAs \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Epw$make_na(period = NULL, missing = FALSE, out_of_range = FALSE)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{Epw$make_na(missing = FALSE, out_of_range = FALSE)}\if{html}{\out{
}} } \subsection{Arguments}{ \if{html}{\out{
}} \describe{ -\item{\code{period}}{A positive integer vector identifying the data period -indexes. Data periods information can be obtained using -\href{../../eplusr/html/Epw.html#method-period}{\code{$period()}} -described above. If \code{NULL}, all data periods are included. -Default: \code{NULL}.} - \item{\code{missing}}{If \code{TRUE}, missing values are included. Default: \code{FALSE}.} @@ -1455,23 +1511,12 @@ summary(epw$data()$liquid_precip_rate) \subsection{Method \code{fill_abnormal()}}{ Fill abnormal data using prescribed pattern \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Epw$fill_abnormal( - period = NULL, - missing = FALSE, - out_of_range = FALSE, - special = FALSE -)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{Epw$fill_abnormal(missing = FALSE, out_of_range = FALSE, special = FALSE)}\if{html}{\out{
}} } \subsection{Arguments}{ \if{html}{\out{
}} \describe{ -\item{\code{period}}{A positive integer vector identifying the data period -indexes. Data periods information can be obtained using -\href{../../eplusr/html/Epw.html#method-period}{\code{$period()}} -described above. If \code{NULL}, all data periods are included. -Default: \code{NULL}.} - \item{\code{missing}}{If \code{TRUE}, missing values are included. Default: \code{FALSE}.} @@ -1719,7 +1764,7 @@ data. existing data periods. \item The date time of input data should not overlap with existing data periods. -\item Input data should have all 29 weather data columns with right +\item Input data should have all 29 weather data columns with correct types. The \code{year}, \code{month}, \code{day}, and \code{minute} column are not compulsory. They will be created according to values in the \code{datetime} column. Existing values will be overwritten. diff --git a/man/Idf.Rd b/man/Idf.Rd index d7118be0b..2fbd00985 100644 --- a/man/Idf.Rd +++ b/man/Idf.Rd @@ -3644,7 +3644,7 @@ possible new object IDs. Default: \code{FALSE}.} \subsection{Details}{ \verb{$to_table()} returns a \link[data.table:data.table]{data.table} that contains core data of specified objects. -The returned \link[data.table:data.table]{data.table} has 6 columns: +The returned \link[data.table:data.table]{data.table} has 5 columns: \itemize{ \item \code{id}: Integer type. Object IDs. \item \code{name}: Character type. Object names. diff --git a/man/expand_idf_dots_value.Rd b/man/expand_idf_dots_value.Rd index 2492df848..cbd78cd11 100644 --- a/man/expand_idf_dots_value.Rd +++ b/man/expand_idf_dots_value.Rd @@ -31,7 +31,14 @@ value, and reference.} with a valid class/object id/name. ID should be denoted in style \code{..ID}. There is a special element \code{.comment} in each list, which will be used as new comments of the object. If \code{.ref_assign} is \code{TRUE}, -\verb{:=} can be used to group multiple id/name wrapped by \code{.()} or \code{c()}.} +\verb{:=} can be used to group ids/names: +\itemize{ +\item When \code{.type} equals \code{"class"}, LHS multiple class indices/names should be +wrapped by \code{.()}, \code{c()}. +\item When \code{.type} equals \code{"object"}, LHS multiple object ids/names should be +wrapped by \code{.()} or \code{c()}. LHS \strong{SINGLE} class name should be +wrapped by \code{..()}. +}} \item{.type}{Should be either \code{"class"} or \code{"object"}. If \code{"class"}, id/name of each input will be treated as class index/name. If \code{"object"}, diff --git a/man/get_idf_table.Rd b/man/get_idf_table.Rd new file mode 100644 index 000000000..03c4bde19 --- /dev/null +++ b/man/get_idf_table.Rd @@ -0,0 +1,104 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/impl-idf.R +\name{get_idf_table} +\alias{get_idf_table} +\title{Extract value data in a data.table} +\usage{ +get_idf_table( + idd_env, + idf_env, + class = NULL, + object = NULL, + string_value = TRUE, + unit = FALSE, + wide = FALSE, + align = FALSE, + all = FALSE, + group_ext = c("none", "group", "index"), + force = FALSE, + init = FALSE +) +} +\arguments{ +\item{idd_env}{An environment or list contains IDD tables including class, +field, and reference.} + +\item{idf_env}{An environment or list contains IDF tables including object, +value, and reference.} + +\item{class}{An integer vector of valid class indexes or a character vector +of valid class names. Default: \code{NULL}.} + +\item{object}{An integer vector of valid object IDs or a character vector +of valid object names. Default: \code{NULL}.} + +\item{string_value}{If \code{TRUE}, all field values are returned as +character. If \code{FALSE}, \code{value} column in returned +\link[data.table:data.table]{data.table} is a list column with +each value stored as corresponding type. Note that if the +value of numeric field is set to \code{"Autosize"} or +\code{"Autocalculate"}, it is left as it is, leaving the returned +type being a string instead of a number. Default: \code{TRUE}.} + +\item{unit}{Only applicable when \code{string_value} is \code{FALSE}. If +\code{TRUE}, values of numeric fields are assigned with units using +\code{\link[units:set_units]{units::set_units()}} if applicable. Default: \code{FALSE}.} + +\item{wide}{Only applicable if target objects belong to a same class. +If \code{TRUE}, a wide table will be returned, i.e. first three +columns are always \code{id}, \code{name} and \code{class}, and then every +field in a separate column. Note that this requires all +objects specified must from the same class. +Default: \code{FALSE}.} + +\item{align}{If \code{TRUE}, all objects in the same class will have the +same field number. The number of fields is the same as the +object that have the most fields among objects specified. +Default: \code{FALSE}.} + +\item{all}{If \code{TRUE}, all available fields defined in IDD for the +class that objects belong to will be returned. Default: +\code{FALSE}.} + +\item{group_ext}{Should be one of \code{"none"}, \code{"group"} or \code{"index"}. +If not \code{"none"}, \code{value} column in returned +\code{\link[data.table:data.table]{data.table::data.table()}} will be converted into a list. +If \code{"group"}, values from extensible fields will be grouped by the +extensible group they belong to. For example, coordinate +values of each vertex in class \code{BuildingSurface:Detailed} will +be put into a list. If \code{"index"}, values from extensible fields +will be grouped by the extensible field indice they belong to. +For example, coordinate values of all x coordinates will be +put into a list. If \code{"none"}, nothing special will be done. +Default: \code{"none"}.} + +\item{force}{If \code{TRUE}, \code{wide} can be \code{TRUE} even though there are +multiple classes in input. This can result in a data.table +with lots of columns. But may be useful when you know that +target classes have the exact same fields, e.g. +\code{Ceiling:Adiabatic} and \code{Floor:Adiabatic}. Default: \code{FALSE}.} + +\item{init}{If \code{TRUE}, a table for new object input will be returned +with all values filled with defaults. In this case, \code{object} +input will be ignored. The \code{id} column will be filled with +possible new object IDs. Default: \code{FALSE}.} +} +\value{ +A \link[data.table:data.table]{data.table} with 6 columns (if +\code{wide} is \code{FALSE}) or at least 5 columns (if \code{wide} is \code{TRUE}). + +When \code{wide} is \code{FALSE}, the 5 columns are: +\itemize{ +\item \code{id}: Integer type. Object IDs. +\item \code{name}: Character type. Object names. +\item \code{class}: Character type. Current class name. +\item \code{index}: Integer type. Field indexes. +\item \code{field}: Character type. Field names. +\item \code{value}: Character type if \code{string_value} is \code{TRUE} or list type if +\code{string_value} is \code{FALSE} or \code{group_ext} is not \code{"none"}. Field values. +} +} +\description{ +Extract value data in a data.table +} +\keyword{internal} diff --git a/man/standardize_idf_value.Rd b/man/standardize_idf_value.Rd new file mode 100644 index 000000000..8976e378e --- /dev/null +++ b/man/standardize_idf_value.Rd @@ -0,0 +1,43 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/impl-idf.R +\name{standardize_idf_value} +\alias{standardize_idf_value} +\title{Standardize Value Data} +\usage{ +standardize_idf_value( + idd_env, + idf_env, + class = NULL, + object = NULL, + field = NULL, + type = c("choice", "reference") +) +} +\arguments{ +\item{idd_env}{An environment or list contains IDD tables including class, +field, and reference.} + +\item{idf_env}{An environment or list contains IDF tables including object, +value, and reference.} + +\item{class}{An integer vector of valid class indexes or a character vector +of valid class names. Default: \code{NULL}.} + +\item{object}{An integer vector of valid object IDs or a character vector +of valid object names. Default: \code{NULL}.} + +\item{field}{An integer vector of valid field indexes or a character +vector of valid field names (can be in in underscore style). \code{class} +and \code{field} should have the same length.} + +\item{type}{A character vector to specify what type of values to be +standardized. Should be a subset of \code{c("choice", "reference")}. +Default: \code{c("choice", "reference")}.} +} +\value{ +A data.table +} +\description{ +Standardize Value Data +} +\keyword{internal} diff --git a/man/validate_objects.Rd b/man/validate_objects.Rd new file mode 100644 index 000000000..9710bc767 --- /dev/null +++ b/man/validate_objects.Rd @@ -0,0 +1,72 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/validate.R +\name{validate_objects} +\alias{validate_objects} +\title{Validate input IDF data in terms of various aspects} +\usage{ +validate_objects( + 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 +) +} +\arguments{ +\item{idd_env}{An environment that contains IDD data} + +\item{idf_env}{An environment that contains IDF data} + +\item{dt_object}{A data.table that contains object data to validate. If +\code{NULL}, the object data from \code{idf_env} will be used, which means to +validate the whole IDF.} + +\item{dt_value}{A data.table that contains value data to validate. If +\code{NULL}, the value data from \code{idf_env} will be used, which means to +validate the whole IDF.} + +\item{required_object}{Whether to check if required objects are missing. This +will only be applied when checking the whole IDF.} + +\item{unique_object}{Whether to check if there are multiple instances of +unique object.} + +\item{unique_name}{Whether to check if there are objects having the same name +in same class.} + +\item{extensible}{Whether to check if there are incomplete extensible.} + +\item{required_field}{Whether to check if there are missing value for +required fields.} + +\item{auto_field}{Whether to check if there are non-autosizable or +non-autocalculatable fields that are assigned "autosize" or +"autocalculate".} + +\item{type}{Whether to check if there are input values whose type are not +consistent with definitions in IDD.} + +\item{choice}{Whether to check if there are invalid choice values.} + +\item{range}{Whether to check if there are numeric values that are out of +ranges specified in IDD.} + +\item{reference}{Whether to check if there are values that have invalid +references.} +} +\value{ +An IdfValidity object. +} +\description{ +Validate input IDF data in terms of various aspects +} +\keyword{internal} diff --git a/tests/testthat/test-assert.R b/tests/testthat/test-assert.R new file mode 100644 index 000000000..d8deab687 --- /dev/null +++ b/tests/testthat/test-assert.R @@ -0,0 +1,98 @@ +context("Assertions") + +test_that("list checking", { + expect_equal(convert_to_eplus_ver(8), numeric_version("8.0.0")) + expect_equal(convert_to_eplus_ver(c(8, 8.1), max = TRUE), numeric_version(c("8.0.0", "8.1.0"))) + + expect_equal(convert_to_idd_ver(8), numeric_version("8.0.0")) + expect_equal(convert_to_idd_ver(c(8, 8.1), max = TRUE), numeric_version(c("8.0.0", "8.1.0"))) + + expect_false(is_eplus_ver("a")) + expect_true(is_eplus_ver(8)) + expect_true(is_eplus_ver(8.5)) + expect_true(is_eplus_ver("latest")) + expect_false(is_eplus_ver("latest", strict = TRUE)) + expect_false(is_eplus_ver("8.8.8")) + + expect_false(is_idd_ver("a")) + expect_true(is_idd_ver(8)) + expect_true(is_idd_ver(8.5)) + expect_true(is_idd_ver("latest")) + expect_false(is_idd_ver("latest", strict = TRUE)) + expect_false(is_idd_ver("8.8.8")) + + expect_false(is_eplus_path(tempfile())) + expect_true({ + file.create(file.path(tempdir(), "Energy+.idd")) + file.create(file.path(tempdir(), "energyplus")) + file.create(file.path(tempdir(), "energyplus.exe")) + is_eplus_path(tempdir()) + }) + + expect_false(is_idd(1)) + expect_true(is_idd(use_idd(8.8))) + + expect_false(is_idf(1)) + expect_true(is_idf(read_idf(example()))) + + expect_false(is_iddobject(1)) + expect_true(is_iddobject(use_idd(8.8)$Version)) + + expect_false(is_idfobject(1)) + expect_true(is_idfobject(read_idf(example())$Version)) + + expect_false(is_epw(1)) + + expect_true(is_rdd(structure(data.table(), class = "RddFile"))) + expect_true(is_mdd(structure(data.table(), class = "MddFile"))) + + expect_true(is_range(ranger())) + + expect_error(assert_strint(1)) + expect_error(assert_strint("a")) + expect_equal(assert_strint("1"), "1") + expect_equal(assert_strint("1", coerce = TRUE), 1L) + + expect_true(has_len(1:2, 2)) + expect_true(has_len(1:2, ranger(0))) + expect_true(has_len(1:2, c(1,2))) + expect_true(has_len(1:2, 1, 1)) + expect_false(has_len(1:2, 3)) + expect_false(has_len(1:2, c(0,4))) + expect_false(has_len(1:2, 1, 2)) + expect_true(have_same_len(1:2, 3:4)) + expect_true(have_same_len(mtcars, seq_len(nrow(mtcars)))) + expect_false(have_same_len(1, 1:2)) + + expect_true(in_range(1, ranger(1, TRUE, 2, FALSE))) + expect_false(in_range(1, ranger(1, FALSE, 2, FALSE))) + + expect_true(is_named(list(a = 1))) + expect_false(is_named(list(1))) + + expect_true(is_choice("yes", c("Yes", "no"))) + expect_true(is_choice("yes", c("Yes", "no"))) + + expect_true(has_name(c(a = 1), "a")) + expect_false(has_name(c(a = 1), "b")) + expect_true(has_name(c(a = 1, b = 2), "a")) + expect_false(has_name(c(a = 1, b = 2), c("b", "c"))) + + expect_true(has_ext(tempfile(fileext = ".idf"), "idf")) + expect_false(has_ext(tempfile(fileext = ".idf"), "epw")) + + expect_true(has_ext(tempfile(fileext = ".idf"), c("idf", "imf"))) + expect_false(has_ext(tempfile(fileext = ".idf"), c("epw", "imf"))) + + expect_true(is_epwdate(epw_date(1))) + expect_false(is_epwdate(epw_date(-1))) + + expect_true(are_epwdate(epw_date(0:5))) + expect_false(are_epwdate(epw_date(-1:5))) + + expect_true(assert(8 > 5, 2 > 1)) + expect_is(tryCatch(assert(is_scalar(1:2)), error = identity), "error_not_scalar") + expect_error(assert(is_scalar(1:2)), class = "error_not_scalar") + expect_error(assert(is_scalar(1:2), msg = "a"), "a", class = "error_not_scalar") + expect_error(assert(is_scalar(1:2), prefix = "input"), "input is not a scalar", class = "error_not_scalar") +}) diff --git a/tests/testthat/test-epw.R b/tests/testthat/test-epw.R new file mode 100644 index 000000000..f1ecd53af --- /dev/null +++ b/tests/testthat/test-epw.R @@ -0,0 +1,492 @@ +context("Epw Class") + +eplusr_option(verbose_info = FALSE) + +# IDD {{{ +test_that("IDD", { + expect_is(idd <- EpwIdd$new(system.file("extdata/epw.idd", package = "eplusr")), "Idd") + expect_output(idd$print()) +}) +# }}} + +# META {{{ +test_that("Meta info", { + skip_on_cran() + if (!is_avail_eplus(8.8)) install_eplus(8.8) + path_epw <- file.path(eplus_config(8.8)$dir, "WeatherData", "USA_CA_San.Francisco.Intl.AP.724940_TMY3.epw") + + expect_is(epw <- read_epw(path_epw), "Epw") + + # can update the path after saved + expect_equal(epw$path(), normalizePath(path_epw)) + + # can get definition + expect_is(epw$definition("LOCATION"), "IddObject") +}) +# }}} + +# HEADER {{{ +test_that("Header getter and setter", { + skip_on_cran() + if (!is_avail_eplus(8.8)) install_eplus(8.8) + path_epw <- file.path(eplus_config(8.8)$dir, "WeatherData", "USA_CA_San.Francisco.Intl.AP.724940_TMY3.epw") + + expect_silent(epw <- read_epw(path_epw)) + + # $location() {{{ + expect_equal( + epw$location(city = "Chongqing", state_province = "Chongqing", country = "China", + data_source = "TMY", wmo_number = "724944", latitude = 20.0, + longitude = -120.0, time_zone = 8L, elevation = 100 + ), + list(city = "Chongqing", + state_province = "Chongqing", + country = "China", + data_source = "TMY", + wmo_number = "724944", + latitude = 20.0, + longitude = -120.0, + time_zone = 8L, + elevation = 100 + ) + ) + expect_equal(epw$location(city = "chongqing")$city, "chongqing") + expect_error(epw$location(city = 1)) + # }}} + + # $design_condition() {{{ + expect_is(epw$design_condition(), "list") + expect_equal(names(epw$design_condition()), c("source", "heating", "cooling", "extremes")) + # }}} + + # $typical_extreme_period() {{{ + expect_is(epw$typical_extreme_period(), "data.table") + expect_equal(names(epw$typical_extreme_period()), c("index", "name", "type", "start_day", "end_day")) + expect_equal(nrow(epw$typical_extreme_period()), 6L) + # }}} + + # $ground_temperature {{{ + expect_is(epw$ground_temperature(), "data.table") + expect_equal(names(epw$ground_temperature()), c( + "index", "depth", + "soil_conductivity", "soil_density", "soil_specific_heat", + "January", "February", "March", + "April", "May", "June", + "July", "August", "September", + "October", "November", "December" + )) + expect_equal(nrow(epw$ground_temperature()), 3L) + # }}} + + # $ground_temperature {{{ + expect_is(epw$ground_temperature(), "data.table") + expect_equal(names(epw$ground_temperature()), c( + "index", "depth", + "soil_conductivity", "soil_density", "soil_specific_heat", + "January", "February", "March", + "April", "May", "June", + "July", "August", "September", + "October", "November", "December" + )) + expect_equal(nrow(epw$ground_temperature()), 3L) + # }}} + + # $holiday {{{ + expect_silent(epw <- read_epw(path_epw)) + expect_is(epw$holiday(), "list") + expect_equal(names(epw$holiday()), c("leapyear", "dst", "holiday")) + + # leapyear + expect_is(epw <- read_epw(path_epw), "Epw") + expect_equal(epw$holiday()$leapyear, FALSE) + expect_error(epw$holiday(TRUE), class = "eplusr_error_epw_header") + + # change to leapyear + expect_is(epw <- read_epw(path_epw), "Epw") + expect_warning(d <- epw$data(1, start_year = 2016, align_wday = FALSE)) + feb29 <- d[month == 2 & day == 28][, day := 29L] + d <- rbindlist(list(d, feb29))[order(month, day)] + get_priv_env(epw)$idf_env()$value[object_id == 5, value_chr := {value_chr[1] <- "Yes";value_chr}] + epw$.__enclos_env__$private$m_data <- d + expect_true(epw$holiday()$leapyear) + expect_error(epw$holiday(FALSE)) + + # dst + expect_is(epw <- read_epw(path_epw), "Epw") + expect_equal(epw$holiday(dst = c(1, 2))$dst, epw_date(1:2)) + expect_equal(epw$holiday(dst = c(as.Date("2008-01-01"), as.Date("2008-02-01")))$dst, epw_date(c("Jan 01", "Feb 01"))) + + # holiday + expect_is(epw <- read_epw(path_epw), "Epw") + expect_is(hol <- epw$holiday(holiday = list(name = "New Year", day = "Jan 01")), "list") + expect_equal(hol$holiday, + data.table(index = 1L, name = "New Year", day = epw_date("1/1")) + ) + + # can restore the original data + expect_error(epw$holiday(holiday = list(name = "New Year", day = "Jan 41"))) + expect_is(hol <- epw$holiday(), "list") + expect_equal(hol$holiday, + data.table(index = 1L, name = "New Year", day = epw_date("1/1")) + ) + # }}} + + # $comment() {{{ + expect_is(epw$comment1(), "character") + expect_equal(epw$comment1("comment1"), "comment1") + expect_equal(epw$comment1(), "comment1") + expect_is(epw$comment2(), "character") + expect_equal(epw$comment2("comment2"), "comment2") + expect_equal(epw$comment2(), "comment2") + # }}} + + # $num_period {{{ + expect_equal(epw$num_period(), 1L) + # }}} + + # $interval {{{ + expect_equal(epw$interval(), 1L) + # }}} + + # $period {{{ + expect_is(epw$period(), "data.table") + expect_is(epw$period(1), "data.table") + expect_error(epw$period(2), class = "eplusr_error_epw_data_period_index") + expect_equal(epw$period(1, name = "test")$name, "test") + expect_error(epw$period(1, start_day_of_week = "test"), class = "eplusr_error_validity_check") + expect_equal(epw$period(1, start_day_of_week = 3)$start_day_of_week, "Wednesday") + expect_equal(epw$period(1, start_day_of_week = "Wed")$start_day_of_week, "Wednesday") + + expect_error(epw$period(1, start_day_of_week = "NoDay")) + expect_equal(epw$period(1)$start_day_of_week, "Wednesday") + # }}} +}) +# }}} + +# CONSTANTS {{{ +test_that("Constant data", { + skip_on_cran() + if (!is_avail_eplus(8.8)) install_eplus(8.8) + path_epw <- file.path(eplus_config(8.8)$dir, "WeatherData", "USA_CA_San.Francisco.Intl.AP.724940_TMY3.epw") + + expect_silent(epw <- read_epw(path_epw)) + + expect_is(epw$missing_code(), "list") + expect_equal(length(epw$missing_code()), 29L) + expect_is(epw$initial_missing_value(), "list") + expect_equal(length(epw$initial_missing_value()), 14L) + expect_is(epw$range_exist(), "list") + expect_equal(length(epw$range_exist()), 28L) + expect_is(epw$range_valid(), "list") + expect_equal(length(epw$range_valid()), 28L) + expect_is(epw$fill_action(), "list") + expect_equal(names(epw$fill_action()), c("use_previous", "use_zero")) +}) +# }}} + +# SAVE {{{ +test_that("$save() & $is_unsaved()", { + skip_on_cran() + if (!is_avail_eplus(8.8)) install_eplus(8.8) + path_epw <- file.path(eplus_config(8.8)$dir, "WeatherData", "USA_CA_San.Francisco.Intl.AP.724940_TMY3.epw") + + expect_is(epw <- read_epw(path_epw), "Epw") + expect_is(d_ori <- epw$data(), "data.table") + + # $is_unsaved() {{{ + expect_false(epw$is_unsaved()) + # }}} + + # $save() {{{ + expect_error(epw$save(".idf")) + unlink(file.path(tempdir(), "test_save.epw"), force = TRUE) + expect_is(epw$save(file.path(tempdir(), "test_save.epw")), "character") + expect_error(epw$save(file.path(tempdir(), "test_save.epw")), class = "eplusr_error") + expect_is(epw$save(overwrite = TRUE), "character") + expect_is(epw1 <- read_epw(file.path(tempdir(), "test_save.epw")), "Epw") + expect_equal(epw1$data(), d_ori) + # }}} +}) +# }}} + +# DATA GETTER {{{ +test_that("Data Getter", { + skip_on_cran() + if (!is_avail_eplus(8.8)) install_eplus(8.8) + path_epw <- file.path(eplus_config(8.8)$dir, "WeatherData", "USA_CA_San.Francisco.Intl.AP.724940_TMY3.epw") + + expect_is(epw <- read_epw(path_epw), "Epw") + + # $data() {{{ + # can get weather data + expect_error(epw$data(2), class = "eplusr_error_epw_data_period_index") + expect_equal(ncol(epw$data()), 36L) + expect_equal(nrow(epw$data()), 8760L) + + # can use the origial datetime + expect_equal(year(epw$data(align_wday = FALSE)$datetime[8760]), 1998) + + # can change year in datetime column + expect_equal( + epw$data(start_year = 2018, tz = "GMT")$datetime, + seq(as.POSIXct("2018-01-01 01:00:00", tz = "GMT"), + as.POSIXct("2019-01-01 00:00:00", tz = "GMT"), + by = "1 hour" + ) + ) + # can change the year column + expect_equal(epw$data(start_year = 2018, update = TRUE)$year, c(rep(2018L, times = 8759), 2019L)) + + # can detect if leap year mismatch found + expect_warning(epw$data(start_year = 2016)) + expect_warning(epw$data(start_year = 2016, align_wday = FALSE)) + + # can change the time zone of datetime column in the returned weather data + expect_error(attr(epw$data(tz = "America/Chicago")$datetime, "tzone"), class = "eplusr_error_epw_data") + expect_equal(attr(epw$data(start_year = 2019, tz = "Etc/GMT+8")$datetime, "tzone"), "Etc/GMT+8") + # }}} + + # $abnormal_data() {{{ + expect_equal(nrow(epw$abnormal_data()), 8760) + expect_equal(nrow(epw$abnormal_data(type = "missing")), 8760) + expect_equal(nrow(epw$abnormal_data(type = "out_of_range")), 0L) + expect_true("line" %in% names(epw$abnormal_data())) + expect_equal(ncol(epw$abnormal_data()), 37L) + expect_equal(nrow(epw$abnormal_data(cols = "albedo")), 2160L) + expect_equal(ncol(epw$abnormal_data(cols = "albedo", keep_all = FALSE)), 8L) + expect_equal(nrow(epw$abnormal_data(cols = "albedo", type = "out_of_range")), 0L) + # }}} + + # $redudant_data() {{{ + expect_equal(nrow(epw$redundant_data()), 0L) + # }}} +}) +# }}} + +# DATA TAGGER {{{ +test_that("Data Tagger", { + skip_on_cran() + if (!is_avail_eplus(8.8)) install_eplus(8.8) + path_epw <- file.path(eplus_config(8.8)$dir, "WeatherData", "USA_CA_San.Francisco.Intl.AP.724940_TMY3.epw") + + expect_is(epw <- read_epw(path_epw), "Epw") + + # $make_na() {{{ + expect_true({ + epw$make_na(missing = TRUE, out_of_range = TRUE) + all(is.na(epw$abnormal_data(cols = "albedo", keep_all = FALSE, type = "missing")$albedo)) + }) + expect_message(with_option(list(verbose_info = TRUE), epw$make_na(missing = TRUE, out_of_range = TRUE)), "already") + # }}} + + # $fill_abnormal() {{{ + expect_equal( + { + epw$fill_abnormal(missing = TRUE, out_of_range = TRUE, special = TRUE) + epw$abnormal_data(cols = "albedo", keep_all = FALSE, type = "missing")$albedo + }, rep(999, 2160) + ) + expect_message(with_option(list(verbose_info = TRUE), epw$fill_abnormal(missing = TRUE, out_of_range = TRUE)), "already") + # }}} + + # $add_unit() & $drop_unit() {{{ + expect_is(class = "units", + { + epw$add_unit() + rad <- epw$data()$direct_normal_radiation + } + ) + expect_equal(units(rad)$numerator, c("h", "W")) + expect_equal(units(rad)$denominator, c("m", "m")) + expect_message(with_option(list(verbose_info = TRUE), epw$add_unit()), "already") + + expect_is(epw$drop_unit()$data()$dry_bulb_temperature, "numeric") + expect_message(with_option(list(verbose_info = TRUE), epw$drop_unit()), "already") + # }}} + + # $purge() {{{ + expect_is(epw <- read_epw(path_epw), "Epw") + expect_is(epw$purge(), "Epw") + epw$.__enclos_env__$private$m_data <- rbindlist(list(get_priv_env(epw)$m_data, epw$data())) + expect_message(with_option(list(verbose_info = TRUE), epw$purge())) + # }}} +}) +# }}} + +# DATA SETTER {{{ +test_that("Data Setter", { + skip_on_cran() + if (!is_avail_eplus(8.8)) install_eplus(8.8) + path_epw <- file.path(eplus_config(8.8)$dir, "WeatherData", "USA_CA_San.Francisco.Intl.AP.724940_TMY3.epw") + + expect_is(epw <- read_epw(path_epw), "Epw") + + # $set() {{{ + expect_is(d <- epw$data(), "data.table") + expect_message(with_option(list(verbose_info = TRUE), epw$set(d, realyear = TRUE))) + expect_equal(epw$period(), + data.table(index = 1L, name = "Data", start_day_of_week = "Sunday", + start_day = epw_date("2017/1/1"), end_day = epw_date("2017/12/31") + ) + ) + + expect_warning(epw$set(d, realyear = TRUE, start_day_of_week = "Monday")) + expect_warning(epw$set(d, realyear = TRUE)) + expect_equal(epw$period()$start_day_of_week, "Sunday") + + expect_is(epw$set(d[1:48]), "Epw") + expect_equal(epw$period(), + data.table(index = 1L, name = "Data", start_day_of_week = "Sunday", + start_day = epw_date("1/1", F), end_day = epw_date("1/2", F) + ) + ) + expect_equal(nrow(epw$data()), 48L) + # }}} + + # $add() {{{ + expect_is(epw <- read_epw(path_epw), "Epw") + + expect_error(epw$add(epw$data()), class = "eplusr_error_parse_epw") + + # after 0L + expect_message(with_option(list(verbose_info = TRUE), epw$add(epw$data(start_year = 2017), realyear = TRUE))) + expect_equal(epw$period()$name, c("Data1", "Data")) + expect_equal(lubridate::year(epw$data(1, align_wday = FALSE)$datetime[1]), 2017) + expect_equal(get_priv_env(epw)$m_log$matched, + data.table(index = 1:2, row = c(1L, 8761L), num = rep(8760L, 2)) + ) + + # after N + expect_warning(d <- epw$data(start_year = 2014, align_wday = FALSE)) + expect_is(epw$add(d, after = 10, realyear = TRUE), "Epw") + expect_equal(epw$period()$name, c("Data1", "Data", "Data2")) + expect_equal(lubridate::year(epw$data(3, align_wday = FALSE)$datetime[1]), 2014) + expect_equal(get_priv_env(epw)$m_log$matched, + data.table(index = 1:3, row = c(1L, 8761L, 17521L), num = rep(8760L, 3)) + ) + + # between + expect_warning(d <- epw$data(1, start_year = 2013, align_wday = FALSE)) + expect_is(epw$add(d, after = 2, realyear = TRUE), "Epw") + expect_equal(lubridate::year(epw$data(3, align_wday = FALSE)$datetime[1]), 2013) + expect_equal(get_priv_env(epw)$m_log$matched, + data.table(index = 1:4, row = c(1L, 8761L, 17521L, 26281L), num = rep(8760L, 4)) + ) + + # unit + no unit + expect_is(epw <- read_epw(path_epw), "Epw") + expect_is(d <- epw$data(start_year = 2017), "data.table") + expect_is(epw$add_unit(), "Epw") + expect_is(epw$add(d, realyear = TRUE), "Epw") + expect_warning(u <- units(epw$data()$liquid_precip_rate)$numerator) + expect_equal(u, "h") + + # unit + unit + expect_is(epw <- read_epw(path_epw), "Epw") + expect_is(epw$add_unit(), "Epw") + expect_is(d <- epw$data(start_year = 2017), "data.table") + expect_is(epw$add(d, realyear = TRUE), "Epw") + expect_warning(u <- units(epw$data()$liquid_precip_rate)$numerator) + expect_equal(u, "h") + + # no unit + unit + expect_is(epw <- read_epw(path_epw), "Epw") + expect_is(epw$add_unit(), "Epw") + expect_is(d <- epw$data(start_year = 2017), "data.table") + expect_is(epw$drop_unit(), "Epw") + expect_is(epw$add(d, realyear = TRUE), "Epw") + expect_warning(u <- epw$data()$liquid_precip_rate) + expect_is(u, "numeric") + + # no na + na + expect_is(epw <- read_epw(path_epw), "Epw") + expect_is(epw$make_na(TRUE, TRUE), "Epw") + expect_is(d <- epw$data(start_year = 2017), "data.table") + expect_is(epw$fill_abnormal(TRUE, TRUE), "Epw") + expect_is(epw$add(d, realyear = TRUE), "Epw") + expect_true(all(!is.na(epw$abnormal_data(cols = "albedo", keep_all = FALSE, type = "missing")$albedo))) + + # na + no na + expect_is(epw <- read_epw(path_epw), "Epw") + expect_is(d <- epw$data(start_year = 2017), "data.table") + expect_is(epw$make_na(TRUE, TRUE), "Epw") + expect_is(epw$add(d, realyear = TRUE), "Epw") + expect_true(all(is.na(epw$abnormal_data(cols = "albedo", keep_all = FALSE, type = "missing")$albedo))) + # }}} + + # $del() {{{ + expect_is(epw <- read_epw(path_epw), "Epw") + + expect_error(epw$del()) + expect_error(epw$del(1)) + + expect_is(epw$add(epw$data(start_year = 2017), realyear = TRUE), "Epw") + expect_message(with_option(list(verbose_info = TRUE), epw$del(1))) + # }}} +}) +# }}} + +# CLONE {{{ +test_that("$clone()", { + path_epw <- file.path(eplus_config(8.8)$dir, "WeatherData", "USA_CA_San.Francisco.Intl.AP.724940_TMY3.epw") + expect_is(epw1 <- read_epw(path_epw), "Epw") + + epw2 <- epw1$clone() + epw2$period(1, name = "Data2") + expect_equal(epw1$period()$name, "Data") + expect_equal(epw2$period()$name, "Data2") +}) +# }}} + +# PRINT {{{ +test_that("$print()", { + skip_on_cran() + if (!is_avail_eplus(8.8)) install_eplus(8.8) + path_epw <- file.path(eplus_config(8.8)$dir, "WeatherData", "USA_CA_San.Francisco.Intl.AP.724940_TMY3.epw") + + expect_silent(epw <- read_epw(path_epw)) + + # $print() {{{ + expect_output(epw$print()) + # }}} +}) +# }}} + +# S3 FORMAT {{{ +test_that("str.Epw & format.Epw", { + skip_on_cran() + if (!is_avail_eplus(8.8)) install_eplus(8.8) + path_epw <- file.path(eplus_config(8.8)$dir, "WeatherData", "USA_CA_San.Francisco.Intl.AP.724940_TMY3.epw") + + expect_silent(epw <- read_epw(path_epw)) + expect_output(str(epw)) + expect_is(format(epw), "character") +}) +# }}} + +# S3 EQUALITY {{{ +test_that("==.Epw & !=.Epw", { + skip_on_cran() + if (!is_avail_eplus(8.8)) install_eplus(8.8) + path_epw <- file.path(eplus_config(8.8)$dir, "WeatherData", "USA_CA_San.Francisco.Intl.AP.724940_TMY3.epw") + + expect_silent(epw <- read_epw(path_epw)) + + expect_true(epw == epw) + expect_false(epw == read_epw(path_epw)) + expect_false(epw == 1) + expect_false(epw != epw) + expect_true(epw != read_epw(path_epw)) +}) +# }}} + +# DOWNLOAD_WEATHER {{{ +test_that("download_weather()", { + skip_on_cran() + + # download weather + expect_message({path_epw <- with_option(list(verbose_info = TRUE), + download_weather("USA_CA_San.Francisco.Intl.AP.724940_TMY3", ask = FALSE, type = "epw", dir = tempdir()))} + ) +}) +# }}} diff --git a/tests/testthat/test-format.R b/tests/testthat/test-format.R new file mode 100644 index 000000000..26f649cde --- /dev/null +++ b/tests/testthat/test-format.R @@ -0,0 +1,435 @@ +context("Format methods") + +test_that("Idd formatting", { + # only test on UTF-8 supported platform + skip_if_not(cli::is_utf8_output()) + + # IDD {{{ + idd_parsed <- parse_idd_file(text("idd", "9.9.9")) + + expect_equal(format_name(idd_parsed$field), + c("!- Test Field", + "!- Test Character Field 1", + "!- Test Numeric Field 1 {m}", + "!- Test Numeric Field 2", + "!- Test Character Field 2" + ) + ) + + expect_equal(format_index(idd_parsed$field), as.character(c(1, 1:4))) + + expect_equal(format_index(idd_parsed$field, required = TRUE), + c("1 ", "1*", "2 ", "3 ", "4 ") + ) + + expect_equal(format_field(idd_parsed$field, leading = 2), + c(" !- Test Field", + " !- Test Character Field 1", + " !- Test Numeric Field 1 {m}", + " !- Test Numeric Field 2", + " !- Test Character Field 2" + ) + ) + + expect_equal(format_field(idd_parsed$field, leading = 2, prefix = FALSE), + c(" Test Field", + " Test Character Field 1", + " Test Numeric Field 1 {m}", + " Test Numeric Field 2", + " Test Character Field 2" + ) + ) + expect_equal(format_objects(idd_parsed$group, component = "group")$out, + c("Group: ", "Group: ") + ) + expect_error(format_objects(idd_parsed$group, component = c("group", "class"))$out) + expect_equal(format_objects(idd_parsed$class, component = "class")$out, + c("Class: ", "Class: ") + ) + expect_equal( + format_objects(idd_parsed$group[idd_parsed$class, on = "group_id"], + component = c("group", "class"), brief = TRUE)$out, + c("[1] Group: ", "[1] Group: ") + ) + expect_equal( + format_objects(idd_parsed$group[idd_parsed$class, on = "group_id"], + component = c("group", "class"), brief = FALSE)$out, + list( + c("Group: ", "└─ Class: ", ""), + c("Group: ", "└─ Class: ", "") + ) + ) + expect_equal(format_objects(idd_parsed$field, component = "field")$out, + c("Field: <1: Test Field>", + "Field: <1: Test Character Field 1>", + "Field: <2: Test Numeric Field 1 {m}>", + "Field: <3: Test Numeric Field 2>", + "Field: <4: Test Character Field 2>" + ) + ) + expect_equal( + format_objects( + idd_parsed$class[, .(group_id, class_id, class_name)][ + idd_parsed$field[, .(class_id, field_id, field_index, field_name, units, ip_units)], on = "class_id"], + c("class", "field"), brief = FALSE)$out, + list( + c("Class: ", + "└─ Field: <1: Test Field>", "" + ), + c("Class: ", + "├─ Field: <1: Test Character Field 1>", + "│─ Field: <2: Test Numeric Field 1 {m}>", + "│─ Field: <3: Test Numeric Field 2>", + "└─ Field: <4: Test Character Field 2>", + "" + ) + ) + ) + expect_equal( + format_objects( + idd_parsed$group[ + idd_parsed$class[, .(group_id, class_id, class_name)], on = "group_id"][ + idd_parsed$field[, .(class_id, field_id, field_index, field_name, units, ip_units)], on = "class_id"], + c("group", "class", "field"))$out, + list( + c("Group: ", + "└─ [1] Class: ", + "" + ), + c("Group: ", + "└─ [4] Class: ", + "" + ) + ) + ) + expect_equal( + format_objects( + idd_parsed$group[ + idd_parsed$class[, .(group_id, class_id, class_name)], on = "group_id"][ + idd_parsed$field[, .(class_id, field_id, field_index, field_name, units, ip_units)], on = "class_id"], + c("group", "class", "field"), brief = FALSE)$out, + list( + list( "Group: ", + c("└─ Class: ", + " └─ Field: <1: Test Field>", + " ") + ), + list( "Group: ", + c("└─ Class: ", + " ├─ Field: <1: Test Character Field 1>", + " │─ Field: <2: Test Numeric Field 1 {m}>", + " │─ Field: <3: Test Numeric Field 2>", + " └─ Field: <4: Test Character Field 2>", + " ") + ) + ) + ) + + expect_equal( + format_objects( + idd_parsed$group[ + idd_parsed$class[, .(group_id, class_id, class_name)], on = "group_id"][ + idd_parsed$field[, .(class_id, field_id, field_index, field_name, units, ip_units)], on = "class_id"], + c("field", "class"), brief = FALSE)$out, + list( + c("Class: ", + "└─ Field: <1: Test Field>", + "" + ), + c("Class: ", + "├─ Field: <1: Test Character Field 1>", + "│─ Field: <2: Test Numeric Field 1 {m}>", + "│─ Field: <3: Test Numeric Field 2>", + "└─ Field: <4: Test Character Field 2>", + "" + ) + ) + ) + + expect_equal( + format_objects( + idd_parsed$group[ + idd_parsed$class[, .(group_id, class_id, class_name)], on = "group_id"][ + idd_parsed$field[, .(class_id, field_id, field_index, field_name, units, ip_units)], on = "class_id"], + c("field", "group"), brief = FALSE)$out, + list( + c("Group: ", + "└─ Field: <1: Test Field>", + "" + ), + c("Group: ", + "├─ Field: <1: Test Character Field 1>", + "│─ Field: <2: Test Numeric Field 1 {m}>", + "│─ Field: <3: Test Numeric Field 2>", + "└─ Field: <4: Test Character Field 2>", + "" + ) + ) + ) + + # Relation + expect_equal( + format_idd_relation(get_idd_relation(idd_parsed, direction = "ref_by", name = TRUE), "ref_by")$fmt, + c("Class: ", + "└─ Field: <1: Test Field>", + " ^~~~~~~~~~~~~~~~~~~~~~", + " └─ Class: ", + " └─ Field: <1: Test Character Field 1>", + "" + ) + ) + expect_equal( + format_idd_relation(get_idd_relation(idd_parsed, direction = "ref_to", name = TRUE), "ref_to")$fmt, + c("Class: ", + "└─ Field: <1: Test Character Field 1>", + " v~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~", + " └─ Class: ", + " └─ Field: <1: Test Field>", + "" + ) + ) + # }}} + # IDF {{{ + idd_parsed <- get_priv_env(use_idd(8.8, "auto"))$m_idd_env + idf_parsed <- parse_idf_file(text("idf", "8.8")) + add_joined_cols(idd_parsed$field, idf_parsed$value, "field_id", c("field_index", "type_enum", "units", "ip_units")) + # object + expect_equal(format_objects(idf_parsed$object, component = "object")$out, + c("Object [ID:1] ", + "Object [ID:2] ", + "Object [ID:3] ", + "Object [ID:4] ", + "Object [ID:5]" + ) + ) + # value + expect_equal( + format_objects(get_idf_value(idd_parsed, idf_parsed, property = c("type_enum", "units", "ip_units")), + component = "value", merge = FALSE)$out[c(1,2,4,5)], + c('Value: <"WD01">', + 'Value: <"MediumSmooth">', + 'Value: <0.115>', + 'Value: <513>') + ) + expect_equal( + format_objects(get_idf_value(idd_parsed, idf_parsed), + component = "value", merge = TRUE)$out[c(1,2,4,5)], + c("1: \"WD01\", !- Name", + "2: \"MediumSmooth\",!- Roughness", + "4: 0.115, !- Conductivity {W/m-K}", + "5: 513, !- Density {kg/m3}" + ) + ) + expect_equal( + format_objects(get_idf_value(idd_parsed, idf_parsed, property = c("units", "ip_units", "type_enum")), + component = c("object", "value"))$out[c(1,2,4,5)], + c("[09] Object [ID:1] ", + "[05] Object [ID:2] ", + "[04] Object [ID:4] ", + "[01] Object [ID:5]" + ) + ) + expect_equal( + format_objects(get_idf_value(idd_parsed, idf_parsed), + component = c("object", "value"), + brief = FALSE)$out[[1L]], + c("Object [ID:1] ", + "├─ 1: \"WD01\", !- Name", + "│─ 2: \"MediumSmooth\",!- Roughness", + "│─ 3: 0.019099999, !- Thickness {m}", + "│─ 4: 0.115, !- Conductivity {W/m-K}", + "│─ 5: 513, !- Density {kg/m3}", + "│─ 6: 1381, !- Specific Heat {J/kg-K}", + "│─ 7: 0.9, !- Thermal Absorptance", + "│─ 8: 0.78, !- Solar Absorptance", + "└─ 9: 0.78; !- Visible Absorptance", + "" + ) + ) + expect_equal( + format_objects(get_idf_value(idd_parsed, idf_parsed), + component = c("object", "value"), + brief = FALSE, merge = FALSE)$out[[1L]], + c("Object [ID:1] ", + "├─ Value: <\"WD01\">", + "│─ Value: <\"MediumSmooth\">", + "│─ Value: <0.019099999>", + "│─ Value: <0.115>", + "│─ Value: <513>", + "│─ Value: <1381>", + "│─ Value: <0.9>", + "│─ Value: <0.78>", + "└─ Value: <0.78>", + "" + ) + ) + expect_equal( + unlist(format_objects(get_idf_value(idd_parsed, idf_parsed), + component = c("object", "field", "value"), + brief = FALSE, merge = FALSE)$out[[1L]]), + c("Object [ID:1] ", + "├─ Field: <1: Name>", + "│ └─ Value: <\"WD01\">", + "│ ", + "│─ Field: <2: Roughness>", + "│ └─ Value: <\"MediumSmooth\">", + "│ ", + "│─ Field: <3: Thickness {m}>", + "│ └─ Value: <0.019099999>", + "│ ", + "│─ Field: <4: Conductivity {W/m-K}>", + "│ └─ Value: <0.115>", + "│ ", + "│─ Field: <5: Density {kg/m3}>", + "│ └─ Value: <513>", + "│ ", + "│─ Field: <6: Specific Heat {J/kg-K}>", + "│ └─ Value: <1381>", + "│ ", + "│─ Field: <7: Thermal Absorptance>", + "│ └─ Value: <0.9>", + "│ ", + "│─ Field: <8: Solar Absorptance>", + "│ └─ Value: <0.78>", + "│ ", + "└─ Field: <9: Visible Absorptance>", + " └─ Value: <0.78>", + " " + ) + ) + expect_equal( + unlist(format_objects(get_idf_value(idd_parsed, idf_parsed), + component = c("class", "object", "value"), + brief = FALSE)$out[[1L]]), + c("Class: ", + "├─ Object [ID:1] ", + "│ ├─ 1: \"WD01\", !- Name", + "│ │─ 2: \"MediumSmooth\",!- Roughness", + "│ │─ 3: 0.019099999, !- Thickness {m}", + "│ │─ 4: 0.115, !- Conductivity {W/m-K}", + "│ │─ 5: 513, !- Density {kg/m3}", + "│ │─ 6: 1381, !- Specific Heat {J/kg-K}", + "│ │─ 7: 0.9, !- Thermal Absorptance", + "│ │─ 8: 0.78, !- Solar Absorptance", + "│ └─ 9: 0.78; !- Visible Absorptance", + "│ ", + "└─ Object [ID:4] ", + " ├─ 1: \"WD02\", !- Name", + " │─ 2: \"MediumSmooth\",!- Roughness", + " │─ 3: 0.019099999, !- Thickness {m}", + " └─ 4: 0.115; !- Conductivity {W/m-K}", + " " + ) + ) + expect_equal( + unlist(format_objects(get_idf_value(idd_parsed, idf_parsed), + component = c("class", "object", "field", "value"), + brief = FALSE, merge = FALSE)$out[[1L]]), + c("Class: ", + "├─ Object [ID:1] ", + "│ ├─ Field: <1: Name>", + "│ │ └─ Value: <\"WD01\">", + "│ │ ", + "│ │─ Field: <2: Roughness>", + "│ │ └─ Value: <\"MediumSmooth\">", + "│ │ ", + "│ │─ Field: <3: Thickness {m}>", + "│ │ └─ Value: <0.019099999>", + "│ │ ", + "│ │─ Field: <4: Conductivity {W/m-K}>", + "│ │ └─ Value: <0.115>", + "│ │ ", + "│ │─ Field: <5: Density {kg/m3}>", + "│ │ └─ Value: <513>", + "│ │ ", + "│ │─ Field: <6: Specific Heat {J/kg-K}>", + "│ │ └─ Value: <1381>", + "│ │ ", + "│ │─ Field: <7: Thermal Absorptance>", + "│ │ └─ Value: <0.9>", + "│ │ ", + "│ │─ Field: <8: Solar Absorptance>", + "│ │ └─ Value: <0.78>", + "│ │ ", + "│ └─ Field: <9: Visible Absorptance>", + "│ └─ Value: <0.78>", + "│ ", + "└─ Object [ID:4] ", + " ├─ Field: <1: Name>", + " │ └─ Value: <\"WD02\">", + " │ ", + " │─ Field: <2: Roughness>", + " │ └─ Value: <\"MediumSmooth\">", + " │ ", + " │─ Field: <3: Thickness {m}>", + " │ └─ Value: <0.019099999>", + " │ ", + " └─ Field: <4: Conductivity {W/m-K}>", + " └─ Value: <0.115>", + " " + ) + ) + + # Format IDF + # add field index, class id and class name + add_joined_cols(idf_parsed$object, idf_parsed$value, "object_id", "class_id") + add_joined_cols(idd_parsed$class, idf_parsed$value, "class_id", "class_name") + add_joined_cols(idd_parsed$field, idf_parsed$value, "field_id", c("field_index", "units", "ip_units", "field_name")) + expect_silent({fmt <- format_idf(idf_parsed$value, idf_parsed$object)}) + expect_equal(names(fmt), c("header", "format")) + expect_equal(fmt$header, + c("!-Generator eplusr", + "!-Option SortedOrder", + "", + "!-NOTE: All comments with '!-' are ignored by the IDFEditor and are generated automatically.", + "!- Use '!' comments if they need to be retained when using the IDFEditor." + ) + ) + expect_equal(fmt$format$class_id, c(1L, 55L, 90L, 103L)) + expect_equal(fmt$format$fmt[[2L]], + list("!- =========== ALL OBJECTS IN CLASS: MATERIAL ===========", + list(c("! this is a test comment for WD01"), + c("Material,", + " WD01, !- Name", + " MediumSmooth, !- Roughness", + " 0.019099999, !- Thickness {m}", + " 0.115, !- Conductivity {W/m-K}", + " 513, !- Density {kg/m3}", + " 1381, !- Specific Heat {J/kg-K}", + " 0.9, !- Thermal Absorptance", + " 0.78, !- Solar Absorptance", + " 0.78; !- Visible Absorptance") + ), + list(NULL, + c("Material,", + " WD02, !- Name", + " MediumSmooth, !- Roughness", + " 0.019099999, !- Thickness {m}", + " 0.115; !- Conductivity {W/m-K}" + ) + ) + ) + ) + + expect_null(format_idf(idf_parsed$value, idf_parsed$object, header = FALSE)$header) + expect_null(format_idf(idf_parsed$value, idf_parsed$object, comment = FALSE)$format$fmt[[2L]][[2L]][[1L]]) + expect_silent({fmt <- format_idf(idf_parsed$value, idf_parsed$object, + dt_order = data.table(object_id = 1:5, object_order = 0L), + save_format = "new_top")}) + expect_equal(fmt$format$object_id, 1:5) + expect_equal(fmt$format$fmt[[1L]], + list(c("! this is a test comment for WD01"), + c("Material,", + " WD01, !- Name", + " MediumSmooth, !- Roughness", + " 0.019099999, !- Thickness {m}", + " 0.115, !- Conductivity {W/m-K}", + " 513, !- Density {kg/m3}", + " 1381, !- Specific Heat {J/kg-K}", + " 0.9, !- Thermal Absorptance", + " 0.78, !- Solar Absorptance", + " 0.78; !- Visible Absorptance") + ) + ) + # }}} +}) diff --git a/tests/testthat/test-group.R b/tests/testthat/test-group.R new file mode 100644 index 000000000..36e2c3721 --- /dev/null +++ b/tests/testthat/test-group.R @@ -0,0 +1,183 @@ +context("Group metiods") + +test_that("Group methods", { + skip_on_cran() + eplusr_option(verbose_info = FALSE) + + if (!is_avail_eplus(8.8)) install_eplus(8.8) + + path_idfs <- normalizePath(file.path(eplus_config(8.8)$dir, "ExampleFiles", + c("1ZoneDataCenterCRAC_wPumpedDXCoolingCoil.idf", + "1ZoneEvapCooler.idf", + "1ZoneParameterAspect.idf", + "1ZoneUncontrolled_DD2009.idf", + "1ZoneUncontrolled_DDChanges.idf" + ) + )) + path_epws <- normalizePath(list.files(file.path(eplus_config(8.8)$dir, "WeatherData"), + "\\.epw", full.names = TRUE)[1:5]) + + expect_error(group_job(empty_idf(8.8)), class = "error_idf_not_local") + # can stop if input model is not saved after modification + expect_error( + group_job( + list( + {idf <- read_idf(path_idfs[[1]]); idf$RunPeriod <- NULL; idf}, + path_idfs[1] + ), + NULL + ), + class = "error_invalid_group_idf_input" + ) + expect_silent(group_job(path_idfs, path_epws[1L])) + expect_silent(group_job(path_idfs[1], path_epws)) + expect_silent(grp <- group_job(path_idfs, NULL)) + expect_equal(grp$status(), + list(run_before = FALSE, alive = FALSE, terminated = NA, + successful = NA, changed_after = NA, + job_status = data.table(index = 1:5, status = "idle", + idf = path_idfs, epw = NA_character_ + ) + ) + ) + + # Run and Status {{{ + # can run the simulation and get status of simulation + expect_equal({grp$run(dir = file.path(tempdir(), "test"), echo = FALSE); status <- grp$status(); names(status)}, + c("run_before", "alive", "terminated", "successful", "changed_after", "job_status") + ) + expect_equal(status[c("run_before", "alive", "terminated", "successful", "changed_after")], + list(run_before = TRUE, alive = FALSE, terminated = FALSE, + successful = FALSE, changed_after = FALSE + ) + ) + expect_equal(names(status$job_status), + c("index", "status", "idf", "epw", "exit_status", "start_time", "end_time", + "energyplus", "output_dir", "stdout", "stderr" + ) + ) + expect_equal(status$job_status$exit_status, c(0L, 0L, 1L, 0L, 0L)) + # }}} + + # Errors {{{ + expect_silent(grp$errors(2)) + expect_warning(grp$errors(3), class = "warn_job_error") + # }}} + + # Output Dir{{{ + expect_silent(grp$output_dir(1)) + expect_warning(grp$output_dir(3), class = "warn_job_error") + # }}} + + # Table {{{ + expect_error(grp$list_table()) + expect_silent(lsts <- grp$list_table(c(1,2,4))) + expect_is(lsts, "list") + expect_equal(length(lsts), 3L) + + expect_error(grp$read_table()) + expect_silent(tables <- grp$read_table(c(1, 2, 4), "Zones")) + expect_equal(names(tables)[1], "case") + # }}} + + # RDD & MDD {{{ + expect_error(grp$read_rdd(3)) + expect_silent(rdds <- grp$read_rdd(c(1,2,4))) + expect_is(rdds, "data.table") + expect_error(grp$read_mdd(3)) + expect_silent(mdds <- grp$read_mdd(c(1,2,4))) + expect_is(mdds, "data.table") + # }}} + + # Report Data Dict {{{ + expect_error(grp$report_data_dict(), class = "error_job_error") + expect_is(grp$report_data_dict(c(1,2,4,5)), "data.table") + expect_true(has_name(grp$report_data_dict(c(1,2,4,5)), "case")) + expect_equal(nrow(grp$report_data_dict(2)), 22) + expect_equal(nrow(grp$report_data_dict("1zoneevapcooler")), 22) + # }}} + + # Tabular Data {{{ + expect_equal(nrow(grp$tabular_data(c(1,2,4,5))), 14668) + expect_equal(nrow(grp$tabular_data(c(1,2,4,5), + report_name = c( + "AnnualBuildingUtilityPerformanceSummary", + "Initialization Summary" + ))), + 9032 + ) + expect_equal(nrow(grp$tabular_data(c(1,2,4,5), table_name = "Site and Source Energy")), 12 * 4) + expect_equal(nrow(grp$tabular_data(c(1,2,4,5), column_name = "Total Energy")), 4 * 4) + expect_equal(nrow(grp$tabular_data(c(1,2,4,5), row_name = "Total Site Energy")), 3 * 4) + expect_equal(nrow(grp$tabular_data(2)), 2172) + expect_equal(nrow(grp$tabular_data(2, + report_name = c( + "AnnualBuildingUtilityPerformanceSummary", + "Initialization Summary" + ))), + 769 + ) + expect_equal(nrow(grp$tabular_data("1zoneevapcooler", table_name = "Site and Source Energy")), 12) + expect_equal(nrow(grp$tabular_data("1zoneevapcooler" ,column_name = "Total Energy")), 4) + expect_equal(nrow(grp$tabular_data("1zoneevapcooler", row_name = "Total Site Energy")), 3) + # can convert to wide table + expect_silent(tab <- grp$tabular_data("1zoneevapcooler", row_name = "Total Site Energy", wide = TRUE)) + expect_equal(names(tab), "AnnualBuildingUtilityPerformanceSummary.Entire Facility.Site and Source Energy") + expect_equivalent(tab[[1L]][, lapply(.SD, class)], + data.table( + case = "character", + report_name = "character", + report_for = "character", + table_name = "character", + row_name = "character", + `Total Energy [GJ]` = "numeric", + `Energy Per Total Building Area [MJ/m2]` = "numeric", + `Energy Per Conditioned Building Area [MJ/m2]` = "numeric" + ) + ) + # }}} + + # Report Data {{{ + expect_equal(nrow(grp$report_data(2, grp$report_data_dict(2))), 872) + expect_equal(nrow(grp$report_data(2)), 872) + expect_equal(nrow(grp$report_data(2, "")), 8) + expect_equal(lubridate::tz(grp$report_data(2, tz = "Asia/Shanghai")$datetime), + "Asia/Shanghai" + ) + expect_equal(names(grp$report_data(2, all = TRUE)), + c("case", "datetime", "month", "day", "hour", "minute", "dst", "interval", + "simulation_days", "day_type", "environment_name", + "environment_period_index", "is_meter", "type", "index_group", + "timestep_type", "key_value", "name", "reporting_frequency", + "schedule_name", "units", "value" + ) + ) + grp$report_data(2) + expect_equal(nrow(grp$report_data(2, period = seq( + lubridate::ymd_hms("2019-12-21 1:0:0"), lubridate::ymd_hms("2019-12-22 0:0:0"), "1 hour") + )), 414) + expect_equal(nrow(grp$report_data(2, month = 12)), 436) + expect_equal(nrow(grp$report_data(2, month = 12, hour = 1)), 18) + expect_equal(nrow(grp$report_data(2, minute = 0)), 872) + expect_equal(nrow(grp$report_data(2, interval = 60)), 872) + expect_equal(nrow(grp$report_data(2, simulation_days = 1)), 872) + expect_equal(nrow(grp$report_data(2, day_type = "WinterDesignDay")), 436) + expect_equal(nrow(grp$report_data(2, environment_name = "DENVER CENTENNIAL ANN HTG 99.6% CONDNS DB")), 436) + # }}} + + # S3 {{{ + expect_true(grp == grp) + expect_false(grp != grp) + # }}} + + skip_on_os("mac") + # Locate Output {{{ + expect_error(grp$locate_output(suffix = ".sql")) + expect_equal(grp$locate_output(2, suffix = ".sql"), + normalizePath(file.path(tempdir(), "test", + tools::file_path_sans_ext(basename(path_idfs[2])), + paste0(tools::file_path_sans_ext(basename(path_idfs[2])), ".sql") + )) + ) + # }}} +}) diff --git a/tests/testthat/test-impl-epw.R b/tests/testthat/test-impl-epw.R new file mode 100644 index 000000000..0cbd8f394 --- /dev/null +++ b/tests/testthat/test-impl-epw.R @@ -0,0 +1,506 @@ +context("Epw Implementation") + +# Epw Header {{{ +test_that("Epw Header", { + # IDD + expect_is(idd <- get_epw_idd(), "Idd") + + # PARSE {{{ + expect_error(parse_epw_header("Wrong\n"), class = "eplusr_error_parse_epw_header_name") + expect_error(parse_epw_header("LOCATION,;;\n"), class = "eplusr_error_parse_epw_header_line") + expect_error(parse_epw_header(paste0("LOCATION", strrep(",", 11), "\n")), class = "eplusr_error_parse_epw_header_field") + + # can stop if missing header + expect_is(err <- catch_cnd(parse_epw_header("LOCATION\n")), "eplusr_error_validity_check") + expect_equal(err$data$missing_object, c( + "DESIGN CONDITIONS", + "TYPICAL/EXTREME PERIODS", + "GROUND TEMPERATURES", + "HOLIDAYS/DAYLIGHT SAVINGS", + "COMMENTS 1", + "COMMENTS 2", + "DATA PERIODS" + )) + + # can stop if invalid type + expect_is(err <- catch_cnd(parse_epw_header("DESIGN CONDITIONS,a\n")), "eplusr_error_validity_check") + expect_equal(err$data$invalid_numeric$class_name, "DESIGN CONDITIONS") + expect_equal(err$data$invalid_numeric$field_index, 1L) + + # can fill "0" for empty headers + expect_is(class = "list", + h <- parse_epw_header( + " + LOCATION,city,state,country,type,wmo,1,2,3,4 + DESIGN CONDITIONS + TYPICAL/EXTREME PERIODS + GROUND TEMPERATURES + HOLIDAYS/DAYLIGHT SAVINGS,yes,0,0,0 + COMMENTS 1 + COMMENTS 2 + DATA PERIODS,1,1, Data, Friday, 2016/01/01, 2016/12/31 + " + ) + ) + expect_equal(h$value[object_id %in% c(2, 3, 4), value_num], rep(0, 3)) + expect_equal(h$value[object_id %in% c(6, 7), value_chr], rep(NA_character_, 2)) + + # can fix mismatched extensible group and value of number field + DC <- function (n = 1, m = n) { + htg <- c("heating", 1:15) + clg <- c("cooling", 1:32) + ext <- c("extremes", 1:16) + grp <- paste0(rep(c(htg, clg, ext), m), collapse = ",") + paste("DESIGN CONDITIONS", n, "src", "", grp, sep = ",", collapse = ",") + } + expect_warning( + h <- parse_epw_header(paste0( + " + LOCATION,city,state,country,type,wmo,1,2,3,4 + ", DC(0, 1), " + TYPICAL/EXTREME PERIODS,0,period,typical,1/1,1/2 + GROUND TEMPERATURES,0,0.5,,,,", paste0(1:12, collapse = ","), " + HOLIDAYS/DAYLIGHT SAVINGS,yes,0,0,0,New year,1/1 + COMMENTS 1 + COMMENTS 2 + DATA PERIODS,1,1,Data,Friday,2016/01/01,2016/12/31,Data1,Friday,2017/01/01,2017/12/31 + " + )), + "Number of Design Conditions" + ) + expect_equal(h$value[object_id == 2, value_num][1], 1L) + expect_equal(h$value[object_id == 3, value_num][1], 1L) + expect_equal(h$value[object_id == 4, value_num][1], 1L) + expect_equal(h$value[object_id == 5, value_num][4], 1L) + expect_equal(h$value[object_id == 8, value_num][1], 2L) + + # can stop if invalid EpwDate + expect_error( + parse_epw_header(paste0( + " + LOCATION,city,state,country,type,wmo,1,2,3,4 + DESIGN CONDITIONS + TYPICAL/EXTREME PERIODS,1,period,typical,a,1/2 + GROUND TEMPERATURES + HOLIDAYS/DAYLIGHT SAVINGS,yes,0,0,0 + COMMENTS 1 + COMMENTS 2 + DATA PERIODS,1,1,Data,Friday,2016/01/01,2016/12/31 + " + )), + class = "eplusr_error_parse_epw" + ) + expect_error( + parse_epw_header(paste0( + " + LOCATION,city,state,country,type,wmo,1,2,3,4 + DESIGN CONDITIONS + TYPICAL/EXTREME PERIODS,1,period,typical,1/1,a + GROUND TEMPERATURES + HOLIDAYS/DAYLIGHT SAVINGS,yes,0,0,0 + COMMENTS 1 + COMMENTS 2 + DATA PERIODS,1,1,Data,Friday,2016/01/01,2016/12/31 + " + )), + class = "eplusr_error_parse_epw" + ) + expect_error( + parse_epw_header(paste0( + " + LOCATION,city,state,country,type,wmo,1,2,3,4 + DESIGN CONDITIONS + TYPICAL/EXTREME PERIODS,1,period,typical,1/2,1/1 + GROUND TEMPERATURES + HOLIDAYS/DAYLIGHT SAVINGS,yes,0,0,0 + COMMENTS 1 + COMMENTS 2 + DATA PERIODS,1,1,Data,Friday,2016/01/01,2016/12/31 + " + )), + class = "eplusr_error_parse_epw" + ) + expect_error( + parse_epw_header(paste0( + " + LOCATION,city,state,country,type,wmo,1,2,3,4 + DESIGN CONDITIONS + TYPICAL/EXTREME PERIODS + GROUND TEMPERATURES + HOLIDAYS/DAYLIGHT SAVINGS,yes,1/1,0,0 + COMMENTS 1 + COMMENTS 2 + DATA PERIODS,1,1,Data,Friday,2016/01/01,2016/12/31 + " + )), + class = "eplusr_error_parse_epw" + ) + expect_error( + parse_epw_header(paste0( + " + LOCATION,city,state,country,type,wmo,1,2,3,4 + DESIGN CONDITIONS + TYPICAL/EXTREME PERIODS + GROUND TEMPERATURES + HOLIDAYS/DAYLIGHT SAVINGS,yes,0,0,1,new year, 2020/01/01 + COMMENTS 1 + COMMENTS 2 + DATA PERIODS,1,1,Data,Friday,2016/01/01,2016/12/31 + " + )), + class = "eplusr_error_parse_epw" + ) + expect_error( + parse_epw_header(paste0( + " + LOCATION,city,state,country,type,wmo,1,2,3,4 + DESIGN CONDITIONS + TYPICAL/EXTREME PERIODS + GROUND TEMPERATURES + HOLIDAYS/DAYLIGHT SAVINGS,yes,0,0,0 + COMMENTS 1 + COMMENTS 2 + DATA PERIODS,1,7,Data,Friday,2016/01/01,2016/12/31 + " + )), + class = "eplusr_error_parse_epw" + ) + expect_error( + parse_epw_header(paste0( + " + LOCATION,city,state,country,type,wmo,1,2,3,4 + DESIGN CONDITIONS + TYPICAL/EXTREME PERIODS + GROUND TEMPERATURES + HOLIDAYS/DAYLIGHT SAVINGS,yes,0,0,0 + COMMENTS 1 + COMMENTS 2 + DATA PERIODS,2,1,Data,Friday,2016/01/01,2016/1/31,Data,Friday,2016/2/01,2016/12/31 + " + )), + class = "eplusr_error_parse_epw" + ) + expect_error( + parse_epw_header(paste0( + " + LOCATION,city,state,country,type,wmo,1,2,3,4 + DESIGN CONDITIONS + TYPICAL/EXTREME PERIODS + GROUND TEMPERATURES + HOLIDAYS/DAYLIGHT SAVINGS,yes,0,0,0 + COMMENTS 1 + COMMENTS 2 + DATA PERIODS,1,1,Data,Friday,2nd Mon in December,2016/12/31 + " + )), + class = "eplusr_error_parse_epw" + ) + expect_error( + parse_epw_header(paste0( + " + LOCATION,city,state,country,type,wmo,1,2,3,4 + DESIGN CONDITIONS + TYPICAL/EXTREME PERIODS + GROUND TEMPERATURES + HOLIDAYS/DAYLIGHT SAVINGS,yes,0,0,0 + COMMENTS 1 + COMMENTS 2 + DATA PERIODS,1,1,Data,Friday,12/1,0 + " + )), + class = "eplusr_error_parse_epw" + ) + expect_warning( + h <- parse_epw_header(paste0( + " + LOCATION,city,state,country,type,wmo,1,2,3,4 + DESIGN CONDITIONS + TYPICAL/EXTREME PERIODS + GROUND TEMPERATURES + HOLIDAYS/DAYLIGHT SAVINGS,yes,0,0,0 + COMMENTS 1 + COMMENTS 2 + DATA PERIODS,1,1,Data,Friday,2016/01/01,12/31 + " + )) + ) + expect_equal(h$value[object_id == 8L, value_chr][6], "2016/12/31") + expect_error( + parse_epw_header(paste0( + " + LOCATION,city,state,country,type,wmo,1,2,3,4 + DESIGN CONDITIONS + TYPICAL/EXTREME PERIODS + GROUND TEMPERATURES + HOLIDAYS/DAYLIGHT SAVINGS,yes,0,0,0 + COMMENTS 1 + COMMENTS 2 + DATA PERIODS,1,1,Data,Friday,2017/01/01,2/29 + " + )), + class = "eplusr_error_parse_epw" + ) + expect_warning( + h <- parse_epw_header(paste0( + " + LOCATION,city,state,country,type,wmo,1,2,3,4 + DESIGN CONDITIONS + TYPICAL/EXTREME PERIODS + GROUND TEMPERATURES + HOLIDAYS/DAYLIGHT SAVINGS,yes,0,0,0 + COMMENTS 1 + COMMENTS 2 + DATA PERIODS,1,1,Data,Friday,01/29,2016/3/21 + " + )), + class = "eplusr_error_parse_epw" + ) + expect_equal(h$value[object_id == 8L, value_chr][6], " 3/21") + expect_warning( + h <- parse_epw_header(paste0( + " + LOCATION,city,state,country,type,wmo,1,2,3,4 + DESIGN CONDITIONS + TYPICAL/EXTREME PERIODS + GROUND TEMPERATURES + HOLIDAYS/DAYLIGHT SAVINGS,yes,0,0,0 + COMMENTS 1 + COMMENTS 2 + DATA PERIODS,1,1,Data,Friday,2015/01/29,2015/3/21 + " + )) + ) + expect_error( + h <- parse_epw_header(paste0( + " + LOCATION,city,state,country,type,wmo,1,2,3,4 + DESIGN CONDITIONS + TYPICAL/EXTREME PERIODS + GROUND TEMPERATURES + HOLIDAYS/DAYLIGHT SAVINGS,yes,0,0,0 + COMMENTS 1 + COMMENTS 2 + DATA PERIODS,1,1,Data,Friday,1/2,1/1 + " + )), + class = "eplusr_error_parse_epw" + ) + + expect_error( + h <- parse_epw_header(paste0( + " + LOCATION,city,state,country,type,wmo,1,2,3,4 + DESIGN CONDITIONS + TYPICAL/EXTREME PERIODS + GROUND TEMPERATURES + HOLIDAYS/DAYLIGHT SAVINGS,no,0,0,0 + COMMENTS 1 + COMMENTS 2 + DATA PERIODS,1,1,Data,Friday,2016/2/29,2016/3/1 + " + )), + class = "eplusr_error_parse_epw" + ) + + expect_error( + parse_epw_header(paste0( + " + LOCATION,city,state,country,type,wmo,1,2,3,4 + DESIGN CONDITIONS + TYPICAL/EXTREME PERIODS + GROUND TEMPERATURES + HOLIDAYS/DAYLIGHT SAVINGS,yes,0,0,0 + COMMENTS 1 + COMMENTS 2 + DATA PERIODS,2,1,Data,Friday,2016/01/01,2016/1/31,Data1,Friday,2016/1/1,2016/12/31 + " + )), + class = "eplusr_error_parse_epw" + ) + # }}} + + # VALUE {{{ + idd <- get_epw_idd() + idd_env <- get_priv_env(idd)$idd_env() + idf_env <- parse_epw_header( + " + LOCATION,city,state,country,type,wmo,1,2,3,4 + DESIGN CONDITIONS + TYPICAL/EXTREME PERIODS + GROUND TEMPERATURES + HOLIDAYS/DAYLIGHT SAVINGS,no,0,0,0 + COMMENTS 1 + COMMENTS 2 + DATA PERIODS,1,1, Data, Friday, 01/01, 12/31 + " + ) + # }}} + + # FORMAT {{{ + idd_env <- get_priv_env(idd)$idd_env() + expect_is(class = "list", + h <- parse_epw_header( + " + LOCATION,city,state,country,type,wmo,1,2,3,4 + DESIGN CONDITIONS + TYPICAL/EXTREME PERIODS + GROUND TEMPERATURES + HOLIDAYS/DAYLIGHT SAVINGS,no,0,0,0 + COMMENTS 1 + COMMENTS 2 + DATA PERIODS,1,1, Data, Friday, 01/01, 12/31 + " + ) + ) + + expect_equal(format_epw_header(h), + c("LOCATION,city,state,country,type,wmo,1,2,3,4", + "DESIGN CONDITIONS,0", + "TYPICAL/EXTREME PERIODS,0", + "GROUND TEMPERATURES,0", + "HOLIDAYS/DAYLIGHT SAVINGS,No,0,0,0", + "COMMENTS 1,", + "COMMENTS 2,", + "DATA PERIODS,1,1,Data,Friday, 1/ 1,12/31" + ) + ) + + expect_equal(format_epw_meta(h), + c("[Location ]: city, state, country", + " {N 1°0'}, {E 2°0'}, {UTC+03:00}", + "[Elevation]: 4m above see level", + "[Data Src ]: type", + "[WMO Stat ]: wmo", + "[Leap Year]: No", + "[Interval ]: 60 mins" + ) + ) + # }}} +}) +# }}} + +# Epw Data {{{ +test_that("Epw Data", { + idd <- get_epw_idd() + idd_env <- get_priv_env(idd)$idd_env() + idf_env <- parse_epw_header( + " + LOCATION,city,state,country,type,wmo,1,2,3,4 + DESIGN CONDITIONS + TYPICAL/EXTREME PERIODS + GROUND TEMPERATURES + HOLIDAYS/DAYLIGHT SAVINGS,no,0,0,0 + COMMENTS 1 + COMMENTS 2 + DATA PERIODS,1,1, Data, Friday, 01/01, 12/31 + " + ) + + expect_error(parse_epw_data("\n\n\n\n\n\n\n\n,,,"), class = "eplusr_error_parse_epw_data_column") + + hd <- "1\n2\n3\n4\n5\n6\n7\n8" + dh <- paste0(rep("a", 35), collapse = ",") + rw <- init_idf_value(idd_env, idf_env, "WEATHER DATA", property = "type") + + val <- paste0(copy(rw)[type == "integer", value_chr := "a"]$value_chr, collapse = ",") + expect_error(parse_epw_data(paste(hd, dh, val, sep = "\n")), class = "eplusr_error_parse_epw_data_type") + + val <- paste0(copy(rw)[type == "real", value_chr := "a"]$value_chr, collapse = ",") + expect_error(parse_epw_data(paste(hd, dh, val, sep = "\n")), class = "eplusr_error_parse_epw_data_type") + + skip_on_cran() + if (!is_avail_eplus(8.8)) install_eplus(8.8) + path_epw <- file.path(eplus_config(8.8)$dir, "WeatherData", "USA_CA_San.Francisco.Intl.AP.724940_TMY3.epw") + + expect_is(parsed <- parse_epw_file(path_epw), "list") + expect_equal(names(parsed), c("header", "data", "matched")) + expect_equal(ncol(parsed$data), 36L) + expect_equal(parsed$matched, data.table(index = 1L, row = 1L, num = 8760L)) + + # FORMAT + expect_equal(find_nearst_wday_year(make_date(2019, 1, 14), 1, 2019), 2019) + expect_equal(find_nearst_wday_year(make_date(2019, 1, 14), 2, 2019), 2014) +}) +# }}} + +# EpwDate Class {{{ +test_that("EpwDate Class", { + expect_equal(get_epw_wday(1), 1) + expect_equal(get_epw_wday(1, label = TRUE), "Monday") + expect_equal(get_epw_wday(1, label = TRUE, abbr = TRUE), "Mon") + expect_equal(get_epw_wday("mon"), 1) + expect_equal(get_epw_wday("mon", label = TRUE), "Monday") + expect_equal(get_epw_wday("mon", label = TRUE, abbr = TRUE), "Mon") + + expect_error(epw_date(list()), "Missing method to convert") + expect_equal(epw_date(""), init_epwdate_vctr(1)) + expect_equal(format(epw_date("")), NA_character_) + expect_output(print(epw_date("")), "NA") + + expect_equal(epw_date(0L), init_epwdate_vctr(1, "0-01-01")) + expect_equal(epw_date("0"), init_epwdate_vctr(1, "0-01-01")) + + expect_equal(epw_date(367), init_epwdate_vctr(1)) + expect_equal(format(epw_date(367)), NA_character_) + expect_output(print(epw_date(367)), "NA") + + expect_equal(epw_date(366), init_epwdate_vctr(1, "4-12-31")) + expect_equal(format(epw_date(366)), "366") + expect_output(print(epw_date(366)), "366th day") + + expect_equal(epw_date(3), init_epwdate_vctr(1, "4-01-03")) + expect_equal(format(epw_date(3)), "3") + expect_output(print(epw_date(3)), "3rd day") + + expect_equal(epw_date("3.10"), init_epwdate_vctr(1, "8-03-10")) + + expect_equal(epw_date("01/03"), init_epwdate_vctr(1, "8-01-03")) + expect_equal(format(epw_date("Apr-01")), " 4/ 1") + expect_output(print(epw_date("Apr-01")), "Apr 01") + + expect_equal(epw_date("01-Apr"), init_epwdate_vctr(1, "8-04-01")) + expect_equal(format(epw_date("01-Apr")), " 4/ 1") + expect_output(print(epw_date("01-Apr")), "Apr 01") + + expect_equal(epw_date("2019-01-Apr"), init_epwdate_vctr(1)) + expect_equal(format(epw_date("2019-01-Apr")), NA_character_) + expect_output(print(epw_date("2019-01-Apr")), "NA") + + expect_equal(epw_date("2019-Apr-01"), init_epwdate_vctr(1)) + expect_equal(format(epw_date("2019-Apr-01")), NA_character_) + expect_output(print(epw_date("2019-Apr-01")), "NA") + + expect_equal(epw_date("4-01-2019"), init_epwdate_vctr(1, "2019-04-01")) + expect_equal(format(epw_date("4-01-2019")), "2019/ 4/ 1") + expect_output(print(epw_date("4-01-2019")), "2019-04-01") + + expect_equal(epw_date("last Mon in Jan"), init_epwdate_vctr(1, "16-01-25")) + expect_equal(format(epw_date("last Mon in Jan")), "Last Monday in January") + expect_output(print(epw_date("last Mon in Jan")), "Last Monday in January") + + expect_equal(epw_date("1st Mon in Jan"), init_epwdate_vctr(1, "12-01-02")) + expect_equal(format(epw_date("1st Mon in Jan")), "1st Monday in January") + expect_output(print(epw_date("1st Mon in Jan")), "1st Monday in January") + + expect_equal(format(epw_date(c("2nd Sunday in March", "1st Sunday in November"))), + c("2nd Sunday in March", "1st Sunday in November") + ) + + expect_equal(epw_date("6 Mon in Jan"), init_epwdate_vctr(1)) + expect_equal(format(epw_date("6 Mon in Jan")), NA_character_) + expect_output(print(epw_date("6 Mon in Jan")), "NA") + + expect_equal(c(epw_date("1/3"), epw_date("3")), epw_date(c("1/3", "3"))) + + expect_true(is_EpwDate(epw_date("1"))) + expect_false(is_EpwDate(Sys.Date())) + expect_equal(epw_date(1), as_EpwDate("1")) + expect_true(is.na(epw_date(""))) + expect_false(is.na(epw_date(1))) + expect_equal(length(epw_date(1:5)), 5L) + expect_equal(epw_date(1:5)[2L], epw_date(2)) + expect_equal(epw_date(1:5)[[3L]], epw_date(3)) + expect_equal({d <- epw_date(1:2);d[1] <- epw_date(3);d}, epw_date(c(3, 2))) + expect_equal({d <- epw_date(1:2);d[[1]] <- epw_date(3);d}, epw_date(c(3, 2))) +}) +# }}} diff --git a/tests/testthat/test-impl-idf.R b/tests/testthat/test-impl-idf.R index 3efcf79e8..f1b19af58 100644 --- a/tests/testthat/test-impl-idf.R +++ b/tests/testthat/test-impl-idf.R @@ -683,6 +683,17 @@ test_that("VALUE DOTS", { # can stop if LHS of ":=" is not allowed expect_error(parse_dots_value(c(1, 2) := list(..1 = "name", ..2 = "sch", 1:3), .scalar = FALSE, .pair = TRUE), class = "eplusr_error_dots_pair_length") + expect_equal(parse_dots_value(cls = list(..1 = "name", ..2 = 1L, NULL, NULL)), + list(object = data.table(rleid = 1L, each_rleid = 1L, id = NA_integer_, name = "cls", + comment = list(), is_ref = FALSE, lhs_sgl = FALSE, rhs_sgl = TRUE, is_empty = FALSE), + value = data.table(rleid = 1L, each_rleid = 1L, id = NA_integer_, name = "cls", + field_index = c(1:2, rep(NA_integer_, 2)), field_name = NA_character_, + value_chr = c("name", "1", rep(NA_character_, 2)), + value_num = c(NA_real_, 1, NA_real_, NA_real_) + ) + ) + ) + # can separate numeric and character value expect_equal(parse_dots_value(cls = list(..1 = "name", ..2 = 1L, NULL, NULL)), list(object = data.table(rleid = 1L, each_rleid = 1L, id = NA_integer_, name = "cls", @@ -742,6 +753,15 @@ test_that("VALUE DOTS", { ) # can use multiple inputs on LHS of ":=" + expect_equal(parse_dots_value(.(1:3) := list(..1 = "name")), + list(object = data.table(rleid = 1L, each_rleid = 1:3, id = 1:3, name = NA_character_, + comment = list(), is_ref = TRUE, lhs_sgl = FALSE, rhs_sgl = TRUE, is_empty = FALSE), + value = data.table(rleid = 1L, each_rleid = 1:3, id = 1:3, name = NA_character_, + field_index = 1L, field_name = NA_character_, + value_chr = "name", value_num = NA_real_ + ) + ) + ) expect_equal(parse_dots_value(c(1:3) := list(..1 = "name")), list(object = data.table(rleid = 1L, each_rleid = 1:3, id = 1:3, name = NA_character_, comment = list(), is_ref = TRUE, lhs_sgl = FALSE, rhs_sgl = TRUE, is_empty = FALSE), @@ -751,6 +771,30 @@ test_that("VALUE DOTS", { ) ) ) + a <- "cls1" + b <- c("cls2", "cls3") + expect_equal(parse_dots_value(..(a) := list(), ..(b) := list(), .empty = TRUE), + list(object = data.table(rleid = c(1L, 2L, 2L), each_rleid = c(1L, 1L, 2L), + id = NA_integer_, name = paste0("cls", 1:3), + comment = list(), is_ref = TRUE, lhs_sgl = FALSE, rhs_sgl = TRUE, is_empty = TRUE), + value = data.table(rleid = c(1L, 2L, 2L), each_rleid = c(1L, 1L, 2L), + id = NA_integer_, name = paste0("cls", 1:3), + field_index = NA_integer_, field_name = NA_character_, + value_chr = NA_character_, value_num = NA_real_ + ) + ) + ) + expect_equal(parse_dots_value(..("cls1") := list(), ..("cls2", "cls3") := list(), .empty = TRUE), + list(object = data.table(rleid = c(1L, 2L, 2L), each_rleid = c(1L, 1L, 2L), + id = NA_integer_, name = paste0("cls", 1:3), + comment = list(), is_ref = TRUE, lhs_sgl = FALSE, rhs_sgl = TRUE, is_empty = TRUE), + value = data.table(rleid = c(1L, 2L, 2L), each_rleid = c(1L, 1L, 2L), + id = NA_integer_, name = paste0("cls", 1:3), + field_index = NA_integer_, field_name = NA_character_, + value_chr = NA_character_, value_num = NA_real_ + ) + ) + ) # can stop if multiple value for normal list when .pair is TRUE expect_error( @@ -950,15 +994,15 @@ test_that("VALUE DOTS", { expect_is(res <- expand_idf_dots_value(idd_env, idf_env, c(1) := list(8.8), .empty = FALSE), "list") expect_equal(names(res), c("object", "value")) expect_equal(res$object, - data.table(rleid = 1L, class_id = 1L, class_name = "Version", + data.table(rleid = 1L, class_id = 1L, class_name = "Version", object_id = NA_integer_, object_name = NA_character_, object_name_lower = NA_character_, comment = list() ) ) expect_equal(res$value, - data.table(rleid = 1L, class_id = 1L, class_name = "Version", - object_id = NA_integer_, object_name = NA_character_, field_id = 1L, - field_index = 1L, field_name = "Version Identifier", value_id = NA_integer_, + data.table(rleid = 1L, class_id = 1L, class_name = "Version", + object_id = NA_integer_, object_name = NA_character_, field_id = 1L, + field_index = 1L, field_name = "Version Identifier", value_id = NA_integer_, value_chr = "8.8", value_num = 8.8) ) @@ -1045,6 +1089,14 @@ test_that("VALUE DOTS", { ) expect_equal(res$object$object_id, 27:40) expect_equal(res$value$field_index, rep(1:3, 14)) + cls <- "Output_Variable" + expect_is(class = "list", + res1 <- expand_idf_dots_value(idd_env, idf_env, .type = "object", .complete = FALSE, + ..(cls) := list(), + .scalar = FALSE, .pair = TRUE + ) + ) + expect_equal(res, res1) ## Class := list(), dup expect_is(class = "list", res <- expand_idf_dots_value(idd_env, idf_env, .type = "object", .complete = FALSE, diff --git a/tests/testthat/test-install.R b/tests/testthat/test-install.R new file mode 100644 index 000000000..bdad3ace7 --- /dev/null +++ b/tests/testthat/test-install.R @@ -0,0 +1,13 @@ +test_that("Install", { + skip_on_cran() + expect_equal(as.character(avail_eplus()), names(.globals$eplus)) + if (is_avail_eplus(8.8)) expect_error(install_eplus(8.8, local = TRUE)) + if (is_macos()) expect_error(install_eplus(8.8, local = TRUE)) + else install_eplus(8.8, local = TRUE, force = TRUE) + + # test if patch on EnergyPlus v9.1 and above works + if (!is_avail_eplus(9.1)) install_eplus(9.1, local = TRUE) + if (!is_avail_eplus(9.2)) install_eplus(9.2, local = TRUE) + expect_true(is_avail_eplus(9.1)) + expect_true(is_avail_eplus(9.2)) +}) diff --git a/tests/testthat/test-job.R b/tests/testthat/test-job.R new file mode 100644 index 000000000..84960ed42 --- /dev/null +++ b/tests/testthat/test-job.R @@ -0,0 +1,116 @@ +context("Job methods") + +test_that("Job methods", { + eplusr_option(verbose_info = FALSE) + skip_on_cran() + if (!is_avail_eplus(8.8)) install_eplus(8.8) + + example <- copy_example() + + expect_silent(job <- eplus_job(example$idf, example$epw)) + + # can get job status + expect_equal( + job$status(), + list(run_before = FALSE, alive = FALSE, terminated = NA, + successful = NA, changed_after = NA) + ) + + # can run job in waiting mode + expect_silent(job$run(wait = TRUE, echo = FALSE)) + + # can refresh job status + expect_equal(job$status(), + list(run_before = TRUE, alive = FALSE, terminated = FALSE, + successful = TRUE, changed_after = FALSE) + ) + + # can kill job + expect_silent(job$kill()) + + example <- copy_example() + job <- eplus_job(example$idf, example$epw) + expect_is({job$run(echo = FALSE);job$errors()}, "ErrFile") + expect_is(job$errors(info = TRUE), "ErrFile") + expect_silent({err <- job$errors()}) + expect_equal(names(err), c("index", "envir_index", "envir", + "level_index", "level", "message" + )) + expect_equal(attr(err, "eplus_version"), numeric_version("8.8.0")) + expect_equal(attr(err, "eplus_build"), "7c3bbe4830") + expect_equal(attr(err, "idd_version"), numeric_version("8.8.0")) + expect_equal(attr(err, "successful"), TRUE) + expect_equal(attr(err, "terminated"), FALSE) + + # can retrieve simulation data + idf <- read_idf(example$idf) + job <- idf$run(example$epw, dir = NULL, echo = FALSE) + # can get all table names + expect_equal(length(job$list_table()), 44L) + + # can read table + expect_error(job$read_table("a"), "no such table") + expect_is(job$read_table("Zones"), "data.table") + + # can read report data dictionary + expect_is(job$report_data_dict(), "data.table") + + # can read report data + expect_equal(nrow(job$report_data()), 3840L) + expect_equal(nrow(job$report_data("")), 1344L) + expect_equal(nrow(job$report_data( + "TRANSFORMER 1", "Transformer Load Loss Rate")), + 192L + ) + expect_equal(nrow(job$report_data( + "TRANSFORMER 1", "Transformer Load Loss Rate")), + 192L + ) + expect_equal(year(job$report_data( + "TRANSFORMER 1", "Transformer Load Loss Rate", year = 2010)$datetime), + rep(2010, 192) + ) + expect_equal(lubridate::tz(job$report_data(tz = "Asia/Shanghai")$datetime), + "Asia/Shanghai" + ) + expect_equal(job$report_data(case = "test")$case, rep("test", 3840)) + expect_equal(names(job$report_data(all = TRUE)), + c("case", "datetime", "month", "day", "hour", "minute", "dst", "interval", + "simulation_days", "day_type", "environment_name", + "environment_period_index", "is_meter", "type", "index_group", + "timestep_type", "key_value", "name", "reporting_frequency", + "schedule_name", "units", "value" + ) + ) + expect_equal(nrow(job$report_data(period = seq( + lubridate::ymd_hms("2019-01-14 0:0:0"), lubridate::ymd_hms("2019-01-15 0:0:0"), "15 min") + )), 1900) + expect_equal(nrow(job$report_data(month = 1)), 1920) + expect_equal(nrow(job$report_data(month = 1, hour = 1)), 80) + expect_equal(nrow(job$report_data(minute = 0)), 960) + expect_equal(nrow(job$report_data(interval = 15)), 3840) + expect_equal(nrow(job$report_data(simulation_days = 1)), 3840) + expect_equal(nrow(job$report_data(day_type = "Tuesday")), 3840) + expect_equal(nrow(job$report_data(environment_name = "WINTERDAY")), 1920) + + expect_true(job == job) + expect_false(job != job) + + skip_on_os("mac") + # can get path + expect_equal(job$path(), c(idf = example$idf, epw = example$epw)) + expect_equal(job$path("idf"), c(example$idf)) + expect_equal(job$path("epw"), c(example$epw)) + + # can get output dir + expect_equal(job$output_dir(), dirname(example$idf)) + + # can get output file path + expect_equal( + job$locate_output(".err"), + normalizePath(file.path(tempdir(), "5Zone_Transformer.err")) + ) + + clean_wd(example$idf) + unlink(c(example$idf, example$epw)) +}) diff --git a/tests/testthat/test-param.R b/tests/testthat/test-param.R new file mode 100644 index 000000000..503dd8c03 --- /dev/null +++ b/tests/testthat/test-param.R @@ -0,0 +1,281 @@ +context("Parametric metiods") + +test_that("Parametric methods", { + skip_on_cran() + eplusr_option(verbose_info = FALSE) + + if (!is_avail_eplus(8.8)) install_eplus(8.8) + + expect_error(param_job(empty_idf(8.8), NULL), class = "error_idf_not_local") + + example <- copy_example() + + param <- param_job(example$idf, example$epw) + + priv <- get_priv_env(param) + + # Seed and Weather {{{ + expect_is(param$seed(), "Idf") + expect_is(param$weather(), "Epw") + expect_null(param$models()) + # }}} + + # Measure {{{ + pa <- param_job(example$idf, NULL) + test <- function(x, y) x + param$apply_measure(test, 1:5) + expect_equal(names(param$models()), sprintf("test_%i", 1:5)) + param$apply_measure(function (x, y) x, 1:5) + expect_equal(names(param$models()), sprintf("case_%i", 1:5)) + + # set_infil_rate {{{ + set_infil_rate <- function (idf, infil_rate) { + + # validate input value + # this is optional, as validations will be made when setting values to `Idf` + stopifnot(is.numeric(infil_rate), infil_rate >= 0) + + if (!idf$is_valid_class("ZoneInfiltration:DesignFlowRate")) + stop("Input model does not have any object in class `ZoneInfiltration:DesignFlowRate`") + + ids <- idf$object_id("ZoneInfiltration:DesignFlowRate", simplify = TRUE) + val <- rep(list(list(design_flow_rate_calculation_method = "AirChanges/Hour", air_changes_per_hour = infil_rate)), length(ids)) + setattr(val, "names", paste0("..", ids)) + idf$set(val) + + idf + } + # }}} + # names are unique + param$apply_measure(set_infil_rate, seq(0, 4, by = 1), .names = rep("A", 5)) + expect_equal(names(priv$m_idfs), c("A", paste0("A_", 1:4))) + + # auto assign name + param$apply_measure(set_infil_rate, seq(0, 4, by = 1), .names = NULL) + expect_equal(length(priv$m_idfs), 5) + expect_equal(names(priv$m_idfs), paste0("set_infil_rate_", 1:5)) + expect_equal(unname(vlapply(priv$m_idfs, is_idf)), rep(TRUE, times = 5)) + # }}} + + # Models {{{ + expect_is(param$models(), "list") + expect_equal(length(param$models()), 5) + expect_equal(names(param$models()), paste0("set_infil_rate_", 1:5)) + expect_equal(unname(vlapply(priv$m_idfs, is_idf)), rep(TRUE, times = 5)) + # }}} + + # Save {{{ + # can preserve name + param$apply_measure(set_infil_rate, seq(0, 4, by = 1), .names = 1:5) + expect_equal(names(param$models()), as.character(1:5)) + expect_silent(paths <- param$save()) + expect_equal(paths, + data.table::data.table( + model = normalizePath(file.path(tempdir(), 1:5, paste0(1:5, ".idf"))), + weather = normalizePath(file.path(tempdir(), 1:5, basename(param$weather()$path()))) + ) + ) + + param$apply_measure(set_infil_rate, seq(0, 4, by = 1), .names = NULL) + expect_silent(paths <- param$save()) + expect_equal(paths, + data.table::data.table( + model = normalizePath(file.path(tempdir(), paste0("set_infil_rate_", 1:5), paste0("set_infil_rate_", 1:5, ".idf"))), + weather = normalizePath(file.path(tempdir(), paste0("set_infil_rate_", 1:5), basename(param$weather()$path()))) + ) + ) + expect_silent(paths <- param$save(separate = FALSE)) + expect_equal(paths, + data.table::data.table( + model = normalizePath(file.path(tempdir(), paste0("set_infil_rate_", 1:5, ".idf"))), + weather = normalizePath(file.path(tempdir(), basename(param$weather()$path()))) + ) + ) + # can save when no weather are provided + expect_silent(paths <- { + empty <- empty_idf(8.8) + empty$save(tempfile(fileext = ".idf")) + par <- param_job(empty, NULL) + par$apply_measure(function (idf, x) idf, 1:2, .names = 1:2) + par$save() + }) + expect_equal(paths, + data.table::data.table( + model = normalizePath(file.path(tempdir(), 1:2, paste0(1:2, ".idf"))), + weather = NA_character_ + ) + ) + # }}} + + # Run and Status {{{ + + # Can detect if models are modified before running + model2 <- param$models()$set_infil_rate_2 + model2$Output_Variable <- NULL + expect_warning(param$run(echo = FALSE), class = "warn_param_modified") + + dir_nms <- paste0("set_infil_rate_", 1:5) + param$apply_measure(set_infil_rate, seq(0, 4, by = 1), .names = NULL) + # can run the simulation and get status of simulation + expect_equal({param$run(dir = NULL, echo = FALSE); status <- param$status(); names(status)}, + c("run_before", "alive", "terminated", "successful", "changed_after", "job_status") + ) + expect_equal(status[c("run_before", "alive", "terminated", "successful", "changed_after")], + list(run_before = TRUE, alive = FALSE, terminated = FALSE, + successful = TRUE, changed_after = FALSE + ) + ) + expect_equal(names(status$job_status), + c("index", "status", "idf", "epw", "exit_status", "start_time", "end_time", + "energyplus", "output_dir", "stdout", "stderr" + ) + ) + # }}} + + # Report Data Dict {{{ + expect_is(param$report_data_dict(), "data.table") + expect_true(has_name(param$report_data_dict(), "case")) + expect_equal(nrow(param$report_data_dict(2)), 20) + expect_equal(nrow(param$report_data_dict("set_infil_rate_2")), 20) + # }}} + + # Tabular Data {{{ + expect_equal(nrow(param$tabular_data()), 6662 * 5) + expect_equal(nrow(param$tabular_data( + report_name = c( + "AnnualBuildingUtilityPerformanceSummary", + "Initialization Summary" + ))), + 3774 * 5 + ) + expect_equal(nrow(param$tabular_data(table_name = "Site and Source Energy")), 12 * 5) + expect_equal(nrow(param$tabular_data(column_name = "Total Energy")), 4 * 5) + expect_equal(nrow(param$tabular_data(row_name = "Total Site Energy")), 3 * 5) + expect_equal(nrow(param$tabular_data(2)), 6662) + expect_equal(nrow(param$tabular_data(2, + report_name = c( + "AnnualBuildingUtilityPerformanceSummary", + "Initialization Summary" + ))), + 3774 + ) + expect_equal(nrow(param$tabular_data(2, table_name = "Site and Source Energy")), 12) + expect_equal(nrow(param$tabular_data(2, column_name = "Total Energy")), 4) + expect_equal(nrow(param$tabular_data(2, row_name = "Total Site Energy")), 3) + expect_equal(nrow(param$tabular_data("set_infil_rate_2")), 6662) + expect_equal(nrow(param$tabular_data("set_infil_rate_2", + report_name = c( + "AnnualBuildingUtilityPerformanceSummary", + "Initialization Summary" + ))), + 3774 + ) + expect_equal(nrow(param$tabular_data("set_infil_rate_2", table_name = "Site and Source Energy")), 12) + expect_equal(nrow(param$tabular_data("set_infil_rate_2" ,column_name = "Total Energy")), 4) + expect_equal(nrow(param$tabular_data("set_infil_rate_2", row_name = "Total Site Energy")), 3) + # }}} + + # Report Data {{{ + expect_equal(nrow(param$report_data(2, param$report_data_dict())), 3840) + expect_equal(nrow(param$report_data(2)), 3840) + expect_equal(nrow(param$report_data(2, "")), 1344L) + expect_equal(nrow(param$report_data(2, + "TRANSFORMER 1", "Transformer Load Loss Rate")), + 192L + ) + expect_equal(nrow(param$report_data(2, + "TRANSFORMER 1", "Transformer Load Loss Rate")), + 192L + ) + expect_equal(year(param$report_data(2, + "TRANSFORMER 1", "Transformer Load Loss Rate", year = 2010)$datetime), + rep(2010, 192) + ) + expect_equal(lubridate::tz(param$report_data(2, tz = "Asia/Shanghai")$datetime), + "Asia/Shanghai" + ) + expect_equal(names(param$report_data(2, all = TRUE)), + c("case", "datetime", "month", "day", "hour", "minute", "dst", "interval", + "simulation_days", "day_type", "environment_name", + "environment_period_index", "is_meter", "type", "index_group", + "timestep_type", "key_value", "name", "reporting_frequency", + "schedule_name", "units", "value" + ) + ) + expect_equal(nrow(param$report_data(2, period = seq( + lubridate::ymd_hms("2019-01-14 0:0:0"), lubridate::ymd_hms("2019-01-15 0:0:0"), "15 min") + )), 1900) + expect_equal(nrow(param$report_data(2, month = 1)), 1920) + expect_equal(nrow(param$report_data(2, month = 1, hour = 1)), 80) + expect_equal(nrow(param$report_data(2, minute = 0)), 960) + expect_equal(nrow(param$report_data(2, interval = 15)), 3840) + expect_equal(nrow(param$report_data(2, simulation_days = 1)), 3840) + expect_equal(nrow(param$report_data(2, day_type = "Tuesday")), 3840) + expect_equal(nrow(param$report_data(2, environment_name = "WINTERDAY")), 1920) + + expect_equal(nrow(param$report_data(NULL, param$report_data_dict())), 3840 * 5) + expect_equal(nrow(param$report_data()), 3840 * 5) + expect_equal(nrow(param$report_data(NULL, "")), 1344L * 5) + expect_equal(nrow(param$report_data(NULL, + "TRANSFORMER 1", "Transformer Load Loss Rate")), + 192L * 5 + ) + expect_equal(nrow(param$report_data(NULL, + "TRANSFORMER 1", "Transformer Load Loss Rate")), + 192L * 5 + ) + expect_equal(year(param$report_data(NULL, + "TRANSFORMER 1", "Transformer Load Loss Rate", year = 2010)$datetime), + rep(2010, 192 * 5) + ) + expect_equal(lubridate::tz(param$report_data(NULL, tz = "Asia/Shanghai")$datetime), + "Asia/Shanghai" + ) + expect_equal(names(param$report_data(all = TRUE)), + c("case", "datetime", "month", "day", "hour", "minute", "dst", "interval", + "simulation_days", "day_type", "environment_name", + "environment_period_index", "is_meter", "type", "index_group", + "timestep_type", "key_value", "name", "reporting_frequency", + "schedule_name", "units", "value" + ) + ) + expect_equal(nrow(param$report_data(period = seq( + lubridate::ymd_hms("2019-01-14 0:0:0"), lubridate::ymd_hms("2019-01-15 0:0:0"), "15 min") + )), 1900 * 5) + expect_equal(nrow(param$report_data(month = 1)), 1920 * 5) + expect_equal(nrow(param$report_data(month = 1, hour = 1)), 80 * 5) + expect_equal(nrow(param$report_data(minute = 0)), 960 * 5) + expect_equal(nrow(param$report_data(interval = 15)), 3840 * 5) + expect_equal(nrow(param$report_data(simulation_days = 1)), 3840 * 5) + expect_equal(nrow(param$report_data(day_type = "Tuesday")), 3840 * 5) + expect_equal(nrow(param$report_data(environment_name = "WINTERDAY")), 1920 * 5) + # }}} + + # S3 {{{ + expect_true(param == param) + expect_false(param != param) + # }}} + + skip_on_os("mac") + # Locate Output {{{ + expect_equal(param$locate_output(suffix = ".sql"), + normalizePath(file.path(dirname(example$idf), dir_nms, paste0(dir_nms, ".sql")))) + expect_equal(param$locate_output(2, suffix = ".sql"), + normalizePath(file.path(dirname(example$idf), dir_nms[2], paste0(dir_nms[2], ".sql")))) + expect_equal(param$locate_output("set_infil_rate_2", suffix = ".sql"), + normalizePath(file.path(dirname(example$idf), dir_nms[2], paste0(dir_nms[2], ".sql")))) + # }}} + + # Output Dir {{{ + expect_equal(param$output_dir(), + normalizePath(file.path(dirname(example$idf), dir_nms))) + expect_equal(param$output_dir(2), + normalizePath(file.path(dirname(example$idf), dir_nms[2]))) + expect_equal(param$output_dir("set_infil_rate_2"), + normalizePath(file.path(dirname(example$idf), dir_nms[2]))) + # }}} + + # clean + lapply(dir_nms, unlink, recursive = TRUE, force = TRUE) + unlink(c(example$idf, example$epw)) +}) diff --git a/tests/testthat/test-parse.R b/tests/testthat/test-parse.R index b2abc93d7..8690c5c87 100644 --- a/tests/testthat/test-parse.R +++ b/tests/testthat/test-parse.R @@ -261,6 +261,115 @@ test_that("parse_idd_file()", { }) # }}} +# parse_idd_file("EPW.idd") {{{ +test_that("parse_idd_file()", { + expect_is(idd_parsed <- parse_idd_file(system.file("extdata/epw.idd", package = "eplusr"), epw = TRUE), "list") + + # can get Idd version + expect_equal(idd_parsed$version, as.numeric_version("1.0.0")) + + # can get Idd build + expect_equal(idd_parsed$build, "2020-07-20") + + # can parse group data + expect_equal(idd_parsed$group$group_id, 1:2) + expect_equal(idd_parsed$group$group_name, c("Header", "Data")) + + # can parse class index data + expect_equal(idd_parsed$class$class_id, 1:9) + expect_equal(idd_parsed$class$class_name, c( + "LOCATION", "DESIGN CONDITIONS", + "TYPICAL/EXTREME PERIODS", "GROUND TEMPERATURES", + "HOLIDAYS/DAYLIGHT SAVINGS","COMMENTS 1", + "COMMENTS 2", "DATA PERIODS", + "WEATHER DATA" + )) + expect_equal(idd_parsed$class$group_id, c(rep(1, 8), 2)) + + # can parse class property data + expect_equal(idd_parsed$class$format, rep("standard", 9)) + expect_equal(idd_parsed$class$min_fields, c(9, 1, 1, 1, 4, 0, 0, 6, 35)) + expect_equal(idd_parsed$class$num_fields, c(9, 69, 5, 17, 6, 1, 1, 6, 35)) + expect_equal(idd_parsed$class$last_required, c(9, 1, 1, 1, 4, 0, 0, 6, 35)) + expect_equal(idd_parsed$class$has_name, rep(FALSE, 9)) + expect_equal(idd_parsed$class$required_object, c(rep(TRUE, 8), FALSE)) + expect_equal(idd_parsed$class$unique_object, c(rep(TRUE, 8), FALSE)) + expect_equal(idd_parsed$class$num_extensible, c(0, 66, 4, 16, 2, 1, 1, 4, 0)) + expect_equal(idd_parsed$class$first_extensible, c(0, 4, 2, 2, 5, 1, 1, 3, 0)) + expect_equal(idd_parsed$class$num_extensible_group, c(0, 1, 1, 1, 1, 1, 1, 1, 0)) + + # can parse field index data + expect_equal(idd_parsed$field$field_id, 1:149) + + # can parse field property data + expect_is(fld <- idd_parsed$field[field_name == "Data Source and Uncertainty Flags"], "data.table") + expect_equal(fld$units, NA_character_) + expect_equal(fld$ip_units, NA_character_) + expect_equal(fld$is_name, FALSE) + expect_equal(fld$required_field, TRUE) + expect_equal(fld$extensible_group, 0L) + expect_equal(fld$type_enum, 4L) + expect_equal(fld$autosizable, FALSE) + expect_equal(fld$autocalculatable, FALSE) + expect_equal(fld$default_chr, NA_character_) + expect_equal(fld$default_num, NA_real_) + expect_equal(fld$choice, list(NULL)) + expect_equal(fld$has_range, FALSE) + expect_equal(fld$maximum, NA_real_) + expect_equal(fld$minimum, NA_real_) + expect_equal(fld$lower_incbounds, FALSE) + expect_equal(fld$upper_incbounds, FALSE) + expect_equal(fld$src_enum, 0L) + expect_equal(fld$has_exist, FALSE) + expect_equal(fld$exist_maximum, NA_real_) + expect_equal(fld$exist_minimum, NA_real_) + expect_equal(fld$exist_lower_incbounds, FALSE) + expect_equal(fld$exist_upper_incbounds, FALSE) + expect_equal(fld$missing_chr, NA_character_) + expect_equal(fld$missing_num, NA_real_) + + # can parse field property data + expect_is(fld <- idd_parsed$field[field_name == "Liquid Precipitation Depth"], "data.table") + expect_equal(fld$units, "mm") + expect_equal(fld$ip_units, NA_character_) + expect_equal(fld$is_name, FALSE) + expect_equal(fld$required_field, TRUE) + expect_equal(fld$extensible_group, 0L) + expect_equal(fld$type_enum, 2L) + expect_equal(fld$autosizable, FALSE) + expect_equal(fld$autocalculatable, FALSE) + expect_equal(fld$default_chr, "0.0") + expect_equal(fld$default_num, 0.0) + expect_equal(fld$choice, list(NULL)) + expect_equal(fld$has_range, TRUE) + expect_equal(fld$maximum, NA_real_) + expect_equal(fld$minimum, 0.0) + expect_equal(fld$lower_incbounds, TRUE) + expect_equal(fld$upper_incbounds, FALSE) + expect_equal(fld$src_enum, 0L) + expect_equal(fld$has_exist, TRUE) + expect_equal(fld$exist_maximum, 999) + expect_equal(fld$exist_minimum, 0) + expect_equal(fld$exist_lower_incbounds, TRUE) + expect_equal(fld$exist_upper_incbounds, TRUE) + expect_equal(fld$missing_chr, "999") + expect_equal(fld$missing_num, 999) + + # can parse field property data + expect_is(fld <- idd_parsed$field[field_name == "Dry Bulb Temperature"], "data.table") + expect_equal(fld$has_exist, TRUE) + expect_equal(fld$exist_maximum, 99.9) + expect_equal(fld$exist_minimum, -Inf) + expect_equal(fld$exist_lower_incbounds, FALSE) + expect_equal(fld$exist_upper_incbounds, TRUE) + expect_equal(fld$missing_chr, "99.9") + expect_equal(fld$missing_num, 99.9) + + # can ignore reference data + expect_equal(nrow(idd_parsed$reference), 0L) +}) +# }}} + # parse_idf_file() {{{ test_that("parse_idf_file()", { # get version {{{ diff --git a/tests/testthat/test-rdd.R b/tests/testthat/test-rdd.R new file mode 100644 index 000000000..476c052f8 --- /dev/null +++ b/tests/testthat/test-rdd.R @@ -0,0 +1,58 @@ +context("Rdd") + +test_that("Rdd", { + skip_on_cran() + if (!is_avail_eplus(8.8)) install_eplus(8.8) + + idf <- read_idf(example()) + job <- idf$run(NULL, dir = tempdir(), echo = FALSE) + + expect_silent(rdd <- job$read_rdd()) + expect_silent(mdd <- job$read_mdd()) + + expect_equal(names(rdd), c("index", "reported_time_step", "report_type", "variable", "units")) + expect_equal(names(mdd), c("index", "reported_time_step", "report_type", "variable", "units")) + expect_equal(attr(rdd, "eplus_version"), idf$version()) + expect_equal(attr(mdd, "eplus_version"), idf$version()) + + expect_error(rdd_to_load(rdd, reporting_frequency = "hour"), + class = "error_invalid_reporting_frequency" + ) + expect_error(mdd_to_load(mdd, reporting_frequency = "hour"), + class = "error_invalid_reporting_frequency" + ) + expect_error(rdd_to_load(rdd[1:2][, reporting_frequency := c(1, 2)]), + class = "error_invalid_reporting_frequency" + ) + expect_error(mdd_to_load(mdd[1:2][, reporting_frequency := c(1, 2)]), + class = "error_invalid_reporting_frequency" + ) + expect_error(mdd_to_load(mdd, class = "")) + + expect_equivalent(rdd_to_load(rdd[1L]), + data.table(id = 1L, class = "Output:Variable", index = 1:3, + field = c("Key Value", "Variable Name", "Reporting Frequency"), + value = c("*", "Site Outdoor Air Drybulb Temperature", "Timestep") + ) + ) + + expect_equivalent(rdd_to_load(rdd[1L][, key_value := "Environment"]), + data.table(id = 1L, class = "Output:Variable", index = 1:3, + field = c("Key Value", "Variable Name", "Reporting Frequency"), + value = c("Environment", "Site Outdoor Air Drybulb Temperature", "Timestep") + ) + ) + + expect_equivalent(mdd_to_load(mdd[1L]), + data.table(id = 1L, class = "Output:Meter", index = 1:2, + field = c("Key Name", "Reporting Frequency"), + value = c("Electricity:Facility", "Timestep") + ) + ) + expect_equivalent(mdd_to_load(mdd[1L], class = "Output:Meter:MeterFileOnly"), + data.table(id = 1L, class = "Output:Meter:MeterFileOnly", index = 1:2, + field = c("Key Name", "Reporting Frequency"), + value = c("Electricity:Facility", "Timestep") + ) + ) +}) diff --git a/tests/testthat/test-reload.R b/tests/testthat/test-reload.R new file mode 100644 index 000000000..b045e0293 --- /dev/null +++ b/tests/testthat/test-reload.R @@ -0,0 +1,83 @@ +context("Reload") + +# Reload {{{ +test_that("Reload", { + eplusr_option(verbose_info = FALSE) + if (!is_avail_eplus(8.8)) install_eplus(8.8) + + example <- copy_example() + + idf <- read_idf(example$idf) + epw <- read_epw(example$epw) + job <- idf$run(NULL, tempdir(), echo = FALSE) + grp <- group_job(idf, NULL)$run(tempdir()) + par <- param_job(idf, NULL) + par$apply_measure(function (x, y) x, 1:2) + par$run(tempdir()) + + f_idf <- tempfile(fileext = ".rds") + f_epw <- tempfile(fileext = ".rds") + f_job <- tempfile(fileext = ".rds") + f_grp <- tempfile(fileext = ".rds") + f_par <- tempfile(fileext = ".rds") + saveRDS(idf, f_idf) + saveRDS(epw, f_epw) + saveRDS(job, f_job) + saveRDS(grp, f_grp) + saveRDS(par, f_par) + + idf <- readRDS(f_idf) + epw <- readRDS(f_epw) + job <- readRDS(f_job) + grp <- readRDS(f_grp) + par <- readRDS(f_par) + + expect_equal(data.table::truelength(get_priv_env(idf)$idd_env()$group), 0L) + expect_equal(data.table::truelength(get_priv_env(idf)$idd_env()$class), 0L) + expect_equal(data.table::truelength(get_priv_env(idf)$idd_env()$field), 0L) + expect_equal(data.table::truelength(get_priv_env(idf)$idd_env()$reference), 0L) + expect_equal(data.table::truelength(get_priv_env(idf)$idf_env()$object), 0L) + expect_equal(data.table::truelength(get_priv_env(idf)$idf_env()$value), 0L) + expect_equal(data.table::truelength(get_priv_env(idf)$idf_env()$reference), 0L) + expect_equal(data.table::truelength(get_priv_env(epw)$m_header$typical), 0L) + expect_equal(data.table::truelength(get_priv_env(epw)$m_header$ground), 0L) + expect_equal(data.table::truelength(get_priv_env(epw)$m_header$holiday$holiday), 0L) + expect_equal(data.table::truelength(get_priv_env(epw)$m_header$period$period), 0L) + expect_equal(data.table::truelength(get_priv_env(epw)$m_data), 0L) + + expect_silent(reload(idf)) + expect_silent(reload(epw)) + expect_silent(reload(job)) + expect_silent(reload(grp)) + expect_silent(reload(par)) + + expect_idf_reloaded <- function (idf) { + expect_true(data.table::truelength(get_priv_env(idf)$idd_env()$group) > 0L) + expect_true(data.table::truelength(get_priv_env(idf)$idd_env()$class) > 0L) + expect_true(data.table::truelength(get_priv_env(idf)$idd_env()$field) > 0L) + expect_true(data.table::truelength(get_priv_env(idf)$idd_env()$reference) > 0L) + expect_true(data.table::truelength(get_priv_env(idf)$idf_env()$object) > 0L) + expect_true(data.table::truelength(get_priv_env(idf)$idf_env()$value) > 0L) + expect_true(data.table::truelength(get_priv_env(idf)$idf_env()$reference) > 0L) + } + + expect_true(data.table::truelength(get_priv_env(epw)$m_header$typical) > 0L) + expect_true(data.table::truelength(get_priv_env(epw)$m_header$ground) > 0L) + expect_true(data.table::truelength(get_priv_env(epw)$m_header$holiday$holiday) > 0L) + expect_true(data.table::truelength(get_priv_env(epw)$m_header$period$period) > 0L) + expect_true(data.table::truelength(get_priv_env(epw)$m_data) > 0L) + + expect_idf_reloaded(idf) + expect_idf_reloaded(get_priv_env(job)$m_idf) + expect_idf_reloaded(get_priv_env(par)$m_seed) + lapply(get_priv_env(grp)$m_idfs, expect_idf_reloaded) + lapply(get_priv_env(par)$m_idfs, expect_idf_reloaded) + expect_true(data.table::truelength(get_priv_env(grp)$m_job) > 0L) + expect_true(data.table::truelength(get_priv_env(par)$m_job) > 0L) + + expect_true(job$status()$successful) + expect_true(grp$status()$successful) + expect_true(par$status()$successful) + +}) +# }}} diff --git a/tests/testthat/test-sql.R b/tests/testthat/test-sql.R new file mode 100644 index 000000000..393bcfecc --- /dev/null +++ b/tests/testthat/test-sql.R @@ -0,0 +1,164 @@ +context("Sql methods") + +test_that("Sql methods", { + skip_on_cran() + if (!is_avail_eplus(8.8)) install_eplus(8.8) + + example <- copy_example() + idf <- read_idf(example$idf) + + expect_is(job <- read_idf(example$idf)$run(example$epw, NULL, echo = FALSE), "EplusJob") + expect_silent(sql <- eplus_sql(job$locate_output(".sql"))) + + # path + expect_equal(sql$path(), normalizePath(file.path(tempdir(), "5Zone_Transformer.sql"))) + expect_equal(sql$path_idf(), normalizePath(file.path(tempdir(), "5Zone_Transformer.idf"))) + + # can get all table names + expect_equal(length(sql$list_table()), 44L) + + # can read table + expect_error(sql$read_table("a"), "no such table") + expect_is(sql$read_table("Zones"), "data.table") + + # can read report data dictionary + expect_is(sql$report_data_dict(), "data.table") + + # can read report data + expect_equal(nrow(sql$report_data(sql$report_data_dict())), 3840L) + expect_equal(nrow(sql$report_data()), 3840L) + expect_equal(nrow(sql$report_data("")), 1344L) + expect_equal(nrow(sql$report_data( + "TRANSFORMER 1", "Transformer Load Loss Rate")), + 192L + ) + expect_equal(nrow(sql$report_data( + "TRANSFORMER 1", "Transformer Load Loss Rate")), + 192L + ) + expect_equal(year(sql$report_data( + "TRANSFORMER 1", "Transformer Load Loss Rate", year = 2010)$datetime), + rep(2010, 192) + ) + expect_equal(lubridate::tz(sql$report_data(tz = "Asia/Shanghai")$datetime), + "Asia/Shanghai" + ) + expect_equal(sql$report_data(case = "test")$case, rep("test", 3840)) + expect_equal(names(sql$report_data(all = TRUE)), + c("case", "datetime", "month", "day", "hour", "minute", "dst", "interval", + "simulation_days", "day_type", "environment_name", + "environment_period_index", "is_meter", "type", "index_group", + "timestep_type", "key_value", "name", "reporting_frequency", + "schedule_name", "units", "value" + ) + ) + expect_equal(nrow(sql$report_data(period = seq( + lubridate::ymd_hms("2019-01-14 0:0:0"), lubridate::ymd_hms("2019-01-15 0:0:0"), "15 min") + )), 1900) + expect_equal(nrow(sql$report_data(month = 1)), 1920) + expect_equal(nrow(sql$report_data(month = 1, hour = 1)), 80) + expect_equal(nrow(sql$report_data(minute = 0)), 960) + expect_equal(nrow(sql$report_data(interval = 15)), 3840) + expect_equal(nrow(sql$report_data(simulation_days = 1)), 3840) + expect_equal(nrow(sql$report_data(day_type = "Tuesday")), 3840) + expect_equal(nrow(sql$report_data(day_type = "normalday")), 3840) + expect_equal(nrow(sql$report_data(day_type = "designday")), 0) + expect_equal(nrow(sql$report_data(environment_name = "WINTERDAY")), 1920) + + expect_equal(nrow(sql$tabular_data()), 6662) + expect_equal(nrow(sql$tabular_data( + report_name = c( + "AnnualBuildingUtilityPerformanceSummary", + "Initialization Summary" + ))), + 3774 + ) + expect_equal(nrow(sql$tabular_data(table_name = "Site and Source Energy")), 12) + expect_equal(nrow(sql$tabular_data(column_name = "Total Energy")), 4) + expect_equal(nrow(sql$tabular_data(row_name = "Total Site Energy")), 3) + # can convert to wide table + expect_silent(tab <- sql$tabular_data(row_name = "Total Site Energy", wide = TRUE, case = NULL)) + expect_equal(names(tab), "AnnualBuildingUtilityPerformanceSummary.Entire Facility.Site and Source Energy") + expect_equivalent( + read_idf(file.path(eplus_config(8.8)$dir, "ExampleFiles/1ZoneUncontrolled.idf"))$ + run(NULL, tempdir(), echo = FALSE)$ + tabular_data(table_name = "Site and Source Energy", wide = TRUE)[[1]][ + , lapply(.SD, class)], + data.table( + case = "character", + report_name = "character", + report_for = "character", + table_name = "character", + row_name = "character", + `Total Energy [GJ]` = "numeric", + `Energy Per Total Building Area [MJ/m2]` = "numeric", + `Energy Per Conditioned Building Area [MJ/m2]` = "numeric" + ) + ) + expect_equivalent(tab[[1L]][, lapply(.SD, class)], + data.table( + report_name = "character", + report_for = "character", + table_name = "character", + row_name = "character", + `Total Energy [GJ]` = "numeric", + `Energy Per Total Building Area [MJ/m2]` = "numeric", + `Energy Per Conditioned Building Area [MJ/m2]` = "numeric" + ) + ) + + skip_on_os("mac") + # can get path + expect_equal(sql$path(), job$locate_output(".sql")) + clean_wd(example$idf) + unlink(c(example$idf, example$epw)) + + skip_on_travis() + skip_on_appveyor() + # can handle multiple time resolution + example <- copy_example() + all_freq <- c("Detailed", "Timestep", "Hourly", "Daily", "Monthly", + "RunPeriod", "Environment", "Annual" + ) + idf <- read_idf(example$idf) + job <- idf$run(NULL, echo = FALSE) + # remove original run periods + idf$RunPeriod <- NULL + # define new run periods + idf$add(RunPeriod = list("Long", 1, 1, 12, 31), RunPeriod = list("Short", 7, 1, 8, 15)) + + # add new output variables to cover all possible report frequency + idf$`Output:Variable` <- NULL + idf$`Output:Meter:MeterFileOnly` <- NULL + rdd <- job$read_rdd()[seq_along(all_freq)][, reporting_frequency := all_freq] + mdd <- job$read_mdd()[seq_along(all_freq)][, reporting_frequency := all_freq] + idf$load(rdd_to_load(rdd)) + idf$load(mdd_to_load(mdd)) + + # save as temp file + idf$save(tempfile(fileext = ".idf")) + # run with weather file + job <- idf$run(example$epw, echo = FALSE) + + res1 <- job$report_data(wide = TRUE) + res2 <- job$report_data(all = TRUE, wide = TRUE) + expect_equal(nrow(res1), nrow(res2)) + + jobs <- lapply(all_freq, function (freq) { + idf$`Output:Variable`<- NULL + + dt <- idf$to_table(class = "Output:Meter") + dt[index == 2L, value := freq] + idf$update(dt) + + idf$save(tempfile(fileext = ".idf")) + + idf$run(NULL, echo = FALSE) + }) + + expect_silent(data_all <- lapply(jobs, function (job) get_sql_report_data(job$locate_output(".sql"), all = TRUE))) + expect_silent(data_wide <- lapply(jobs, function (job) get_sql_report_data(job$locate_output(".sql"), all = TRUE, wide = TRUE))) + + clean_wd(example$idf) + unlink(c(example$idf, example$epw)) +}) diff --git a/tests/testthat/test-units.R b/tests/testthat/test-units.R new file mode 100644 index 000000000..fc46ea776 --- /dev/null +++ b/tests/testthat/test-units.R @@ -0,0 +1,124 @@ +test_that("Units conversion", { + expect_silent(reg_custom_units()) + + expect_equal(units::set_units(1, "person") + units::set_units(1, "person"), + units::set_units(2, "person") + ) + expect_equal(units::set_units(1, "dollar") + units::set_units(1, "dollar"), + units::set_units(2, "dollar") + ) + expect_equal(units::set_units(1, "Wh") + units::set_units(3600, "J"), + units::set_units(2, "Wh") + ) + expect_equal(units::set_units(units::set_units(1, "inH2O"), "inch_H2O_39F"), + units::set_units(1, "inch_H2O_39F") + ) + + expect_equal(NULL %||% 1, 1) + expect_equal(1 %||% 2, 1) + + expect_equal(collapse(1:3), "'1', '2' and '3'") + expect_equal(collapse(1:3, out = NULL), "1, 2 and 3") + expect_equal(collapse(1, out = NULL), "1") + expect_equal(collapse(1:3, or = NULL), "'1', '2', '3'") + expect_equal(collapse(1:3, or = TRUE), "'1', '2' or '3'") + + expect_equal(surround(1:3), c("'1'", "'2'", "'3'")) + expect_equal(surround(1:3, out = NULL), as.character(1:3)) + + expect_null(rpad(NULL)) + expect_equal(rpad(c(1, 10)), c("1 ", "10")) + expect_equal(rpad(c(1, 10), width = 3), c("1 ", "10 ")) + + expect_null(lpad(NULL)) + expect_equal(lpad(c(1, 10)), c(" 1", "10")) + expect_equal(lpad(c(1, 10), width = 3), c(" 1", " 10")) + + expect_error(read_lines(NULL), "Failed to read input file") + expect_equal(read_lines("a\n b \n c \n"), data.table(line = 1:3, string = c("a", "b", "c"))) + + f <- tempfile() + expect_silent(write_lines(read_lines("a\nb"), f)) + expect_equal(read_lines(f), data.table(line = 1:2, string = c("a", "b"))) + expect_silent(write_lines(c("a", "b"), f)) + expect_equal(read_lines(f), data.table(line = 1:2, string = c("a", "b"))) + expect_silent(write_lines(c("c", "d"), f, append = TRUE)) + expect_equal(read_lines(f), data.table(line = 1:4, string = c("a", "b", "c", "d"))) + expect_error(write_lines(1:3, f), "Must be of type 'character'") + + expect_equal(standardize_ver("latest"), numeric_version("9.2.0")) + expect_equal(standardize_ver("latest", strict = TRUE), numeric_version(NA, strict = FALSE)) + expect_equal(standardize_ver(c(1, 1.1)), numeric_version(c("1.0.0", "1.1.0"))) + expect_equal(standardize_ver(c(1, 1.1), complete = FALSE), numeric_version(c("1.0", "1.1"))) + expect_equal(standardize_ver(c("1.0", "1.1.0.01")), numeric_version(c("1.0.0", "1.1.0"))) + expect_equal(standardize_ver(c("1.0", "1.1.0.01"), complete = FALSE), numeric_version(c("1.0", "1.1.0"))) + + expect_error(match_minor_ver(1), "numeric_version") + expect_error(match_minor_ver(numeric_version(1:2)), "length 1") + expect_equal(match_minor_ver(numeric_version("0.0"), ALL_IDD_VER), numeric_version(NA, strict = FALSE)) + expect_equal(match_minor_ver(numeric_version("9.1"), ALL_IDD_VER), numeric_version("9.1.0")) + expect_equal(match_minor_ver(numeric_version("9.0"), ALL_IDD_VER), numeric_version("9.0.1")) + + expect_equal(vec_depth(NULL), 0L) + expect_equal(vec_depth(character()), 1L) + expect_equal(vec_depth(list()), 1L) + expect_equal(vec_depth(list(list())), 2L) + expect_equal(vec_depth(list(list(NULL))), 2L) + expect_equal(vec_depth(list(list(1))), 3L) + expect_error(vec_depth(environment()), "must be a vector") + + expect_equal(vlapply(1:3, is.integer), rep(TRUE, 3L)) + expect_equal(vlapply(setNames(1:3, c("a", "b", "c")), is.integer), setNames(rep(TRUE, 3L), c("a", "b", "c"))) + expect_equal(vlapply(setNames(1:3, c("a", "b", "c")), is.integer, use.names = FALSE), rep(TRUE, 3L)) + + expect_equal(viapply(1:3, length), rep(1L, 3L)) + expect_equal(viapply(setNames(1:3, c("a", "b", "c")), length), setNames(rep(1L, 3L), c("a", "b", "c"))) + expect_equal(viapply(setNames(1:3, c("a", "b", "c")), length, use.names = FALSE), rep(1L, 3L)) + + expect_equal(vcapply(1:3, paste), as.character(1:3)) + expect_equal(vcapply(setNames(1:3, c("a", "b", "c")), paste), setNames(as.character(1:3), c("a", "b", "c"))) + expect_equal(vcapply(setNames(1:3, c("a", "b", "c")), paste, use.names = FALSE), as.character(1:3)) + + expect_equal(apply2(1:3, 4:6, "+"), list(5L, 7L, 9L)) + expect_equal(apply2_int(1:3, 4:6, "+"), c(5L, 7L, 9L)) + expect_equal(apply2_lgl(1:3, 4:6, ">"), rep(FALSE, 3L)) + expect_equal(apply2_chr(1:3, 4:6, paste0), c("14", "25", "36")) + + expect_equal(underscore_name("Class Name"), "Class_Name") + expect_equal(underscore_name("Class:Name"), "Class_Name") + expect_equal(lower_name("Class:Name"), "class_name") + expect_equal(lower_name("Class Name"), "class_name") + + expect_equal(make_filename(c("", "")), c("_a____", "_a_____1")) + expect_equal(make_filename(c("", ""), unique = FALSE), c("_a____", "_a____")) + + expect_equal(names2(1:3), rep(NA_character_, 3)) + expect_equal(names2(c(a = 1, 2)), c("a", NA_character_)) + + expect_equal(each_length(list(1, 2:3)), c(1L, 2L)) + + expect_equal(ranger()[], list(minimum = -Inf, lower_incbounds = FALSE, maximum = Inf, upper_incbounds = FALSE)) + expect_equal(format(ranger()), "(-Inf, Inf)") + expect_equal(ranger(1, TRUE)[], list(minimum = 1, lower_incbounds = TRUE, maximum = Inf, upper_incbounds = FALSE)) + expect_equal(format(ranger(1, TRUE)), "[1, Inf)") + + expect_error(append_dt(data.table(a = 1), data.table())) + expect_equal(append_dt(data.table(), data.table()), data.table()) + expect_equal(append_dt(data.table(a = 1), data.table(a = 2, b = 1)), data.table(a = c(1, 2))) + expect_equal(append_dt(data.table(a = 1, b = 1), data.table(a = c(1, 2), b = c(3, 4)), "a"), data.table(a = c(1, 2), b = c(3, 4))) + + expect_equal(fmt_dbl(1.111), "1.11") + expect_equal(fmt_dbl(1.111, 1), "1.1") + expect_equal(fmt_int(1), "1.0") + expect_equal(fmt_int(1, 0), "1") + + expect_equal(wday(as.Date("2020-01-01")), 3L) + expect_equal(as.character(wday(as.Date("2020-01-01"), label = TRUE)), "Wednesday") + + expect_equal(str_trunc("abcdefghij", 10), "abcde...") + + expect_equal(match_in_vec("a", LETTERS), 1L) + expect_equal(match_in_vec("a", LETTERS, "aa"), 1L) + expect_equal(match_in_vec("a", LETTERS, "aa", label = TRUE), "A") + expect_equal(match_in_vec("aa", LETTERS, "aa", label = TRUE), "A") +}) diff --git a/tests/testthat/test-validate.R b/tests/testthat/test-validate.R new file mode 100644 index 000000000..f03d1c40a --- /dev/null +++ b/tests/testthat/test-validate.R @@ -0,0 +1,256 @@ +context("validate") + +# VALIDTATE {{{ +test_that("Validate method", { + idf <- read_idf(example(), use_idd(8.8, "auto")) + idf_env <- get_priv_env(idf)$m_idf_env + idd_env <- get_priv_env(idf)$idd_env() + + expect_is(empty_validity(), "IdfValidity") + expect_equal(names(empty_validity()), + 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" + ) + ) + + + # MISSING OBJECT {{{ + env_in <- parse_idf_file(text("idf", 8.8)) + expect_equal( + check_missing_object(idd_env, idf_env, env_in)$validity$missing_object, + c("Building", "GlobalGeometryRules") + ) + ids <- get_idd_class(idd_env, c("Building", "GlobalGeometryRules"))$class_id + expect_equal( + check_missing_object(idd_env, idf_env, list(object = list(class_id = ids)))$validity$missing_object, + character(0) + ) + # }}} + + # DUPLICATE OBJECT {{{ + env_in <- list2env(parse_idf_file(text("idf", 8.8))) + env_in$validity <- empty_validity() + expect_equal(nrow(check_duplicate_object(idd_env, idf_env, env_in)$validity$duplicate_object), 0L) + env_in$object <- rbindlist(list( + env_in$object, + data.table( + object_id = 6:7, object_name = c("Bld", "Bld"), + object_name_lower = c("bld", "bld"), + class_id = get_idd_class(idd_env, "Building")$class_id, + comment = list(NULL, NULL) + ) + ), use.names = TRUE) + env_in$value <- rbindlist(list( + env_in$value, + data.table( + object_id = 6:7, + object_name = "Bld", + class_id = get_idd_class(idd_env, "Building")$class_id, + class_name = "Building", + field_id = get_idd_field(idd_env, "Building", "Name")$field_id, + field_index = 1L, + field_name = "Name", + units = NA_character_, + ip_units = NA_character_, + type_enum = IDDFIELD_TYPE$alpha, + value_id = 45:46, + value_chr = "Bld", + value_num = NA_real_ + ) + ), fill = TRUE) + expect_equal(check_duplicate_object(idd_env, idf_env, env_in)$validity$duplicate_object$object_id, + c(6L, 7L) + ) + # }}} + + # CONFLICT NAME {{{ + env_in <- list2env(parse_idf_file(text("idf", 8.8))) + env_in$validity <- empty_validity() + env_in$check_whole <- TRUE + expect_equal(nrow(check_conflict_name(idd_env, idf_env, env_in)$validity$conflict_name), 0L) + env_in$object <- rbindlist(list( + env_in$object, + data.table( + object_id = 6:7, object_name = "Bld", + object_name_lower = "bld", + class_id = get_idd_class(idd_env, "Building")$class_id, + comment = list(NULL, NULL) + ) + ), use.names = TRUE) + env_in$value <- rbindlist(list( + env_in$value, + data.table( + object_id = 6:7, + object_name = c("Bld", "Bld"), + class_id = rep(get_idd_class(idd_env, "Building")$class_id, 2), + class_name = rep("Building", 2), + field_id = rep(get_idd_field(idd_env, "Building", "Name")$field_id, 2), + field_index = rep(1L, 2), + field_name = rep("Name", 2), + units = rep(NA_character_, 2), + ip_units = rep(NA_character_, 2), + type_enum = rep(IDDFIELD_TYPE$alpha, 2), + value_id = 45:46, + value_chr = c("Bld", "Bld"), + value_num = rep(NA_real_, 2) + ) + ), fill = TRUE) + expect_equal(check_conflict_name(idd_env, idf_env, env_in)$validity$conflict_name$object_id, + c(6L, 7L) + ) + # }}} + + # INCOMPLETE EXTENSIBLE {{{ + env_in <- list2env(parse_idf_file(text("idf", 8.8))) + env_in$validity <- empty_validity() + add_joined_cols(env_in$object, env_in$value, "object_id", c("class_id", "object_name")) + add_class_property(idd_env, env_in$value, c("class_id", "class_name")) + add_field_property(idd_env, env_in$value, c("extensible_group", "field_index", "field_name", "units", "ip_units", "type_enum")) + expect_equal(nrow(check_incomplete_extensible(idd_env, idf_env, env_in)$validity$incomplete_extensible), 0L) + invisible(env_in$value[extensible_group == 3L, value_chr := NA_character_]) + expect_silent({err <- check_incomplete_extensible(idd_env, idf_env, env_in)$validity$incomplete_extensible}) + expect_equal(err$object_id, rep(3L, 3)) + expect_equal(err$field_index, 17:19) + expect_equal(err$value_id, 31:33) + # }}} + + # MISSING VALUE {{{ + env_in <- list2env(parse_idf_file(text("idf", 8.8))) + env_in$validity <- empty_validity() + add_joined_cols(env_in$object, env_in$value, "object_id", c("class_id", "object_name")) + add_class_property(idd_env, env_in$value, c("class_id", "class_name")) + add_field_property(idd_env, env_in$value, c("required_field", "field_index", "field_name", "units", "ip_units", "type_enum")) + invisible(env_in$value[J(c(1L, 10L, 15L)), on = "value_id", value_chr := NA_character_]) + + expect_silent({mis <- check_missing_value(idd_env, idf_env, env_in)$validity$missing_value}) + expect_equal(mis$object_id, 1:3) + expect_equal(mis$value_id, c(1L, 10L, 15L)) + # }}} + + # INVALID AUTOSIZE {{{ + env_in <- list2env(parse_idf_file(text("idf", 8.8))) + env_in$validity <- empty_validity() + add_joined_cols(env_in$object, env_in$value, "object_id", c("class_id", "object_name")) + add_class_property(idd_env, env_in$value, c("class_id", "class_name")) + add_field_property(idd_env, env_in$value, c("autosizable", "field_index", "field_name", "units", "ip_units", "type_enum")) + invisible(env_in$value[field_name == "Name", value_chr := "autosize"]) + set(env_in$value, NULL, "value_lower", stri_trans_tolower(env_in$value$value_chr)) + + expect_silent({autosize <- check_invalid_autosize(idd_env, idf_env, env_in)$validity$invalid_autosize}) + expect_equal(autosize$object_id, 1:4) + expect_equal(autosize$field_index, rep(1L, 4L)) + expect_equal(autosize$value_id, c(1L, 10L, 15L, 40L)) + # }}} + + # INVALID AUTOCALCULATE {{{ + env_in <- list2env(parse_idf_file(text("idf", 8.8))) + env_in$validity <- empty_validity() + add_joined_cols(env_in$object, env_in$value, "object_id", c("class_id", "object_name")) + add_class_property(idd_env, env_in$value, c("class_id", "class_name")) + add_field_property(idd_env, env_in$value, c("autocalculatable", "field_index", "field_name", "units", "ip_units", "type_enum")) + invisible(env_in$value[field_name == "Name", value_chr := "autocalculate"]) + set(env_in$value, NULL, "value_lower", stri_trans_tolower(env_in$value$value_chr)) + + expect_silent({autocal <- check_invalid_autocalculate(idd_env, idf_env, env_in)$validity$invalid_autocalculate}) + expect_equal(autocal$object_id, 1:4) + expect_equal(autocal$field_index, rep(1L, 4L)) + expect_equal(autocal$value_id, c(1L, 10L, 15L, 40L)) + # }}} + + # INVALID CHARACTER {{{ + env_in <- list2env(parse_idf_file(text("idf", 8.8))) + env_in$validity <- empty_validity() + add_joined_cols(env_in$object, env_in$value, "object_id", c("class_id", "object_name")) + add_class_property(idd_env, env_in$value, c("class_id", "class_name")) + add_field_property(idd_env, env_in$value, c("field_index", "field_name", "units", "ip_units", "type_enum")) + invisible(env_in$value[field_name == "Name", `:=`(value_chr = "1", value_num = 1L)]) + + expect_silent({chr <- check_invalid_character(idd_env, idf_env, env_in)$validity$invalid_character}) + expect_equal(chr$object_id, 1:4) + expect_equal(chr$field_index, rep(1L, 4L)) + expect_equal(chr$value_id, c(1L, 10L, 15L, 40L)) + # }}} + + # INVALID NUMERIC {{{ + env_in <- list2env(parse_idf_file(text("idf", 8.8))) + env_in$validity <- empty_validity() + add_joined_cols(env_in$object, env_in$value, "object_id", c("class_id", "object_name")) + add_class_property(idd_env, env_in$value, c("class_id", "class_name")) + add_field_property(idd_env, env_in$value, c("field_index", "field_name", "units", "ip_units", "type_enum")) + invisible(env_in$value[object_id == 1L & type_enum <= IDDFIELD_TYPE$real, `:=`(value_num = NA_real_)]) + + expect_silent({num <- check_invalid_numeric(idd_env, idf_env, env_in)$validity$invalid_numeric}) + expect_equal(num$object_id, c(rep(1L, 7), rep(3L, 3))) + expect_equal(num$value_id, c(3:9, 37:39)) + # }}} + + # INVALID INTEGER {{{ + env_in <- list2env(parse_idf_file(text("idf", 8.8))) + env_in$validity <- empty_validity() + add_joined_cols(env_in$object, env_in$value, "object_id", c("class_id", "object_name")) + add_class_property(idd_env, env_in$value, c("class_id", "class_name")) + add_field_property(idd_env, env_in$value, c("field_index", "field_name", "units", "ip_units", "type_enum")) + + invisible(env_in$value[object_id == 1L & type_enum == IDDFIELD_TYPE$real, `:=`(type_enum = IDDFIELD_TYPE$integer)]) + expect_silent({int <- check_invalid_integer(idd_env, idf_env, env_in)$validity$invalid_integer}) + expect_equal(int$object_id, rep(1L, 5)) + expect_equal(int$value_id, c(3L, 4L, 7:9)) + # }}} + + # INVALID CHOICE {{{ + env_in <- list2env(parse_idf_file(text("idf", 8.8))) + env_in$validity <- empty_validity() + add_joined_cols(env_in$object, env_in$value, "object_id", c("class_id", "object_name")) + add_class_property(idd_env, env_in$value, c("class_id", "class_name")) + add_field_property(idd_env, env_in$value, c("choice", "field_index", "field_name", "units", "ip_units", "type_enum")) + invisible(env_in$value[object_id == 1L & type_enum == IDDFIELD_TYPE$choice, value_chr := "wrong"]) + set(env_in$value, NULL, "value_lower", stri_trans_tolower(env_in$value$value_chr)) + + expect_silent({cho <- check_invalid_choice(idd_env, idf_env, env_in)$validity$invalid_choice}) + expect_equal(cho$object_id, 1L) + expect_equal(cho$value_id, 2L) + # }}} + + # INVALID RANGE {{{ + env_in <- list2env(parse_idf_file(text("idf", 8.8))) + env_in$validity <- empty_validity() + add_joined_cols(env_in$object, env_in$value, "object_id", c("class_id", "object_name")) + add_class_property(idd_env, env_in$value, c("class_id", "class_name")) + add_field_property(idd_env, env_in$value, + c("has_range", "maximum", "minimum", "lower_incbounds", "upper_incbounds", + "field_index", "field_name", "units", "ip_units", "type_enum") + ) + invisible(env_in$value[value_id == 3L, value_num := -1]) + + expect_silent({ran <- check_invalid_range(idd_env, idf_env, env_in)$validity$invalid_range}) + expect_equal(ran$object_id, 1L) + expect_equal(ran$value_id, 3L) + # }}} + + # INVALID REFERENCE {{{ + env_in <- list2env(parse_idf_file(text("idf", 8.8))) + env_in$validity <- empty_validity() + env_in$check_whole <- TRUE + add_joined_cols(env_in$object, env_in$value, "object_id", c("class_id", "object_name")) + add_class_property(idd_env, env_in$value, c("class_id", "class_name")) + add_field_property(idd_env, env_in$value, + c("src_enum", "field_index", "field_name", "units", "ip_units", "type_enum") + ) + + expect_silent({ref <- check_invalid_reference(idd_env, env_in, env_in)$validity$invalid_reference}) + expect_equal(ref$object_id, c(rep(2L, 3), rep(3L, 2))) + expect_equal(ref$value_id, c(12:14, 18L, 20L)) + # }}} +}) +# }}} diff --git a/tests/testthat/test_epw.R b/tests/testthat/test_epw.R deleted file mode 100644 index ed7cac856..000000000 --- a/tests/testthat/test_epw.R +++ /dev/null @@ -1,220 +0,0 @@ -test_that("Epw class", { - # clean temp dir - clean_tempdir() - eplusr_option(verbose_info = FALSE) - - skip_on_cran() - if (!is_avail_eplus(8.8)) install_eplus(8.8) - path_epw <- file.path(eplus_config(8.8)$dir, "WeatherData", "USA_CA_San.Francisco.Intl.AP.724940_TMY3.epw") - - expect_silent(epw <- read_epw(path_epw)) - - # can save the file - expect_silent(epw$save(file.path(tempdir(), "weather.epw"))) - - # can update the path after saved - expect_equal(epw$path(), file.path(tempdir(), "weather.epw")) - - # can read local EPW file - expect_silent(epw <- read_epw(file.path(tempdir(), "weather.epw"))) - - expect_equal( - epw$location(city = "Chongqing", state_province = "Chongqing", country = "China", - data_source = "TMY", wmo_number = "724944", latitude = 20.0, - longitude = -120.0, time_zone = 8L, elevation = 100 - ), - list(city = "Chongqing", - state_province = "Chongqing", - country = "China", - data_source = "TMY", - wmo_number = "724944", - latitude = 20.0, - longitude = -120.0, - time_zone = 8L, - elevation = 100 - ) - ) - expect_equal(epw$location(city = "chongqing")$city, "chongqing") - expect_error(epw$location(city = 1), class = "error_invalid_epw_header_location_type") - - expect_is(epw$design_condition(), "list") - expect_equal(names(epw$design_condition()), c("source", "heating", "cooling", "extremes")) - epw$typical_extreme_period() - epw$ground_temperature() - expect_is(epw$holiday(), "list") - expect_error(epw$holiday(TRUE), class = "error_invalid_epw_header_leapyear") - expect_equal(epw$holiday(dst = c(1, 2))$dst, epw_date(1:2)) - expect_equal(epw$holiday(dst = c(as.Date("2008-01-01"), as.Date("2008-02-01")))$dst, epw_date(c("Jan 01", "Feb 01"))) - expect_is(epw$comment1(), "character") - expect_equal(epw$comment1("comment1"), "comment1") - expect_equal(epw$comment1(), "comment1") - expect_is(epw$comment2(), "character") - expect_equal(epw$comment2("comment2"), "comment2") - expect_equal(epw$comment2(), "comment2") - expect_equal(epw$num_period(), 1L) - expect_equal(epw$interval(), 1L) - expect_is(epw$period(), "data.table") - expect_is(epw$period(1), "data.table") - expect_error(epw$period(2), class = "error_invalid_data_period_index") - expect_equal(epw$period(1, name = "test")$name, "test") - expect_error(epw$period(1, name = "test"), class = "error_invalid_epw_data_period_name") - expect_equal(epw$period(1, name = "Data")$name, "Data") - expect_error(epw$period(1, start_day_of_week = "test"), class = "error_not_wday") - expect_equal(epw$period(1, start_day_of_week = 3)$start_day_of_week, 3L) - expect_equal(epw$period(1, start_day_of_week = "Wed")$start_day_of_week, 3L) - expect_equal(epw$period(1)$start_day_of_week, 3L) - - # constant - expect_is(epw$missing_code(), "list") - expect_is(epw$initial_missing_value(), "list") - expect_is(epw$range_exist(), "list") - expect_is(epw$range_valid(), "list") - expect_is(epw$fill_action(), "list") - - # can get weather data - expect_is(epw$data(), "data.table") - expect_error(epw$data(2), class = "error_invalid_data_period_index") - expect_equal(ncol(epw$data()), 36L) - expect_equal(nrow(epw$data()), 8760L) - # can change year in datetime column - expect_equal( - epw$data(start_year = 2018, tz = "GMT")$datetime, - seq(as.POSIXct("2018-01-01 01:00:00", tz = "GMT"), - as.POSIXct("2019-01-01 00:00:00", tz = "GMT"), - by = "1 hour" - ) - ) - - # can change the year column - expect_equal(epw$data(start_year = 2018, update = TRUE)$year, c(rep(2018L, times = 8759), 2019L)) - # can change the time zone of datetime column in the returned weather data - expect_error(attr(epw$data(tz = "America/Chicago")$datetime, "tzone"), class = "error_invalid_epw_date_introduced") - expect_equal(attr(epw$data(start_year = 2019, tz = "Etc/GMT+8")$datetime, "tzone"), "Etc/GMT+8") - - expect_equal(nrow(epw$abnormal_data()), 2170L) - expect_true("line" %in% names(epw$abnormal_data())) - expect_equal(ncol(epw$abnormal_data()), 37L) - expect_equal(nrow(epw$abnormal_data(cols = "albedo")), 2160L) - expect_equal(ncol(epw$abnormal_data(cols = "albedo", keep_all = FALSE)), 8L) - expect_equal(nrow(epw$abnormal_data(cols = "albedo", type = "out_of_range")), 0L) - - expect_equal(nrow(epw$redundant_data()), 0L) - - expect_true(all(is.na(epw$make_na(missing = TRUE)$abnormal_data(cols = "albedo", type = "missing")$albedo))) - - expect_true(all(!is.na(epw$fill_abnormal(missing = TRUE, special = TRUE)$abnormal_data(cols = "albedo", type = "missing")$albedo))) - - expect_is(epw$add_unit()$data()$dry_bulb_temperature, "units") - - expect_is(epw$drop_unit()$data()$dry_bulb_temperature, "numeric") - - expect_silent(epw$purge()) - - epw <- read_epw(path_epw) - # keep input year values - y <- epw$data()$year - # can change weather data - expect_silent(epw$set(epw$data(), warning = FALSE)) - expect_equal(epw$data()$year, y) - expect_error(epw$add(epw$data(), warning = FALSE), class = "error_epw_data_overlap") - expect_error(epw$add(epw$data(start_year = 2016L), realyear = TRUE, warning = FALSE), class = "error_invalid_epw_data_date") - expect_silent(epw$add(epw$data(start_year = 2018L), realyear = TRUE, warning = FALSE)) - expect_equal(epw$period()$index, 1L:2L) - expect_equal(epw$period()$name, c("Data1", "Data")) - expect_warning(epw$add(epw$data(start_year = 2019L), after = 5L, realyear = TRUE, warning = FALSE), - "starting date will be overwriten" - ) - expect_equal(epw$period()$index, 1L:3L) - expect_equal(epw$period()$name, c("Data1", "Data", "Data2")) - expect_equal(epw$period()$start_day, c(c(epw_date("2018/1/1"), epw_date("1/1", FALSE)), epw_date("2019/1/1"))) - - expect_equal(find_nearst_wday_year(make_date(2019, 1, 14), 1, 2019), 2019) - expect_equal(find_nearst_wday_year(make_date(2019, 1, 14), 2, 2019), 2014) - - # EpwDate Class {{{ - expect_error(epw_date(list()), "Missing method to convert") - expect_equal(epw_date(""), init_epwdate_vctr(1)) - expect_equal(format(epw_date("")), NA_character_) - expect_output(print(epw_date("")), "NA") - - expect_equal(epw_date(0L), init_epwdate_vctr(1, "0-01-01")) - expect_equal(epw_date("0"), init_epwdate_vctr(1, "0-01-01")) - - expect_equal(epw_date(367), init_epwdate_vctr(1)) - expect_equal(format(epw_date(367)), NA_character_) - expect_output(print(epw_date(367)), "NA") - - expect_equal(epw_date(366), init_epwdate_vctr(1, "4-12-31")) - expect_equal(format(epw_date(366)), "366") - expect_output(print(epw_date(366)), "366th day") - - expect_equal(epw_date(3), init_epwdate_vctr(1, "4-01-03")) - expect_equal(format(epw_date(3)), "3") - expect_output(print(epw_date(3)), "3rd day") - - expect_equal(epw_date("3.10"), init_epwdate_vctr(1, "8-03-10")) - - expect_equal(epw_date("01/03"), init_epwdate_vctr(1, "8-01-03")) - expect_equal(format(epw_date("Apr-01")), "4/ 1") - expect_output(print(epw_date("Apr-01")), "Apr 01") - - expect_equal(epw_date("01-Apr"), init_epwdate_vctr(1, "8-04-01")) - expect_equal(format(epw_date("01-Apr")), "4/ 1") - expect_output(print(epw_date("01-Apr")), "Apr 01") - - expect_equal(epw_date("2019-01-Apr"), init_epwdate_vctr(1)) - expect_equal(format(epw_date("2019-01-Apr")), NA_character_) - expect_output(print(epw_date("2019-01-Apr")), "NA") - - expect_equal(epw_date("2019-Apr-01"), init_epwdate_vctr(1)) - expect_equal(format(epw_date("2019-Apr-01")), NA_character_) - expect_output(print(epw_date("2019-Apr-01")), "NA") - - expect_equal(epw_date("4-01-2019"), init_epwdate_vctr(1, "2019-04-01")) - expect_equal(format(epw_date("4-01-2019")), "2019/4/ 1") - expect_output(print(epw_date("4-01-2019")), "2019-04-01") - - expect_equal(epw_date("last Mon in Jan"), init_epwdate_vctr(1, "16-01-25")) - expect_equal(format(epw_date("last Mon in Jan")), "Last Monday in January") - expect_output(print(epw_date("last Mon in Jan")), "Last Monday in January") - - expect_equal(epw_date("1st Mon in Jan"), init_epwdate_vctr(1, "12-01-02")) - expect_equal(format(epw_date("1st Mon in Jan")), "1st Monday in January") - expect_output(print(epw_date("1st Mon in Jan")), "1st Monday in January") - - expect_equal(format(epw_date(c("2nd Sunday in March", "1st Sunday in November"))), - c("2nd Sunday in March", "1st Sunday in November") - ) - - expect_equal(epw_date("6 Mon in Jan"), init_epwdate_vctr(1)) - expect_equal(format(epw_date("6 Mon in Jan")), NA_character_) - expect_output(print(epw_date("6 Mon in Jan")), "NA") - - expect_equal(c(epw_date("1/3"), epw_date("3")), epw_date(c("1/3", "3"))) - - expect_true(is_EpwDate(epw_date("1"))) - expect_false(is_EpwDate(Sys.Date())) - expect_equal(epw_date(1), as_EpwDate("1")) - expect_true(is.na(epw_date(""))) - expect_false(is.na(epw_date(1))) - expect_equal(length(epw_date(1:5)), 5L) - expect_equal(epw_date(1:5)[2L], epw_date(2)) - expect_equal(epw_date(1:5)[[3L]], epw_date(3)) - expect_equal({d <- epw_date(1:2);d[1] <- epw_date(3);d}, epw_date(c(3, 2))) - expect_equal({d <- epw_date(1:2);d[[1]] <- epw_date(3);d}, epw_date(c(3, 2))) - # }}} - - # can check equality - expect_true(epw == epw) - expect_false(epw == read_epw(path_epw)) - expect_false(epw != epw) - expect_true(epw != read_epw(path_epw)) - - # do not test on CRAN - skip_on_cran() - # download weather - eplusr_option(verbose_info = TRUE) - expect_message({path_epw <- download_weather("USA_CA_San.Francisco.Intl.AP.724940_TMY3", - ask = FALSE, type = "epw", dir = tempdir())} - ) -}) From 4a5d8526c5395d2ebe7720cf276026ce67af527a Mon Sep 17 00:00:00 2001 From: Hongyuan Jia Date: Sat, 25 Jul 2020 21:54:06 +0800 Subject: [PATCH 27/43] [refactor] Refactor assert.R --- NAMESPACE | 1 - R/assert.R | 124 +------- R/assertions.R | 565 --------------------------------- R/diagram.R | 4 +- R/err.R | 3 +- R/format.R | 103 +++--- R/geometry.R | 75 +++-- R/group.R | 38 ++- R/impl-epw.R | 2 +- R/impl-sql.R | 41 ++- R/install.R | 95 ++---- R/job.R | 95 ++---- R/param.R | 40 +-- R/rdd.R | 33 +- R/sql.R | 7 +- R/transition.R | 8 +- man/assertion.Rd | 2 +- tests/testthat/test-assert.R | 56 +--- tests/testthat/test_assert.R | 101 ------ tests/testthat/test_format.R | 435 ------------------------- tests/testthat/test_group.R | 183 ----------- tests/testthat/test_install.R | 13 - tests/testthat/test_job.R | 116 ------- tests/testthat/test_param.R | 281 ---------------- tests/testthat/test_rdd.R | 58 ---- tests/testthat/test_reload.R | 83 ----- tests/testthat/test_sql.R | 164 ---------- tests/testthat/test_units.R | 124 -------- tests/testthat/test_validate.R | 256 --------------- 29 files changed, 262 insertions(+), 2844 deletions(-) delete mode 100644 R/assertions.R delete mode 100644 tests/testthat/test_assert.R delete mode 100644 tests/testthat/test_format.R delete mode 100644 tests/testthat/test_group.R delete mode 100644 tests/testthat/test_install.R delete mode 100644 tests/testthat/test_job.R delete mode 100644 tests/testthat/test_param.R delete mode 100644 tests/testthat/test_rdd.R delete mode 100644 tests/testthat/test_reload.R delete mode 100644 tests/testthat/test_sql.R delete mode 100644 tests/testthat/test_units.R delete mode 100644 tests/testthat/test_validate.R diff --git a/NAMESPACE b/NAMESPACE index dcacf42bb..66c7ac766 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -213,7 +213,6 @@ importFrom(checkmate,qtestr) importFrom(checkmate,test_character) importFrom(checkmate,test_choice) importFrom(checkmate,test_class) -importFrom(checkmate,test_count) importFrom(checkmate,test_file_exists) importFrom(checkmate,test_flag) importFrom(checkmate,test_integerish) diff --git a/R/assert.R b/R/assert.R index 10ce43f37..c33650d4f 100644 --- a/R/assert.R +++ b/R/assert.R @@ -135,56 +135,6 @@ is_rdd <- function (x) checkmate::test_class(x, "RddFile") is_mdd <- function (x) checkmate::test_class(x, "MddFile") # }}} -# is_range {{{ -is_range <- function (x) { - checkmate::test_list(x, len = 4L) && checkmate::test_class(x, "Range") -} -# }}} - -# assert_strint {{{ -check_strint <- function (x, len = NULL, min.len = NULL, max.len = NULL, names = NULL, null.ok = FALSE) { - chk <- checkmate::check_character(x, any.missing = FALSE, len = len, min.len = max.len, names = names, null.ok = null.ok) - if (isTRUE(chk)) TRUE else chk - num <- suppressWarnings(as.double(x)) - chk <- checkmate::check_integerish(num, any.missing = FALSE) - if (isTRUE(chk)) TRUE - else "Must be a vector with integer-coercible format" -} -test_strint <- checkmate::makeTestFunction(check_strint) -assert_strint <- function (x, len = NULL, coerce = FALSE, .var.name = checkmate::vname(x), add = NULL) { - res <- check_strint(x) - checkmate::makeAssertion(x, res, .var.name, add) - if (isTRUE(coerce)) storage.mode(x) <- "integer" - x -} -# }}} -# assert_length {{{ -check_length <- function (x, len, step = NULL) { - if (is_range(len)) { - res <- if (in_range(length(x), len)) TRUE - else paste0("Must have length in range ", len, ", but has length ", length(x)) - } else if (checkmate::test_count(len)){ - if (is.null(step)) { - length(x) == len - res <- if (length(x) == len) TRUE - else paste0("Must have length ", len, ", but has length ", length(x)) - } else { - if (!checkmate::test_count(step, positive = TRUE)) stop("'step' should be either NULL or an integer") - res <- if (length(x) >= len && ((length(x) - len) %% step == 0L)) TRUE - else paste0("Must have length of pattern '", len, " + " , step, " x N'") - } - } else if (checkmate::test_integerish(len, lower = 0L)) { - if (!is.null(step)) { - stop("'step' should not be provided when 'len' is an integer vector") - } - res <- if (length(x) %in% len) TRUE - else paste0("Must have length ", collapse(len, or = TRUE), ", but has length ", length(x)) - } else { - stop("'len' should be either a range or an integer vector") - } -} -assert_length <- checkmate::makeAssertionFunction(check_length) -# }}} # assert_same_len {{{ check_same_len <- function (x, y) { if (NROW(x) == NROW(y)) TRUE else "Must have same length" @@ -195,6 +145,7 @@ assert_same_len <- function(x, y, .var.name = paste(checkmate::vname(x), "and", checkmate::makeAssertion(x, res, .var.name, add) } # }}} + # in_range {{{ in_range <- function (x, range) { if (range$lower_incbounds == range$upper_incbounds) { @@ -208,91 +159,20 @@ in_range <- function (x, range) { } } # }}} -# check_range {{{ -check_range <- function (x, range) { - res <- in_range(x, range) - if (all(res)) TRUE - else paste("Must in range", range) -} -# }}} -# is_choice {{{ -is_choice <- function (x, choices) { - is.character(x) & stri_trans_tolower(x) %chin% stri_trans_tolower(choices) -} -# on_fail(is_choice) <- function (call, env) { -# paste0(deparse(call$x), " should be one of ", collapse(eval(call$choices, env))) -# } -# }}} # has_names {{{ has_names <- function(x, names) names %chin% names(x) # }}} + # has_ext {{{ has_ext <- function (path, ext) tolower(tools::file_ext(path)) %chin% ext # }}} -assert_epwdate <- function (x, len = NULL, null.ok = FALSE, .var.name = checkmate::vname(x), add = NULL) { - x <- assert_vector(x, len = len, null.ok = null.ok) - if (is.null(x)) return(x) - x <- epw_data(x) - res <- if (!checkmate::anyMissing(x)) TRUE - else "Must be a vector of valid EPW date specifications" - makeAssertion(x, res, .var.name, add) -} -assert_wday <- function (x, len = NULL, null.ok = FALSE, .var.name = checkmate::vname(x), add = NULL) { - x <- assert_vector(x, len = len, null.ok = null.ok) - if (is.null(x)) return(x) - x <- get_epw_wday(x) - res <- if (!checkmate::anyMissing(x)) TRUE - else "Must be a vector of valid EPW day of week specifications" - makeAssertion(x, res, .var.name, add) -} - # is_epwdate {{{ is_epwdate <- function (x) { length(x) == 1L && !is.na(epw_date(x)) } # }}} -# not_epwdate_realyear {{{ -not_epwdate_realyear <- function (x, scalar = FALSE, zero = TRUE) { - d <- epw_date(x) - r <- !is.na(d) & get_epwdate_type(d) != 3L - if (!zero) r <- r & get_epwdate_type(d) != 0L - if (scalar) { - length(x) == 1L && all(r) - } else { - r - } -} -# on_fail(not_epwdate_realyear) <- function (call, env) { -# s <- eval(call$scalar, env) -# if (!is.null(s) && s) { -# paste0(deparse(call$x), " should not be EPW real-year date specification.") -# } else { -# paste0(deparse(call$x), " should not contain any EPW real-year date specification.") -# } -# } -# }}} -# not_epwdate_weekday {{{ -not_epwdate_weekday <- function (x, scalar = FALSE, zero = TRUE) { - d <- epw_date(x) - r <- !is.na(d) & get_epwdate_type(d) != 5L - if (!zero) r <- r & get_epwdate_type(d) != 0L - if (scalar) { - length(x) == 1L && all(r) - } else { - r - } -} -# on_fail(not_epwdate_weekday) <- function (call, env) { -# s <- eval(call$scalar, env) -# if (!is.null(s) && s) { -# paste0(deparse(call$x), " is not valid EPW Julian day or Month/Day date specification.") -# } else { -# paste0(deparse(call$x), " contains invalid EPW Julian day or Month/Day date specification.") -# } -# } -# }}} # is_windows {{{ is_windows <- function () .Platform$OS.type == 'windows' diff --git a/R/assertions.R b/R/assertions.R deleted file mode 100644 index 464d5b85d..000000000 --- a/R/assertions.R +++ /dev/null @@ -1,565 +0,0 @@ -#' @importFrom tools file_ext -#' @include constants.R -NULL - -# on_fail {{{ -# a tailored version of assertthat::`on_failure<-` -# should be compatible with assertthat::assert_that -"on_fail<-" <- function (x, value) { - stopifnot(is.function(x), identical(names(formals(value)), c("call", "env"))) - setattr(x, "fail", value) -} -# }}} -# assert {{{ -# a tailored version of assertthat::assert_that -assert <- function(..., msg = NULL, prefix = NULL, err_type = NULL, env = parent.frame()) { - assertions <- eval(substitute(alist(...))) - - for (assertion in assertions) { - val <- eval(assertion, env) - # all TRUE - if (length(val) && !any(is.na(val)) && all(val)) next - - # get error type - if (is.null(err_type)) { - fnm <- deparse(assertion[[1L]]) - if (stringi::stri_startswith_fixed(fnm, "is") || stringi::stri_startswith_fixed(fnm, "are")) { - err_type <- c(paste0("error_not_", sub("[a-z]+_", "", fnm)), "error_assertion") - } else { - err_type <- c(paste0("error_not_", fnm), "error_assertion") - } - } - - # use msg if given - if (!is.null(msg)) abort(err_type, msg) - - # get function - f <- eval(assertion[[1L]], env) - - # get msg_fun - msg_fun <- attr(f, "fail") - - # if no msg_fun defined, use default message - if (is.null(msg_fun)) { - abort(err_type, - sprintf(ngettext( - length(val), "%s is not TRUE.", "%s are not all TRUE."), - surround(deparse(assertion, width.cutoff = 60L)) - ) - ) - } - - # match.call does not do well with primitive functions - if (!is.primitive(f)) assertion <- match.call(f, assertion) - - if (is.null(prefix)) { - abort(err_type, msg_fun(assertion, env)) - } else { - # change message prefix - stopifnot(is_string(prefix)) - abort(err_type, - paste0(prefix, sub(".*? (is|are|should|does|do|must|can|contains)", " \\1", msg_fun(assertion, env))) - ) - } - } - TRUE -} -# }}} - -# is_version {{{ -is_version <- function (ver) { - !is.na(standardize_ver(ver)) -} -# }}} -#' Check for Idd, Idf and Epw objects -#' -#' These functions test if input is a valid object of Idd, Idf, Epw and other -#' main classes. -#' -#' `is_eplus_ver()` returns `TRUE` if input is a valid EnergyPlus version. -#' -#' `is_idd_ver()` returns `TRUE` if input is a valid EnergyPlus IDD version. -#' -#' `is_eplus_path()` returns `TRUE` if input path is a valid EnergyPlus path, -#' i.e. a path where there is an `energyplus` executable and an `Energy+.idd` -#' file. -#' -#' `is_idd()` returns `TRUE` if input is an Idd object. -#' -#' `is_idf()` returns `TRUE` if input is an Idf object. -#' -#' `is_iddobject()` returns `TRUE` if input is an IddObject object. -#' -#' `is_idfobject()` returns `TRUE` if input is an IdfObject object. -#' -#' `is_epw()` returns `TRUE` if input is an Epw object. -#' -#' @param ver A character or numeric vector with suitable numeric version -#' strings. -#' @param strict If `FALSE`, `ver` can be a special string "latest" which -#' represents the latest version. -#' @return A logical vector. -#' @rdname assertion -#' @export -#' @examples -#' is_eplus_ver(8.8) -#' is_eplus_ver(8.0) -#' is_eplus_ver("latest", strict = FALSE) -#' -#' is_idd_ver("9.0.1") -#' is_idd_ver("8.0.1") -#' -#' is_eplus_path("C:/EnergyPlusV9-0-0") -#' is_eplus_path("/usr/local/EnergyPlus-9-0-1") -#' -#' is_idd(use_idd(8.8, download = "auto")) -#' -#' idf <- read_idf(system.file("extdata/1ZoneUncontrolled.idf", package = "eplusr"), -#' idd = use_idd(8.8, download = "auto")) -#' is_idf(idf) -#' -#' is_iddobject(idd_object(8.8, "Version")) -#' -#' is_idfobject(idf_object(idf, 1)) -#' -#' \dontrun{ -#' is_epw(read_epw(download_weather("los angeles.*tmy3", type = "epw", ask = FALSE, max_match = 1))) -#' } -# is_eplus_ver {{{ -is_eplus_ver <- function (ver, strict = FALSE) { - ver <- standardize_ver(ver, strict = strict, complete = FALSE) - ver <- lapply(ver, match_minor_ver, all_ver = c(ALL_EPLUS_VER, names(.globals$eplus_config)), verbose = FALSE) - !viapply(ver, is.na) -} -on_fail(is_eplus_ver) <- function (call, env) { - paste0(deparse(call$ver), " is not a valid or supported EnergyPlus version. ", - "Only EnergyPlus v8.3.0 and after are supported." - ) -} -# }}} - -#' @rdname assertion -#' @export -# is_idd_ver {{{ -is_idd_ver <- function (ver, strict = FALSE) { - ver <- standardize_ver(ver, strict = strict, complete = FALSE) - !is.na(match_minor_ver(ver, c(ALL_IDD_VER, names(.globals$idd)), verbose = FALSE)) -} -on_fail(is_idd_ver) <- function (call, env) { - paste0(collapse(eval(call$ver, env)), " is not a valid Idd version.") -} -# }}} - -#' @param path A path to test. -#' @rdname assertion -#' @export -# is_eplus_path {{{ -is_eplus_path <- function (path) { - eplus <- paste0("energyplus", if (is_windows()) ".exe" else "") - eplus1 <- paste0("EnergyPlus", if (is_windows()) ".exe" else "") - # in case input is a numeric version - path <- as.character(path) - dir.exists(path) & - (file.exists(file.path(path, eplus)) | file.exists(file.path(path, eplus1))) & - file.exists(file.path(path, "Energy+.idd")) -} -on_fail(is_eplus_path) <- function (call, env) { - paste(deparse(call$path), "is not a valid EnergyPlus installation path", - "where `energyplus` executable and `Energy+.idd` should exist." - ) -} -# }}} - -#' @param x An object to test. -#' @rdname assertion -#' @export -# is_idd {{{ -is_idd <- function (x) inherits(x, "Idd") -on_fail(is_idd) <- function (call, env) { - paste(deparse(call$x), "is not an Idd object.") -} -# }}} - -#' @rdname assertion -#' @export -# is_idf {{{ -is_idf <- function (x) inherits(x, "Idf") -on_fail(is_idf) <- function (call, env) { - paste(deparse(call$x), "is not an Idf object.") -} -# }}} - -#' @rdname assertion -#' @export -# is_iddobject {{{ -is_iddobject <- function (x) inherits(x, "IddObject") -on_fail(is_iddobject) <- function (call, env) { - paste(deparse(call$x), "is not an IddObject object.") -} -# }}} - -#' @rdname assertion -#' @export -# is_idfobject {{{ -is_idfobject <- function (x) inherits(x, "IdfObject") -on_fail(is_idfobject) <- function (call, env) { - paste(deparse(call$x), "is not an IdfObject object.") -} -# }}} - -#' @rdname assertion -#' @export -# is_epw {{{ -is_epw <- function (x) inherits(x, "Epw") -on_fail(is_epw) <- function (call, env) { - paste(deparse(call$x), "is not an Epw object.") -} -# }}} - -# is_rdd {{{ -is_rdd <- function (x) inherits(x, "RddFile") -is_mdd <- function (x) inherits(x, "MddFile") -on_fail(is_rdd) <- function (call, env) { - paste(deparse(call$x), "is not a RddFile object.") -} -on_fail(is_mdd) <- function (call, env) { - paste(deparse(call$x), "is not a MddFile object.") -} -# }}} - -# is_range {{{ -is_range <- function (x) { - inherits(x, "Range") -} -# }}} - -# no_na {{{ -no_na <- function (x, coerce = FALSE) { - all(!is.na(x)) -} -on_fail(no_na) <- function (call, env) { - end <- if (eval(call$coerce, env)) " after coercion." else " ." - paste0(deparse(call$x), "should not contain any NA", end) -} -# }}} -# not_empty {{{ -not_empty <- function (x) { - all((dim(x) %||% length(x)) != 0) -} -on_fail(not_empty) <- function (call, env) { - paste(deparse(call$x), "is empty.") -} -# }}} -# is_empty {{{ -is_empty <- function (x) { - !not_empty(x) -} -on_fail(is_empty) <- function (call, env) { - paste(deparse(call$x), "is not empty.") -} -# }}} -# is_number {{{ -is_number <- function (x) { - length(x) == 1L && is.numeric(x) && !is.na(x) -} -on_fail(is_number) <- function (call, env) { - paste(deparse(call$x), "is not a number (length one numeric vector).") -} -# }}} -# is_strnum {{{ -is_strnum <- function(x) { - length(x) == 1L && is.character(x) && all(!is.na(suppressWarnings(as.double(x)))) -} -on_fail(is_strnum) <- function (call, env) { - paste(deparse(call$x), "is not a coercible number.") -} -# }}} -# is_integer {{{ -is_integer <- function(x) { - length(x) == 1L && !is.na(x) && (is.integer(x) || (is.numeric(x) && all(x == trunc(x)))) -} -on_fail(is_integer) <- function (call, env) { - paste(deparse(call$x), "is neither a length one integer nor can be coerced into one.") -} -# }}} -# is_strint {{{ -is_strint <- function(x) { - is_integer(suppressWarnings(as.double(x))) -} -on_fail(is_strint) <- function (call, env) { - paste(deparse(call$x), "is not an integer-coercible format.") -} -# }}} -# is_count {{{ -is_count <- function (x, zero = FALSE) { - if (!is_integer(x)) return(FALSE) - if (zero) x >= 0L else x > 0L -} -on_fail(is_count) <- function (call, env) { - zero <- eval(call$zero, env) - info <- if (!is.null(zero) && zero) "non-nagitive integer" else "positive integer" - paste(deparse(call$x), "is not a count (a length one", info, "vector).") -} -# }}} -# is_string {{{ -is_string <- function(x) is.character(x) && length(x) == 1 && !is.na(x) -on_fail(is_string) <- function (call, env) { - paste(deparse(call$x), "is not a string (length one character vector).") -} -# }}} -# is_flag {{{ -is_flag <- function(x) is.logical(x) && length(x) == 1 && !is.na(x) -on_fail(is_flag) <- function (call, env) { - paste(deparse(call$x), "is neither `TRUE` nor `FALSE`.") -} -# }}} -# is_scalar {{{ -is_scalar <- function(x) length(x) == 1L -on_fail(is_scalar) <- function (call, env) { - paste(deparse(call$x), "is not a scalar (length one vector).") -} -# }}} -# are_string {{{ -are_string <- function(x) is.character(x) && all(!is.na(x)) -on_fail(are_string) <- function (call, env) { - paste(deparse(call$x), "is not a character vector.") -} -# }}} -# are_strint {{{ -are_strint <- function(x) { - are_integer(suppressWarnings(as.double(x))) -} -on_fail(are_strint) <- function (call, env) { - paste(deparse(call$x), "is not an integer-coercible vector.") -} -# }}} -# are_integer {{{ -are_integer <- function(x) { - is.numeric(x) && all(!is.na(x)) && all(x == trunc(x)) -} -on_fail(are_integer) <- function (call, env) { - paste(deparse(call$x), "is neither an integer vector or can be converted into one.") -} -# }}} -# are_number {{{ -are_number <- function (x) { - is.numeric(x) && all(!is.na(x)) -} -on_fail(are_number) <- function (call, env) { - paste(deparse(call$x), "is not a number vector.") -} -# }}} -# are_strnum {{{ -are_strnum <- function(x) { - is.character(x) & all(!is.na(suppressWarnings(as.double(x)))) -} -on_fail(are_strnum) <- function (call, env) { - paste(deparse(call$x), "is not a number-coercible vector.") -} -# }}} -# are_count {{{ -are_count <- function (x, zero = FALSE) { - are_integer(x) && if (zero) all(x >= 0L) else all(x > 0L) -} -on_fail(are_count) <- function (call, env) { - zero <- eval(call$zero, env) - info <- if (!is.null(zero) && zero) "non-nagitive integer" else "positive integer" - paste(deparse(call$x), "are not counts (a", info, "vector).") -} -# }}} -# has_len {{{ -has_len <- function (x, len, step = NULL) { - if (is_range(len)) { - in_range(length(x), len) - } else if (is_integer(len)){ - if (is.null(step)) { - length(x) == len - } else { - if (!is_integer(step)) stop("`step` should be either NULL or an integer.") - length(x) >= len && ((length(x) - len) %% step == 0L) - } - } else if (are_integer(len)) { - if (!is.null(step)) { - stop("`step` should not be provided when `len` is an integer vector.") - } - length(x) %in% len - } else { - stop("`len` should be either a range or an integer vector.") - } -} -on_fail(has_len) <- function (call, env) { - len <- eval(call$len, env) - step <- eval(call$step, env) - - if (is_range(len)) { - paste0(deparse(call$x), " does not meet the required length range of ", len, ".") - } else { - if (is.null(step)) { - paste0(deparse(call$x), " does not have the required length of ", collapse(len, or = TRUE), ".") - } else { - paste0(deparse(call$x), " does not have the required length pattern `", len, " + " , step, " x N`.") - } - } -} -# }}} -# have_same_len {{{ -have_same_len <- function (x, y) { - NROW(x) == NROW(y) -} -on_fail(have_same_len) <- function (call, env) { - paste(deparse(call$x), "and", deparse(call$y), "do not have the same length.") -} -# }}} -# in_range {{{ -in_range <- function (x, range) { - if (range$lower_incbounds == range$upper_incbounds) { - between(x, range$minimum, range$maximum, range$lower_incbounds) - } else { - if (range$lower_incbounds) { - x >= range$minimum & x < range$maximum - } else { - x > range$minimum & x <= range$maximum - } - } -} -on_fail(in_range) <- function (call, env) { - paste(deparse(call$x), "is not in range", eval(call$range, env)) -} -# }}} -# is_named {{{ -is_named <- function (x) !is.null(names(x)) -on_fail(is_named) <- function (call, env) { - paste(deparse(call$x), "must be named.") -} -# }}} -# is_choice {{{ -is_choice <- function (x, choices) { - is.character(x) & stri_trans_tolower(x) %in% stri_trans_tolower(choices) -} -on_fail(is_choice) <- function (call, env) { - paste0(deparse(call$x), " should be one of ", collapse(eval(call$choices, env))) -} -# }}} -# has_name {{{ -has_name <- function(x, which) { - assert(is.character(which), msg = "Non-character `which` in has_name().") - all(which %in% names(x)) -} -on_fail(has_name) <- function (call, env) { - nms <- eval(call$which, env) - paste(deparse(call$x), "does not have", - sprintf( - ngettext(length(nms), - "name %s.", "all required names %s." - ), - collapse(nms) - ) - ) -} -# }}} -# has_ext {{{ -has_ext <- function (path, ext) tolower(tools::file_ext(path)) %in% tolower(ext) -on_fail(has_ext) <- function (call, env) { - ext <- eval(call$ext, env) - paste(deparse(call$path), - sprintf( - ngettext(length(ext), - "should have the extension of %s.", - "should have one of the extensions %s." - ), - collapse(ext) - ) - ) -} -# }}} - -# is_epwdate {{{ -is_epwdate <- function (x) { - length(x) == 1L && !is.na(epw_date(x)) -} -on_fail(is_epwdate) <- function (call, env) { - paste0(deparse(call$x), " is not a valid EPW date specification.") -} -# }}} -# are_epwdate {{{ -are_epwdate <- function (x) { - all(!is.na(epw_date(x))) -} -on_fail(are_epwdate) <- function (call, env) { - paste0(deparse(call$x), " contains invalid EPW date specification.") -} -# }}} -# not_epwdate_realyear {{{ -not_epwdate_realyear <- function (x, scalar = FALSE, zero = TRUE) { - d <- epw_date(x) - r <- !is.na(d) & get_epwdate_type(d) != 3L - if (!zero) r <- r & get_epwdate_type(d) != 0L - if (scalar) { - length(x) == 1L && all(r) - } else { - r - } -} -on_fail(not_epwdate_realyear) <- function (call, env) { - s <- eval(call$scalar, env) - if (!is.null(s) && s) { - paste0(deparse(call$x), " should not be EPW real-year date specification.") - } else { - paste0(deparse(call$x), " should not contain any EPW real-year date specification.") - } -} -# }}} -# not_epwdate_weekday {{{ -not_epwdate_weekday <- function (x, scalar = FALSE, zero = TRUE) { - d <- epw_date(x) - r <- !is.na(d) & get_epwdate_type(d) != 5L - if (!zero) r <- r & get_epwdate_type(d) != 0L - if (scalar) { - length(x) == 1L && all(r) - } else { - r - } -} -on_fail(not_epwdate_weekday) <- function (call, env) { - s <- eval(call$scalar, env) - if (!is.null(s) && s) { - paste0(deparse(call$x), " is not valid EPW Julian day or Month/Day date specification.") - } else { - paste0(deparse(call$x), " contains invalid EPW Julian day or Month/Day date specification.") - } -} -# }}} -# is_unique {{{ -is_unique <- function (x) { - anyDuplicated(x) == 0L -} -on_fail(is_unique) <- function (call, env) { - paste0(deparse(call$x), " should not contain any duplication.") -} -# }}} -# is_wday {{{ -is_wday <- function (x) { - length(x) == 1L && !is.na(get_epw_wday(x)) -} -on_fail(is_wday) <- function (call, env) { - paste0(deparse(call$x), " is not a valid day of week format.") -} -# }}} -# are_wday {{{ -are_wday <- function (x) { - all(!is.na(get_epw_wday(x))) -} -on_fail(is_wday) <- function (call, env) { - paste0(deparse(call$x), " contains invalid day of week format.") -} -# }}} - -# is_windows {{{ -is_windows <- function () .Platform$OS.type == 'windows' -# }}} -# is_linux {{{ -is_linux <- function () Sys.info()["sysname"] == "Linux" -# }}} -# is_macos {{{ -is_macos <- function () Sys.info()["sysname"] == "Darwin" -# }}} diff --git a/R/diagram.R b/R/diagram.R index 702c3f8ec..e06fc8d67 100644 --- a/R/diagram.R +++ b/R/diagram.R @@ -8,10 +8,12 @@ # @param path A path of EnergyPlus `Bind Node Detail` (`.bnd`) file. # @return File path of the generated `.svg` file if successful. Otherwise # `NULL`. +#' @importFrom checkmate test_file_exists # @export # hvac_diagram {{{ hvac_diagram <- function (eplus, path) { - assert(file.exists(path), has_ext(path, "bnd")) + if (!checkmate::test_file_exists(path, "r", "bnd")) return(NULL) + assert_vector(eplus, len = 1L) nm <- tools::file_path_sans_ext(basename(path)) wd <- dirname(path) diff --git a/R/err.R b/R/err.R index c726f0324..64ee8bdf5 100644 --- a/R/err.R +++ b/R/err.R @@ -56,9 +56,10 @@ NULL #' # read the err file #' read_err(job$locate_output(".err")) #' } +#' @importFrom checkmate assert_file # read_err {{{ read_err <- function (path) { - assert(has_ext(path, c("err", "vcperr"))) + checkmate::assert_file(path, extension = c("err", "vcperr")) parse_err_file(path) } # }}} diff --git a/R/format.R b/R/format.R index 6173bb765..8e4b7a05c 100644 --- a/R/format.R +++ b/R/format.R @@ -130,25 +130,23 @@ format_header <- function (save_format = c("sorted", "new_top", "new_bot"), # }}} # format_idf: return whole Idf output {{{ +#' @importFrom checkmate assert_names assert_count assert_flag assert_int format_idf <- function ( dt_value, dt_object = NULL, dt_order = NULL, header = TRUE, comment = TRUE, save_format = c("sorted", "new_top", "new_bot"), - special_format = FALSE, leading = 4L, in_ip = FALSE, sep_at = 29L, index = FALSE, + special_format = FALSE, leading = 4L, sep_at = 29L, index = FALSE, blank = FALSE, end = TRUE, required = FALSE ) { - assert(has_name(dt_value, c("object_id", "class_id", "class_name", "field_index"))) + assert_names(names(dt_value), must.include = c("object_id", "class_id", "class_name", "field_index")) save_format <- match.arg(save_format) - assert( - is_count(leading, zero = TRUE), - is_flag(in_ip), - is_count(sep_at, zero = TRUE), - is_flag(index), - is_flag(blank), - is_flag(end), - is_flag(required) - ) + assert_count(leading) + assert_int(sep_at, lower = -1L) + assert_flag(index) + assert_flag(blank) + assert_flag(end) + assert_flag(required) setorderv(dt_value, c("object_id", "field_index")) @@ -194,19 +192,23 @@ format_idf <- function ( by = c("class_id") ] } else { - assert(!is.null(dt_order)) - out[J(dt_order$object_id), on = "object_id", object_order := dt_order$object_order] - if (save_format == "new_top") { - setorderv(out, c("object_order", "object_id"), c(-1L, 1L)) - } else { - setorderv(out, c("object_order", "object_id"), c(1L, 1L)) + if (!is.null(dt_order)) { + assert_data_frame(dt_order, any.missing = FALSE, min.cols = 2) + assert_names(names(dt_order), must.include = c("object_id", "object_order")) + + out[dt_order, on = "object_id", object_order := i.object_order] + if (save_format == "new_top") { + setorderv(out, c("object_order", "object_id"), c(-1L, 1L)) + } else { + setorderv(out, c("object_order", "object_id"), c(1L, 1L)) + } + set(out, NULL, "object_order", NULL) } - set(out, NULL, "object_order", NULL) } # }}} if (header) - h <- format_header(save_format = save_format, view_in_ip = in_ip, special_format = special_format) + h <- format_header(save_format = save_format, view_in_ip = eplusr_option("view_in_ip"), special_format = special_format) else h <- NULL list(header = h, format = out) @@ -616,7 +618,7 @@ format_possible <- function (x) { cols <- NULL # auto {{{ - if (has_name(x, "auto")) { + if (has_names(x, "auto")) { set(x, NULL, "fmt_auto", paste0("* Auto value: ", { tmp <- paste0("\"", x$auto, "\"") @@ -630,7 +632,7 @@ format_possible <- function (x) { # }}} # default {{{ - if (has_name(x, "default")) { + if (has_names(x, "default")) { set(x, NULL, "fmt_default", paste0("* Default: ", vcapply(x$default, function (def) { if (is.numeric(def)) { @@ -648,7 +650,7 @@ format_possible <- function (x) { # }}} # choice {{{ - if (has_name(x, "choice")) { + if (has_names(x, "choice")) { set(x, NULL, "fmt_choice", paste0("* Choice:", vcapply(x$choice, function (cho) { if (!length(cho)) return(" ") @@ -663,7 +665,7 @@ format_possible <- function (x) { # }}} # range {{{ - if (has_name(x, "ranger")) { + if (has_names(x, "ranger")) { set(x, NULL, "range", paste0("* Range: ", vcapply(x$range, format.Range))) on.exit(set(x, NULL, "fmt_range", NULL), add = TRUE) cols <- c(cols, "fmt_range") @@ -671,7 +673,7 @@ format_possible <- function (x) { # }}} # source {{{ - if (has_name(x, "source")) { + if (has_names(x, "source")) { set(x, NULL, "fmt_source", paste0("* Source: ", vcapply(x$source, function (src) { if (!length(src)) return("") @@ -684,7 +686,7 @@ format_possible <- function (x) { } # }}} - if (has_name(x, "value_id")) { + if (has_names(x, "value_id")) { res <- x[, .SD, .SDcols = c("object_id", "value_id", "field", cols)] } else { res <- x[, .SD, .SDcols = c("class_id", "field_id", "field", cols)] @@ -722,11 +724,11 @@ format_field_by_parent <- function (dt, col = "value", sep_at = 15L, required = val <- col == "value" # in order to keep index more tidy, have to format them based on # parent index - if (has_name(dt, "object_id")) { + if (has_names(dt, "object_id")) { col_parent <- "object_id" - } else if (has_name(dt, "class_id")) { + } else if (has_names(dt, "class_id")) { col_parent <- "class_id" - } else if (has_name(dt, "group_id")) { + } else if (has_names(dt, "group_id")) { col_parent <- "group_id" } else { col_parent <- NULL @@ -750,34 +752,33 @@ format_field_by_parent <- function (dt, col = "value", sep_at = 15L, required = # }}} # format_objects: return pretty formatted tree string for mutiple IdfObjects {{{ +#' @importFrom checkmate assert_subset assert_names format_objects <- function (dt, component = c("group", "class", "object", "field", "value"), brief = TRUE, merge = TRUE, sep_at = 15L, nest = TRUE, order = FALSE, required = FALSE) { - all_comp <- c("group", "class", "object", "field", "value") - component <- all_comp[sort(chmatch(component, all_comp))] - assert(no_na(component), msg = paste0("`component` should be one or some of ", collapse(all_comp))) + assert_subset(component, c("group", "class", "object", "field", "value"), FALSE) # create each component {{{ if ("group" %chin% component) { - assert(has_name(dt, c("group_id", "group_name")), prefix = "Input") + assert_names(names(dt), must.include = c("group_id", "group_name")) set(dt, NULL, "group", format_group(dt)) } if ("class" %chin% component) { - assert(has_name(dt, c("class_id", "class_name")), prefix = "Input") + assert_names(names(dt), must.include = c("class_id", "class_name")) set(dt, NULL, "class", format_class(dt)) } if ("object" %chin% component) { - assert(has_name(dt, c("object_id", "object_name")), prefix = "Input") + assert_names(names(dt), must.include = c("object_id", "object_name")) set(dt, NULL, "object", format_object(dt)) } if ("value" %chin% component) { - assert(has_name(dt, c("value_id", "value_chr", "value_num")), prefix = "Input") + assert_names(names(dt), must.include = c("value_id", "value_chr", "value_num")) old_value <- dt[["value_chr"]] if (merge) { - assert(has_name(dt, c("field_id", "field_index", "field_name", "units", "ip_units"))) + assert_names(names(dt), must.include = c("field_id", "field_index", "field_name", "units", "ip_units")) set(dt, NULL, "value", format_field_by_parent(dt, "value", sep_at = sep_at, required = required)) component <- component[component != "field"] } else { @@ -793,7 +794,7 @@ format_objects <- function (dt, component = c("group", "class", "object", "field # should format "field" after "value" as if merge is TRUE, then formatting # field is not necessary if ("field" %chin% component) { - assert(has_name(dt, c("field_id", "field_index", "field_name", "units", "ip_units")), prefix = "Input") + assert_names(names(dt), must.include = c("field_id", "field_index", "field_name", "units", "ip_units")) if ((!"value" %chin% component) || ("value" %chin% component & !merge)) { set(dt, NULL, "field", paste0("Field: <", format_field_by_parent(dt, "field", sep_at = sep_at, required = required), ">") ) @@ -857,7 +858,7 @@ format_objects <- function (dt, component = c("group", "class", "object", "field col_del <- intersect(names(dt), c("group", "class", "object", "field", "value")) if (length(col_del)) set(dt, NULL, col_del, NULL) - if (has_name(dt, "value_chr")) set(dt, NULL, "value_chr", old_value) + if (has_names(dt, "value_chr")) set(dt, NULL, "value_chr", old_value) if (nest & order) setorderv(out, col_id) out @@ -884,7 +885,7 @@ format_field <- function (dt, val <- NULL } - nm <- format_name(dt, prefix) + nm <- if (sep_at < 0L) "" else format_name(dt, prefix) paste0(idx, val, nm) } @@ -892,7 +893,7 @@ format_field <- function (dt, # format_index: return right aligned field index {{{ format_index <- function (dt, required = FALSE, pad_char = " ") { - if (required) assert(has_name(dt, "required_field")) + if (required) assert_names(names(dt), must.include = "required_field") if (any(!is.na(dt$field_index))) { idx <- lpad(dt$field_index, pad_char, width = max(nchar(dt$field_index[!is.na(dt$field_index)], "width"))) @@ -912,13 +913,14 @@ format_index <- function (dt, required = FALSE, pad_char = " ") { # }}} # format_value: return Idf format value strings {{{ +#' @importFrom checkmate assert_names format_value <- function (dt, leading = 4L, length = 29L, quote = FALSE, blank = FALSE, end = TRUE) { length <- max(length, 0L) if (is.null(dt$value_chr)) return(paste0(stri_dup(" ", leading), character(nrow(dt)))) set(dt, NULL, "value_out", dt$value_chr) set(dt, NULL, "width", leading + nchar(dt$value_out, "width") + 1L) # 1 for comma(,) - if (has_name(dt, "value_num")) { + if (has_names(dt, "value_num")) { dt[!is.na(value_num), `:=`( value_out = as.character(value_num), width = leading + nchar(value_num, "width") + 1L) @@ -943,7 +945,7 @@ format_value <- function (dt, leading = 4L, length = 29L, quote = FALSE, blank = if (!quote) { dt[is.na(value_out), `:=`(value_out = blk_chr, width = leading + blk_chr_w + 1L)] } else { - assert(has_name(dt, "type_enum")) + assert_names(names(dt), must.include = "type_enum") # character value dt[type_enum > IDDFIELD_TYPE$real, @@ -982,7 +984,7 @@ format_value <- function (dt, leading = 4L, length = 29L, quote = FALSE, blank = } else if (!end) { res <- paste0(values, ",") } else { - if (has_name(dt, "object_id")) { + if (has_names(dt, "object_id")) { is_end <- dt[, .I[.N], by = object_id]$V1 } else { is_end <- length(values) @@ -1061,10 +1063,7 @@ print.IddRelation <- function (x, ...) { # print.IdfRelationBy {{{ print.IdfRelationBy <- function (x, ...) { cli::cat_rule("Referred by Others") - if (!all(has_name(x, c( - "class_name", "object_name", "field_name", - "src_class_name", "src_object_name", "src_field_name" - )))) { + if (!all(has_names(x, c("class_name", "object_name", "field_name", "src_class_name", "src_object_name", "src_field_name")))) { NextMethod("print") return(invisible(x)) } @@ -1083,10 +1082,7 @@ print.IdfRelationBy <- function (x, ...) { print.IdfRelationTo <- function (x, ...) { cli::cat_rule("Refer to Others") - if (!all(has_name(x, c( - "class_name", "object_name", "field_name", - "src_class_name", "src_object_name", "src_field_name" - )))) { + if (!all(has_names(x, c("class_name", "object_name", "field_name", "src_class_name", "src_object_name", "src_field_name")))) { NextMethod("print") return(invisible(x)) } @@ -1104,10 +1100,7 @@ print.IdfRelationTo <- function (x, ...) { # print.IdfRelationNode {{{ print.IdfRelationNode <- function (x, ...) { cli::cat_rule("Node Relation") - if (!all(has_name(x, c( - "class_name", "object_name", "field_name", - "src_class_name", "src_object_name", "src_field_name" - )))) { + if (!all(has_names(x, c("class_name", "object_name", "field_name", "src_class_name", "src_object_name", "src_field_name")))) { NextMethod("print") return(invisible(x)) } diff --git a/R/geometry.R b/R/geometry.R index 16f062008..2e9c83975 100644 --- a/R/geometry.R +++ b/R/geometry.R @@ -9,7 +9,7 @@ IdfGeometry <- R6Class("IdfGeometry", cloneable = FALSE, private$m_geometry <- extract_geometry(private$m_parent) # save uuid - private$m_log$parent_uuid <- ._get_private(private$m_parent)$m_log$uuid + private$m_log$parent_uuid <- get_priv_env(private$m_parent)$m_log$uuid }, vertices = function () @@ -87,7 +87,19 @@ extract_geometry <- function (idf) { set(dt, NULL, c("origin_x", "origin_y", "origin_z"), NULL) # rotate if necessary - dt <- rotate_vertices(dt, idf$Building$North_Axis, c("x", "y", "z")) + if (idf$is_valid_class("Building")) { + north <- idf$Building$North_Axis + if (is.na(north)) { + warn("North Axis unknown, using 0", "warn_unknown_north_axis") + north <- 0 + } + } else { + north <- 0 + warn("Could not find 'Building' object, assuming 0 rotation", + "warn_no_building" + ) + } + dt <- rotate_vertices(dt, north, c("x", "y", "z")) # add number of vert and vertex index dt[, `:=`(n_vert = .N, index_vertex = seq_len(.N)), by = "id"] @@ -106,44 +118,40 @@ get_global_geom_rules <- function (idf) { invalid <- idf$object_unique("GlobalGeometryRules")$validate(custom_validate(choice = TRUE))$invalid_choice if (nrow(invalid)) { if (1L %in% invalid$field_index) { - warn("warn_invalid_start_vertex_pos", paste0( - "Invalid coordinate system found ", surround(rules$starting_vertex_position), ". ", + warn(paste0("Invalid coordinate system found ", surround(rules$starting_vertex_position), ". ", "Assuming 'UpperLeftCorner'." - )) + ), "warn_invalid_start_vertex_pos") rules$starting_vertex_position <- "upperleftcorner" } if (2L %in% invalid$field_index) { - warn("warn_invalid_vertex_entry_dir", paste0( - "Invalid vertex entry direction found ", surround(rules$vertex_entry_direciton), ". ", + warn(paste0("Invalid vertex entry direction found ", surround(rules$vertex_entry_direction), ". ", "Assuming 'Counterclockwise'." - )) - rules$vertex_entry_direciton <- "counterclockwise" + ), "warn_invalid_vertex_entry_dir") + rules$vertex_entry_direction <- "counterclockwise" } if (3L %in% invalid$field_index) { - warn("warn_invalid_global_coord_sys", paste0( - "Invalid coordinate system found ", surround(rules$coordinate_system), ". ", + warn(paste0("Invalid coordinate system found ", surround(rules$coordinate_system), ". ", "Assuming 'Relative'." - )) + ), "warn_invalid_global_coord_sys") rules$coordinate_system <- "relative" } if (5L %in% invalid$field_index) { - warn("warn_invalid_rectsurface_coord_sys", paste0( - "Invalid rectangular coordinate system found ", surround(rules$rectangular_surface_coordinate_system), ". ", + warn(paste0("Invalid rectangular coordinate system found ", surround(rules$rectangular_surface_coordinate_system), ". ", "Assuming 'Relative'." - )) + ), "warn_invalid_rectsurface_coord_sys") rules$rectangular_surface_coordinate_system <- "relative" } } } else { - warn("warn_no_global_geom_rules", - "No 'GlobalGeometryRules' object found in current IDF. Assuming all defaults." + warn("No 'GlobalGeometryRules' object found in current IDF. Assuming all defaults.", + "warn_no_global_geom_rules" ) rules <- list( starting_vertex_position = "upperleftcorner", - vertex_entry_direciton = "counterclockwise", + vertex_entry_direction = "counterclockwise", coordinate_system = "relative", daylighting_reference_point_coordinate_system = "relative", rectangular_surface_coordinate_system = "relative" @@ -166,20 +174,18 @@ get_zone_origin <- function (idf) { setnames(zone, c("name", "x", "y", "z", "dir_relative_north")) set(zone, NULL, "name_lower", stri_trans_tolower(zone$name)) if (nrow(mis_origin <- na.omit(zone, by = c("x", "y", "z"), invert = TRUE))) { - warn("warn_no_zone_origin", paste0( - "Zone below has unknown origin. (0, 0, 0) will be used:\n", + warn(paste0("Zone below has unknown origin. (0, 0, 0) will be used:\n", collapse(mis_origin$name) - )) + ), "warn_no_zone_origin") zone[J(NA_real_), on = "x", x := 0.0] zone[J(NA_real_), on = "y", y := 0.0] zone[J(NA_real_), on = "z", z := 0.0] } if (anyNA(zone$dir_relative_north)) { - warn("warn_no_zone_north", paste0( - "Zone below has unknown direction of relative North. 0 will be used:\n", + warn(paste0("Zone below has unknown direction of relative North. 0 will be used:\n", collapse(zone[is.na(dir_relative_north), name]) - )) + ), "warn_no_zone_north") zone[J(NA_real_), on = "dir_relative_north", dir_relative_north := 0.0] } @@ -676,6 +682,7 @@ get_vertices_from_specs <- function (azimuth, tilt, x0, y0, z0, length, height_w # rotate_vertices {{{ rotate_vertices <- function (dt, degree, vertices) { + browser() if (is.na(degree)) return(dt) # rotate if necessary @@ -781,13 +788,13 @@ geom_view <- function (self, private, new = TRUE, clear = TRUE, axis = TRUE, theta = 0, phi = -60, fov = 60, zoom = 1, background = "white", size = c(0, 30, 800)) { if (!requireNamespace("rgl", quietly = TRUE)) { - abort("error_no_rgl", paste0( + abort(paste0( "'eplusr' relies on the 'rgl' package to view 3D IDF geometry; ", "please add this to your library with install.packages('rgl') and try agian." )) } if (!requireNamespace("decido", quietly = TRUE)) { - abort("error_no_decido", paste0( + abort(paste0( "'eplusr' relies on the 'decido' package to view 3D IDF geometry; ", "please add this to your library with install.packages('decido') and try agian." )) @@ -880,14 +887,13 @@ geom_view_add_ground <- function (self, private, ground = "#CCCCC9") { # geom_save_snapshot {{{ geom_save_snapshot <- function (self, private, filename, bring_to_front = TRUE, axis = FALSE) { if (!requireNamespace("rgl", quietly = TRUE)) { - abort("error_no_rgl", paste0( - "'eplusr' relies on the 'rgl' package to view 3D IDF geometry; ", + abort(paste0("'eplusr' relies on the 'rgl' package to view 3D IDF geometry; ", "please add this to your library with install.packages('rgl') and try agian." )) } if (is.null(private$m_log$id$device)) { - abort("error_no_rgl_window", "No rgl window currently open. Please run '$view()' first.") + abort("No rgl window currently open. Please run '$view()' first.") } # set the last plot device as active @@ -906,8 +912,7 @@ geom_save_snapshot <- function (self, private, filename, bring_to_front = TRUE, if (bring_to_front) rgl::rgl.bringtotop() rgl::rgl.postscript(filename, tools::file_ext(filename)) } else { - abort("error_not_rgl_supported_fmt", paste0( - "Not supported export format ", surround(tools::file_ext(filename)), ". ", + abort(paste0("Not supported export format ", surround(tools::file_ext(filename)), ". ", "Current supported: ", collapse(c("png", "ps", "eps", "tex", "pdf", "svg", "pgf")) )) } @@ -928,12 +933,12 @@ rad_to_deg <- function (x) x / pi * 180 # }}} # rgl_init {{{ +#' @importFrom checkmate assert_flag assert_numeric rgl_init <- function (new = FALSE, clear = TRUE, theta = 0, phi = -60, fov = 60, zoom = 1, background = "white", size = c(0, 30, 800)) { - assert(is_flag(new), is_flag(clear), is_number(theta), is_number(phi), is_number(fov), is_number(zoom)) - assert(are_number(size), length(size) <= 4L, - msg = sprintf("'size' should be a numeric vector with length no more than %i.", length(size)) - ) + checkmate::assert_flag(new) + checkmate::assert_flag(clear) + checkmate::assert_numeric(size, max.len = 4L) if (clear) { if (rgl::rgl.cur() == 0) new <- TRUE else rgl::rgl.clear() diff --git a/R/group.R b/R/group.R index f6dab546a..50ee10f2d 100644 --- a/R/group.R +++ b/R/group.R @@ -60,7 +60,7 @@ EplusGroupJob <- R6::R6Class(classname = "EplusGroupJob", cloneable = FALSE, private$m_log$unsaved <- input$sql | input$dict # save uuid - private$m_log$idf_uuid <- vcapply(private$m_idfs, function (idf) ._get_private(idf)$m_log$uuid) + private$m_log$idf_uuid <- vcapply(private$m_idfs, function (idf) get_priv_env(idf)$m_log$uuid) private$m_log$uuid <- unique_id() }, @@ -789,7 +789,7 @@ group_job <- function (idfs, epws) { # epgroup_run {{{ epgroup_run <- function (self, private, output_dir = NULL, wait = TRUE, force = FALSE, copy_external = FALSE, echo = wait) { # check if generated models have been modified outside - uuid <- vcapply(private$m_idfs, function (idf) ._get_private(idf)$m_log$uuid) + uuid <- vcapply(private$m_idfs, function (idf) get_priv_env(idf)$m_log$uuid) if (any(uuid != private$m_log$idf_uuid)) { warn("warning_param_modified", paste0( "Some of the grouped models have been modified. ", @@ -806,10 +806,11 @@ epgroup_run <- function (self, private, output_dir = NULL, wait = TRUE, force = } # }}} # epgroup_run_models {{{ +#' @importFrom checkmate test_names epgroup_run_models <- function (self, private, output_dir = NULL, wait = TRUE, force = FALSE, copy_external = FALSE, echo = wait) { path_idf <- vcapply(private$m_idfs, function (idf) idf$path()) - if (is_named(private$m_idfs)) { + if (checkmate::test_names(private$m_idfs)) { # for parametric job nms <- paste0(make_filename(names(private$m_idfs)), ".idf") } else { @@ -832,7 +833,7 @@ epgroup_run_models <- function (self, private, output_dir = NULL, wait = TRUE, f else if (length(output_dir) == 1L) { output_dir <- rep(output_dir, length(path_idf)) } else { - assert(have_same_len(path_idf, output_dir)) + assert_same_len(path_idf, output_dir) } output_dir <- normalizePath(output_dir, mustWork = FALSE) @@ -840,9 +841,7 @@ epgroup_run_models <- function (self, private, output_dir = NULL, wait = TRUE, f dir_to_create <- uniq_dir[!dir.exists(uniq_dir)] create_dir <- dir.create(dir_to_create, showWarnings = FALSE, recursive = TRUE) if (any(!create_dir)) { - abort("error_create_output_dir", paste0("Failed to create output directory: ", - collapse(dir_to_create)[!create_dir]) - ) + abort(paste0("Failed to create output directory: ", collapse(dir_to_create)[!create_dir])) } } @@ -969,13 +968,13 @@ epgroup_status <- function (self, private) { } status$changed_after <- FALSE - uuid <- vcapply(private$m_idfs, function (idf) ._get_private(idf)$m_log$uuid) + uuid <- vcapply(private$m_idfs, function (idf) get_priv_env(idf)$m_log$uuid) if (any(private$m_log$idf_uuid != uuid)) { status$changed_after <- TRUE } # for parametric job - if (is_idf(private$m_seed) && !identical(private$m_log$seed_uuid, ._get_private(private$m_seed)$m_log$uuid)) { + if (is_idf(private$m_seed) && !identical(private$m_log$seed_uuid, get_priv_env(private$m_seed)$m_log$uuid)) { status$changed_after <- TRUE } @@ -1150,8 +1149,7 @@ get_epgroup_input <- function (idfs, epws, sql = TRUE, dict = TRUE) { err <- c("error_idf_not_local", "error_idf_path_not_exist", "error_idf_not_saved") if (any(invld <- vlapply(idfs, inherits, err))) { - abort("error_invalid_group_idf_input", paste0( - "Invalid IDF input found:\n", + abort(paste0("Invalid IDF input found:\n", paste0(lpad(paste0(" #", which(invld))), ": ", vcapply(idfs[invld], conditionMessage), collapse = "\n" ) @@ -1175,8 +1173,7 @@ get_epgroup_input <- function (idfs, epws, sql = TRUE, dict = TRUE) { err <- c("error_epw_not_local", "error_epw_path_not_exist", "error_epw_not_saved") if (any(invld <- vlapply(epws, inherits, err))) { - abort("error_invalid_group_epw_input", paste0( - "Invalid EPW input found:\n", + abort(paste0("Invalid EPW input found:\n", paste0(lpad(paste0(" #", which(invld))), ": ", vcapply(epws[invld], conditionMessage), collapse = "\n" ) @@ -1195,7 +1192,7 @@ get_epgroup_input <- function (idfs, epws, sql = TRUE, dict = TRUE) { sql <- rep(sql, length(epws)) dict <- rep(dict, length(epws)) } - assert(have_same_len(idfs, epws)) + assert_same_len(idfs, epws) } list(idfs = idfs, epws = epws, sql = sql, dict = dict) @@ -1226,7 +1223,7 @@ epgroup_retrieve_data <- function (self, private) { } if (is.null(private$m_log$end_time)) { end_times <- private$m_job[!is.na(end_time), end_time] - if (not_empty(end_times)) private$m_log$end_time <- max(end_times) + if (length(end_times)) private$m_log$end_time <- max(end_times) } } } @@ -1263,7 +1260,7 @@ epgroup_job_from_which <- function (self, private, which, keep_unsucess = FALSE) # setting `keep_unsucess` to TRUE makes it possible to continue to parse # some output files such like .err files. (#24) - if (not_empty(job[status != "completed"])) { + if (nrow(job[status != "completed"])) { incomplete <- job[status != "completed"] msg <- incomplete[, sim_status(rpad(toupper(status)), index, idf, epw)] if (keep_unsucess) { @@ -1272,7 +1269,7 @@ epgroup_job_from_which <- function (self, private, which, keep_unsucess = FALSE) paste0(msg, collapse = "\n") )) } else { - abort("error_job_error", paste0("Some of jobs failed to complete. ", + abort(paste0("Some of jobs failed to complete. ", "Please fix the problems and re-run it before collecting output:\n", paste0(msg, collapse = "\n") )) @@ -1283,8 +1280,9 @@ epgroup_job_from_which <- function (self, private, which, keep_unsucess = FALSE) } # }}} # epgroup_case_from_which {{{ +#' @importFrom checkmate test_names epgroup_case_from_which <- function (self, private, which = NULL, name = FALSE) { - if (is_named(private$m_idfs)) { + if (checkmate::test_names(private$m_idfs)) { nms <- names(private$m_idfs) } else { nms <- vcapply(private$m_idfs, function(idf) tools::file_path_sans_ext(basename(idf$path()))) @@ -1301,7 +1299,7 @@ epgroup_case_from_which <- function (self, private, which = NULL, name = FALSE) collapse(which[is.na(valid)]), ".", call. = FALSE) idx <- valid - } else if (all(are_count(which))) { + } else if (checkmate::test_integerish(which, lower = 1L, any.missing = FALSE)) { valid <- which <= length(nms) if (any(!valid)) stop("Invalid job index found for current parametric job: ", @@ -1468,7 +1466,7 @@ format.EplusGroupJob <- function (x, ...) { #' @export `==.EplusGroupJob` <- function (e1, e2) { if (!inherits(e2, "EplusGroupJob")) return(FALSE) - identical(._get_private(e1)$m_log$uuid, ._get_private(e2)$m_log$uuid) + identical(get_priv_env(e1)$m_log$uuid, get_priv_env(e2)$m_log$uuid) } #' @export diff --git a/R/impl-epw.R b/R/impl-epw.R index f4c89a1ba..582391224 100644 --- a/R/impl-epw.R +++ b/R/impl-epw.R @@ -425,7 +425,7 @@ parse_epw_header_holiday <- function (header, strict = FALSE, transform = TRUE) invld <- val[J(i, 2L), on = c("extensible_group", "extensible_field_index")] issue_epw_header_parse_error_single(obj, invld, i) } - if (any(realyr <- !not_epwdate_realyear(holiday))) { + if (any(realyr <- is_epwdate_type(holiday, EPWDATE_TYPE$ymd))) { i <- which(realyr) invld <- val[J(i, 2L), on = c("extensible_group", "extensible_field_index")] issue_epw_header_parse_error_single(obj, invld, i, ". Can not contain year specification.") diff --git a/R/impl-sql.R b/R/impl-sql.R index 4b4173eb4..4d90d2632 100644 --- a/R/impl-sql.R +++ b/R/impl-sql.R @@ -31,6 +31,7 @@ get_sql_query <- function (sql, query) { } # }}} # get_sql_tabular_data_query {{{ +#' @importFrom checkmate assert_character get_sql_tabular_data_query <- function (report_name = NULL, report_for = NULL, table_name = NULL, column_name = NULL, row_name = NULL) { @@ -68,12 +69,17 @@ get_sql_tabular_data_query <- function (report_name = NULL, report_for = NULL, " # }}} + assert_character(report_name, any.missing = FALSE, null.ok = TRUE) + assert_character(report_for, any.missing = FALSE, null.ok = TRUE) + assert_character(table_name, any.missing = FALSE, null.ok = TRUE) + assert_character(column_name, any.missing = FALSE, null.ok = TRUE) + assert_character(row_name, any.missing = FALSE, null.ok = TRUE) q <- NULL %and% - .sql_make(report_name, assert(is.character(report_name), no_na(report_name))) %and% - .sql_make(report_for, assert(is.character(report_for), no_na(report_for))) %and% - .sql_make(table_name, assert(is.character(table_name), no_na(table_name))) %and% - .sql_make(column_name, assert(is.character(column_name), no_na(column_name))) %and% - .sql_make(row_name, assert(is.character(row_name), no_na(row_name))) + .sql_make(report_name) %and% + .sql_make(report_for) %and% + .sql_make(table_name) %and% + .sql_make(column_name) %and% + .sql_make(row_name) if (is.null(q)) return(view) @@ -87,6 +93,7 @@ list_sql_table <- function (sql) { } # }}} # get_sql_report_data {{{ +#' @importFrom checkmate assert_scalar get_sql_report_data <- function (sql, key_value = NULL, name = NULL, year = NULL, tz = "UTC", case = "auto", all = FALSE, wide = FALSE, period = NULL, month = NULL, day = NULL, hour = NULL, minute = NULL, @@ -334,8 +341,9 @@ get_sql_report_data <- function (sql, key_value = NULL, name = NULL, year = NULL if (wide) res <- report_dt_to_wide(res, all) if (!is.null(case)) { - assert(is_scalar(case)) - set(res, NULL, "case", as.character(case)) + assert_scalar(case) + case_name <- as.character(case) + set(res, NULL, "case", case_name) setcolorder(res, c("case", setdiff(names(res), "case"))) } @@ -348,14 +356,15 @@ get_sql_report_data_dict <- function (sql) { } # }}} # get_sql_tabular_data {{{ +#' @importFrom checkmate assert_scalar get_sql_tabular_data <- function (sql, report_name = NULL, report_for = NULL, table_name = NULL, column_name = NULL, row_name = NULL, case = "auto", wide = FALSE, string_value = !wide) { q <- get_sql_tabular_data_query(report_name, report_for, table_name, column_name, row_name) dt <- setnames(get_sql_query(sql, q), "tabular_data_index", "index")[] - if (not_empty(case)) { - assert(is_scalar(case)) + if (!is.null(case)) { + assert_scalar(case) case_name <- as.character(case) set(dt, NULL, "case", case_name) setcolorder(dt, c("case", setdiff(names(dt), "case"))) @@ -374,7 +383,7 @@ get_sql_tabular_data <- function (sql, report_name = NULL, report_for = NULL, } # add row index - dt[, row_index := seq_len(.N), by = c("case"[has_name(dt, "case")], "report_name", "report_for", "table_name", "column_name")] + dt[, row_index := seq_len(.N), by = c("case"[has_names(dt, "case")], "report_name", "report_for", "table_name", "column_name")] # remove empty rows dt <- dt[!J(c("", "-"), c("", "-")), on = c("row_name", "value")] @@ -401,7 +410,7 @@ wide_tabular_data <- function (dt, string_value = TRUE) { cols_num <- unique(dt$column_name[dt$is_num]) # format table - if (has_name(dt, "case")) { + if (has_names(dt, "case")) { dt <- data.table::dcast.data.table(dt, case + report_name + report_for + table_name + row_index + row_name ~ column_name, value.var = "value" @@ -451,11 +460,13 @@ tidy_sql_name <- function (x) { } # }}} # report_dt_to_wide {{{ +#' @importFrom checkmate assert_names report_dt_to_wide <- function (dt, date_components = FALSE) { - assert(has_name(dt, c("datetime", "month", "day", "hour", "minute", + assert_names(names(dt), must.include = c( + "datetime", "month", "day", "hour", "minute", "key_value", "name", "environment_period_index", "environment_name", "reporting_frequency", "is_meter", "simulation_days", "day_type" - ))) + )) # change detailed level frequency to "Each Call" dt[, Variable := reporting_frequency] @@ -502,7 +513,7 @@ report_dt_to_wide <- function (dt, date_components = FALSE) { `:=`(day_type = wday(datetime, label = TRUE)) ] - if (has_name(dt, "case")) { + if (has_names(dt, "case")) { dt <- dcast.data.table(dt, case + environment_period_index + environment_name + simulation_days + datetime + month + day + hour + minute + @@ -516,7 +527,7 @@ report_dt_to_wide <- function (dt, date_components = FALSE) { value.var = "value") } } else { - if (has_name(dt, "case")) { + if (has_names(dt, "case")) { dt <- dcast.data.table(dt, case + environment_period_index + environment_name + simulation_days + `Date/Time` ~ Variable, diff --git a/R/install.R b/R/install.R index 56fbfcbd5..51a912424 100644 --- a/R/install.R +++ b/R/install.R @@ -106,23 +106,22 @@ NULL #' } #' @author Hongyuan Jia #' @export +#' @importFrom checkmate assert_string # install_eplus {{{ install_eplus <- function (ver = "latest", local = FALSE, dir = NULL, force = FALSE, ...) { ver <- standardize_ver(ver) - if (!is.null(dir)) assert(is_string(dir)) + assert_string(dir, null.ok = TRUE) # check if the same version has been installed already if (is_avail_eplus(ver)) { if (!isTRUE(force)) { - abort("error_eplus_to_install_exists", paste0( - "It seems EnergyPlus v", ver, " has been already installed at ", + abort(paste0("It seems EnergyPlus v", ver, " has been already installed at ", surround(eplus_config(ver)$dir), ". Set `force` to `TRUE` to reinstall." )) } if (is_macos() & ver >= 9.1) { - abort("error_eplus_to_force_install_macos", paste0( - "Cannot perform force reinstallation when EnergyPlus version is v9.1 and above. ", + abort(paste0("Cannot perform force reinstallation when EnergyPlus version is v9.1 and above. ", "Please first uninstall EnergyPlus v", ver, " at ", surround(eplus_config(ver)$dir), " and then run 'install_eplus(\"", ver, "\")'." )) @@ -186,7 +185,7 @@ download_eplus <- function (ver = "latest", dir) { eplus_download_url <- function (ver) { cmt <- eplus_release_commit(ver) - if (is_empty(cmt)) + if (!length(cmt)) stop("Failed to get installer data for EnergyPlus v", ver, ". ", "All available version are: ", collapse(ALL_EPLUS_RELEASE_COMMIT[order(version), version]), ".", call. = FALSE) @@ -210,8 +209,6 @@ eplus_download_url <- function (ver) { eplus_release_commit <- function(ver) { ver <- standardize_ver(ver) - assert(is_eplus_ver(ver)) - ALL_EPLUS_RELEASE_COMMIT[version == as.character(ver)] } # }}} @@ -269,10 +266,7 @@ get_win_user_path <- function (error = FALSE) { if (whoami$status != 0L) { if (!error) return("") - abort("error_cannot_get_win_user", paste0( - "Cannot get the user-level install path because ", - "it failed to get current logged user name." - )) + abort("Cannot get the user-level install path because it failed to get current logged user name.") } user <- gsub("\r\n", "", basename(whoami$stdout), fixed = TRUE) @@ -309,6 +303,7 @@ install_eplus_macos <- function (ver, exec, local = FALSE) { } # }}} # install_eplus_linux {{{ +#' @importFrom checkmate assert_string install_eplus_linux <- function (ver, exec, local = FALSE, dir = NULL, dir_bin = NULL) { if (local) { if (is.null(dir)) dir <- "~/.local" @@ -318,7 +313,7 @@ install_eplus_linux <- function (ver, exec, local = FALSE, dir = NULL, dir_bin = if (is.null(dir_bin)) dir_bin <- "/usr/local/bin" } - if (!is.null(dir_bin)) assert(is_string(dir_bin)) + assert_string(dir_bin) if (!dir.exists(dir)) dir.create(dir, recursive = TRUE) if (!dir.exists(dir_bin)) dir.create(dir_bin, recursive = TRUE) @@ -494,22 +489,14 @@ install_eplus_qt <- function (exec, dir, local = FALSE) { #' #' @export # use_eplus {{{ +#' @importFrom checkmate assert_vector use_eplus <- function (eplus) { - assert(is_scalar(eplus)) + assert_vector(eplus, len = 1L) + ver <- convert_to_eplus_ver(eplus, strict = TRUE, max = FALSE)[[1L]] # if eplus is a version, try to locate it in the default path - if (is_eplus_ver(eplus, strict = TRUE)) { - ver <- standardize_ver(eplus, complete = FALSE) - ori_ver <- ver - - # have to check all possible patched versions - all_ver <- unique(c(ALL_IDD_VER, names(.globals$eplus_config))) - if (is.na(ver[, 3L])) { - ver <- numeric_version(all_ver[ver == numeric_version(all_ver)[, 1L:2L]]) - } else { - ver <- numeric_version(all_ver[ver == numeric_version(all_ver)]) - } - + if (!anyNA(ver)) { + ori_ver <- ver[, 1:2] # try user-level first eplus_dir <- eplus_default_path(ver, local = TRUE) dir_cache <- eplus_dir @@ -551,26 +538,23 @@ use_eplus <- function (eplus) { collapse(paste0("v", ver)), ".\n") } - fail <- paste0("Cannot locate EnergyPlus v", stringi::stri_trim_both(as.character(eplus)), " at default ", + fail <- paste0("Cannot locate EnergyPlus v", ori_ver, " at default ", "installation path ", surround(c(dir_cache, eplus_dir)), collapse = "\n") - abort("error_cannot_locate_eplus", paste0(msg, fail, "\n", - "Please specify explicitly the path of EnergyPlus installation." - )) + abort(paste0(msg, fail, "\nPlease specify explicitly the path of EnergyPlus installation."), "locate_eplus") } } else if (is_eplus_path(eplus)){ ver <- get_ver_from_path(eplus) eplus_dir <- eplus } else { - abort("error_invalid_eplus_input", paste0("`eplus` should be either a ", - "valid EnergyPlus version or an EnergyPlus installation path." - )) + abort("`eplus` should be either a valid EnergyPlus version or an EnergyPlus installation path.") } + eplus_dir <- normalizePath(eplus_dir) exe <- paste0("energyplus", if (is_windows()) ".exe" else "") - res <- list(version = ver, dir = normalizePath(eplus_dir), exe = exe) + res <- list(version = ver, dir = eplus_dir, exe = exe) - ori <- .globals$eplus_config[[as.character(ver)]] - .globals$eplus_config[[as.character(ver)]] <- res + ori <- .globals$eplus[[as.character(ver)]] + .globals$eplus[[as.character(ver)]] <- res if (is.null(ori)) { verbose_info("EnergyPlus v", ver, " located at ", surround(eplus_dir), @@ -580,8 +564,8 @@ use_eplus <- function (eplus) { surround(eplus_dir), " already exists. No Updating performed.") } else { verbose_info("Update configure data of EnergyPlus v", ver, ":\n", - " Former location: ", surround(ori$dir), " ---> ", - "New location: ", surround(eplus_dir)) + " Former location: ", surround(ori$dir), " ---> ", + "New location: ", surround(eplus_dir)) } if (ver < 8.3) { @@ -600,17 +584,15 @@ use_eplus <- function (eplus) { #' @export # eplus_config {{{ eplus_config <- function (ver) { - assert(is_idd_ver(ver, strict = TRUE)) - ver <- standardize_ver(ver, complete = FALSE) - ver_m <- match_minor_ver(ver, names(.globals$eplus_config), "eplus") - if (is.na(ver)) { - warn("warning_miss_eplus_config", - "Failed to find configuration data of EnergyPlus v", ver, ".", - call. = FALSE) + assert_vector(ver, len = 1L) + ver_m <- convert_to_eplus_ver(ver, all_ver = names(.globals$eplus)) + + if (is.na(ver_m)) { + warn(paste0("Failed to find configuration data of EnergyPlus v", ver), "miss_eplus_config") return(list()) } - .globals$eplus_config[[as.character(ver_m)]] + .globals$eplus[[as.character(ver_m)]] } # }}} @@ -618,7 +600,7 @@ eplus_config <- function (ver) { #' @export # avail_eplus {{{ avail_eplus <- function () { - res <- names(.globals$eplus_config) + res <- names(.globals$eplus) if (!length(res)) return(NULL) sort(numeric_version(res)) } @@ -646,11 +628,8 @@ locate_eplus <- function () { # }}} # eplus_default_path {{{ eplus_default_path <- function (ver, local = FALSE) { - ver <- standardize_ver(ver) - if (length(ver) <= 1L) { - assert(is_idd_ver(ver)) - } else { - lapply(ver, function (v) assert(is_idd_ver(v))) + if (anyNA(ver <- convert_to_eplus_ver(ver))) { + stop("'ver' must be a vector of valid EnergyPlus versions") } ver_dash <- paste0(ver[, 1L], "-", ver[, 2L], "-", ver[, 3L]) @@ -683,17 +662,7 @@ get_ver_from_path <- function (path) { idd_file <- normalizePath(file.path(path, "Energy+.idd"), mustWork = TRUE) tryCatch(get_idd_ver(read_lines(idd_file, nrows = 1L)), - error_miss_idd_ver = function (e) { - stop("Failed to parse EnergyPlus version using IDD ", - surround(idd_file), ".\n", conditionMessage(e) - ) - }, - error_invalid_idd_ver = function (e) { - stop("Failed to parse EnergyPlus version using IDD ", - surround(idd_file), ".\n", conditionMessage(e) - ) - }, - error_multi_idd_ver = function (e) { + error = function (e) { stop("Failed to parse EnergyPlus version using IDD ", surround(idd_file), ".\n", conditionMessage(e) ) diff --git a/R/job.R b/R/job.R index 91f095cc9..836212e01 100644 --- a/R/job.R +++ b/R/job.R @@ -777,7 +777,7 @@ job_initialize <- function (self, private, idf, epw) { private$m_log$unsaved <- attr(private$m_idf, "sql") || attr(private$m_idf, "dict") # save uuid - private$m_log$seed_uuid <- ._get_private(private$m_idf)$m_log$uuid + private$m_log$seed_uuid <- get_priv_env(private$m_idf)$m_log$uuid private$m_log$uuid <- unique_id() } @@ -802,9 +802,8 @@ job_path <- function (self, private, type = c("all", "idf", "epw")) { job_run <- function (self, private, epw, dir = NULL, wait = TRUE, force = FALSE, echo = wait, copy_external = FALSE) { # stop if idf object has been changed accidentally - if (!identical(._get_private(private$m_idf)$m_log$uuid, private$m_log$seed_uuid)) { - abort("error_job_idf_modified", paste0( - "The idf has been modified after job was created. ", + if (!identical(get_priv_env(private$m_idf)$m_log$uuid, private$m_log$seed_uuid)) { + abort(paste0("The idf has been modified after job was created. ", "Running this idf will result in simulation outputs that may be not reproducible.", "Please recreate the job using new idf and then run it." )) @@ -836,11 +835,9 @@ job_run <- function (self, private, epw, dir = NULL, wait = TRUE, force = FALSE, # when no epw is given, at least one design day object should exists if (is.null(private$m_epw_path)) { if (!private$m_idf$is_valid_class("SizingPeriod:DesignDay")) { - assert("error_run_no_ddy", - paste0("When no weather file is given, input IDF should contain ", - "`SizingPeriod:DesignDay` object to enable Design-Day-only ", - "simulation." - ) + stop("When no weather file is given, input IDF should contain ", + "at least one 'SizingPeriod:DesignDay' object to enable ", + "Design-Day-only simulation." ) } } @@ -856,8 +853,7 @@ job_run <- function (self, private, epw, dir = NULL, wait = TRUE, force = FALSE, ") and start a new simulation...") suppressMessages(self$kill()) } else { - abort("error_job_still_alive", paste0( - "The simulation of current Idf is still running (PID: ", + abort(paste0("The simulation of current Idf is still running (PID: ", pid, "). Please set `force` to TRUE if you want ", "to kill the running process and start a new simulation." )) @@ -958,7 +954,7 @@ job_status <- function (self, private) { } status$changed_after <- FALSE - if (!identical(private$m_log$seed_uuid, ._get_private(private$m_idf)$m_log$uuid)) { + if (!identical(private$m_log$seed_uuid, get_priv_env(private$m_idf)$m_log$uuid)) { status$changed_after <- TRUE } @@ -1021,11 +1017,7 @@ job_locate_output <- function (self, private, suffix = ".err", strict = TRUE, mu } - if (must_exist) { - assert(file.exists(out), msg = paste0("File ", surround(out), " does not exists."), - err_type = "error_file_not_exist" - ) - } + if (must_exist) checkmate::assert_file_exists(out, "r", .var.name = "output file") out } @@ -1043,7 +1035,7 @@ job_output_errors <- function (self, private, info = FALSE) { job_sql_path <- function (self, private) { path_sql <- job_locate_output(self, private, ".sql", must_exist = FALSE) if (!file.exists(path_sql)) { - abort("error_sql_not_exist", paste0("Simulation SQL output does not exist.")) + abort("Simulation SQL output does not exist.") } path_sql } @@ -1056,9 +1048,8 @@ job_rdd_path <- function (self, private, type = c("rdd", "mdd")) { rdd = "Report Data Dictionary (RDD) file", mdd = "Meter Data Dictionary (MDD) file" ) - if (!file.exists(path)) { - assert(paste0("error_", type, "_not_exist"), paste0(name, " does not exist.")) - } + + if (must_exist) checkmate::assert_file_exists(out, "r", .var.name = name) path } @@ -1176,7 +1167,7 @@ format.EplusSql <- function (x, ...) { #' @export `==.EplusJob` <- function (e1, e2) { if (!inherits(e2, "EplusJob")) return(FALSE) - identical(._get_private(e1)$m_log$uuid, ._get_private(e2)$m_log$uuid) + identical(get_priv_env(e1)$m_log$uuid, get_priv_env(e2)$m_log$uuid) } #' @export @@ -1191,30 +1182,18 @@ get_init_idf <- function (idf, sql = TRUE, dict = TRUE) { idf <- if (!is_idf(idf)) read_idf(idf) else idf$clone(deep = TRUE) if (is.null(idf$path())) { - abort("error_idf_not_local", - paste0( - "The Idf object is not created from local file. ", - "Please save it using `$save()` before running." - ) - ) + abort("The Idf object is not created from local file. Please save it using `$save()` before running.") } if (!utils::file_test("-f", idf$path())) { - abort("error_idf_path_not_exist", - paste0( - "Failed to locate the local IDF file of input Idf object. ", - "Path: ", surround(idf$path()), " ", - "Please re-save it to disk using `$save()` before running." - ) - ) + abort(paste0("Failed to locate the local IDF file of input Idf object. ", + "Path: ", surround(idf$path()), " ", + "Please re-save it to disk using `$save()` before running." + )) } if (idf$is_unsaved()) { - abort("error_idf_not_saved", - paste0("Idf has been modified since read or last saved. ", - "Please save it using `$save()` before running." - ) - ) + abort("Idf has been modified since read or last saved. Please save it using `$save()` before running.") } # add Output:SQLite if necessary @@ -1229,45 +1208,31 @@ get_init_idf <- function (idf, sql = TRUE, dict = TRUE) { } # }}} # get_init_epw {{{ +#' @importFrom checkmate test_string get_init_epw <- function (epw) { - if (is_string(epw)) { + if (checkmate::test_string(epw)) { if (!file.exists(epw)) { - abort("error_epw_path_not_exist", - paste0( - "Input EPW file does not exist. ", - "Path: ", surround(normalizePath(epw, mustWork = FALSE)) - ) - ) + abort(paste0("Input EPW file does not exist. ", + "Path: ", surround(normalizePath(epw, mustWork = FALSE)) + )) } path <- epw } else { epw <- if (!is_epw(epw)) read_epw(epw) else epw$clone(deep = TRUE) if (is.null(epw$path())) { - abort("error_epw_not_local", - paste0( - "The Epw object is not created from local file. ", - "Please save it using `$save()` before running." - ) - ) + abort("The Epw object is not created from local file. Please save it using `$save()` before running.") } if (!utils::file_test("-f", epw$path())) { - abort("error_epw_path_not_exist", - paste0( - "Failed to locate the local EPW file of input Epw object. ", - "Path: ", surround(epw$path()), " ", - "Please re-save it to disk using `$save()` before running." - ) - ) + abort(paste0("Failed to locate the local EPW file of input Epw object. ", + "Path: ", surround(epw$path()), " ", + "Please re-save it to disk using `$save()` before running." + )) } if (epw$is_unsaved()) { - abort("error_epw_not_saved", - paste0("Epw has been modified since read or last saved. ", - "Please save it using `$save()` before running." - ) - ) + abort("Epw has been modified since read or last saved. Please save it using `$save()` before running.") } path <- epw$path() diff --git a/R/param.R b/R/param.R index 62e6d692b..c00e20a95 100644 --- a/R/param.R +++ b/R/param.R @@ -64,7 +64,7 @@ ParametricJob <- R6::R6Class(classname = "ParametricJob", cloneable = FALSE, if (!is.null(epw)) private$m_epws_path <- get_init_epw(epw) # save uuid - private$m_log$seed_uuid <- ._get_private(private$m_seed)$m_log$uuid + private$m_log$seed_uuid <- get_priv_env(private$m_seed)$m_log$uuid private$m_log$uuid <- unique_id() }, @@ -407,18 +407,23 @@ param_weather <- function (self, private) { } # }}} # param_apply_measure {{{ +#' @importFrom checkmate assert_function param_apply_measure <- function (self, private, measure, ..., .names = NULL, .env = parent.frame()) { - assert(is.function(measure)) + checkmate::assert_function(measure) if (length(formals(measure)) < 2L) { - abort("error_measure_no_arg", "`measure` function must have at least two argument.") + stop("'measure' function must have at least two argument") } measure_wrapper <- function (idf, ...) { - assert(is_idf(idf), msg = paste0("Measure should take an `Idf` object as input, not `", class(idf)[[1]], "`.")) + if (!is_idf(idf)) { + stop("Measure should take an 'Idf' object as input, not '", class(idf)[[1]], "'") + } idf <- idf$clone(deep = TRUE) idf <- measure(idf, ...) - assert(is_idf(idf), msg = paste0("Measure should return an `Idf` object, not `", class(idf)[[1]], "`.")) + if (!is_idf(idf)) { + stop("Measure should return an 'Idf' object, not '", class(idf)[[1]], "'") + } idf } @@ -437,9 +442,9 @@ param_apply_measure <- function (self, private, measure, ..., .names = NULL, .en if (is.null(.names)) { nms <- paste0(mea_nm, "_", seq_along(out)) } else { - assert(have_same_len(out, .names), - msg = paste0(length(out), " models created with only ", length(.names), " names given.") - ) + if (length(out) != length(.names)) { + stop(paste0(length(out), " models created with only ", length(.names), " names given")) + } nms <- make.unique(as.character(.names), sep = "_") } @@ -448,7 +453,7 @@ param_apply_measure <- function (self, private, measure, ..., .names = NULL, .en private$m_idfs <- out # log unique ids - private$m_log$idf_uuid <- vcapply(private$m_idfs, function (idf) ._get_private(idf)$m_log$uuid) + private$m_log$idf_uuid <- vcapply(private$m_idfs, function (idf) get_priv_env(idf)$m_log$uuid) log_new_uuid(private$m_log) if (eplusr_option("verbose_info")) { @@ -469,11 +474,11 @@ param_apply_measure <- function (self, private, measure, ..., .names = NULL, .en # param_run {{{ param_run <- function (self, private, output_dir = NULL, wait = TRUE, force = FALSE, copy_external = FALSE, echo = wait) { if (is.null(private$m_idfs)) { - abort("error_no_measured_applied", "No measure has been applied.") + abort("No measure has been applied.") } # check if generated models have been modified outside - uuid <- vapply(private$m_idfs, function (idf) ._get_private(idf)$m_log$uuid, character(1)) + uuid <- vapply(private$m_idfs, function (idf) get_priv_env(idf)$m_log$uuid, character(1)) if (any(uuid != private$m_log$idf_uuid)) { warn("warning_param_modified", paste0( @@ -493,22 +498,21 @@ param_run <- function (self, private, output_dir = NULL, wait = TRUE, force = FA } # }}} # param_save {{{ +#' @importFrom checkmate assert_string param_save <- function (self, private, dir = NULL, separate = TRUE, copy_external = FALSE) { if (is.null(private$m_idfs)) { - abort("error_no_measured_applied", - "No parametric models found since no measure has been applied." - ) + abort("No parametric models found since no measure has been applied.") } # restore uuid - uuid <- vcapply(private$m_idfs, function (idf) ._get_private(idf)$m_log$uuid) + uuid <- vcapply(private$m_idfs, function (idf) get_priv_env(idf)$m_log$uuid) path_idf <- normalizePath(private$m_seed$path(), mustWork = TRUE) if (is.null(dir)) dir <- dirname(path_idf) else { - assert(is_string(dir)) + assert_string(dir) } if (!dir.exists(dir)) { @@ -545,7 +549,7 @@ param_save <- function (self, private, dir = NULL, separate = TRUE, copy_externa # if not assign original here, the model modification checkings in `$run()` # may be incorrect. for (i in seq_along(uuid)) { - log <- ._get_private(private$m_idfs[[i]])$m_log + log <- get_priv_env(private$m_idfs[[i]])$m_log log$uuid <- uuid[[i]] } @@ -580,7 +584,7 @@ param_print <- function (self, private) { #' @export `==.ParametricJob` <- function (e1, e2) { if (!inherits(e2, "ParametricJob")) return(FALSE) - identical(._get_private(e1)$m_log$uuid, ._get_private(e2)$m_log$uuid) + identical(get_priv_env(e1)$m_log$uuid, get_priv_env(e2)$m_log$uuid) } #' @export diff --git a/R/rdd.R b/R/rdd.R index f53dd1434..4c995cbac 100644 --- a/R/rdd.R +++ b/R/rdd.R @@ -59,18 +59,20 @@ NULL #' } #' @rdname rdd #' @author Hongyuan Jia +#' @importFrom checkmate assert_file_exists # read_rdd {{{ read_rdd <- function (path) { - assert(has_ext(path, "rdd")) + assert_file_exists(path, "r", "rdd") parse_rdd_file(path)[] } # }}} #' @rdname rdd +#' @importFrom checkmate assert_file_exists #' @export # read_mdd {{{ read_mdd <- function (path) { - assert(has_ext(path, "mdd")) + assert_file_exists(path, "r", "mdd") parse_rdd_file(path, mdd = TRUE)[] } # }}} @@ -99,9 +101,7 @@ parse_rdd_file <- function (path, mdd = FALSE) { if (!stri_startswith_fixed(header$string, "Program Version") && !stri_startswith_fixed(header$string, "! Program Version")) { type <- if (mdd) "mdd" else "rdd" - abort(paste0("error_invalid_", type), - paste0("Input file is not a valid EnergyPlus ", stri_trans_toupper(type), " file.") - ) + abort(paste0("Input file is not a valid EnergyPlus ", stri_trans_toupper(type), " file.")) } rdd_head <- stri_split_fixed(header$string, ",")[[1L]] @@ -253,9 +253,10 @@ parse_rdd_file <- function (path, mdd = FALSE) { #' mdd_to_load(mdd_sub, class = "Output:Meter:MeterFileOnly") #' } #' @export +#' @importFrom checkmate assert_string # rdd_to_load {{{ rdd_to_load <- function (rdd, key_value, reporting_frequency) { - assert(is_rdd(rdd)) + if (is_rdd(rdd)) abort("'rdd' must be an RddFile object") # copy the original rdd <- copy(rdd) @@ -267,9 +268,9 @@ rdd_to_load <- function (rdd, key_value, reporting_frequency) { set(rdd, NULL, "class", "Output:Variable") if (!missing(key_value)) { - assert(is_string(key_value)) + assert_string(key_value) set(rdd, NULL, "key_value", key_value) - } else if (!has_name(rdd, "key_value")) { + } else if (!has_names(rdd, "key_value")) { set(rdd, NULL, "key_value", "*") } else { set(rdd, NULL, "key_value", as.character(rdd$key_value)) @@ -278,7 +279,7 @@ rdd_to_load <- function (rdd, key_value, reporting_frequency) { if (!missing(reporting_frequency)) { rep_freq <- validate_report_freq(reporting_frequency) set(rdd, NULL, "reporting_frequency", rep_freq) - } else if (!has_name(rdd, "reporting_frequency")) { + } else if (!has_names(rdd, "reporting_frequency")) { set(rdd, NULL, "reporting_frequency", "Timestep") } else { set(rdd, NULL, "reporting_frequency", @@ -309,7 +310,7 @@ mdd_to_load <- function (mdd, reporting_frequency, class = c("Output:Meter", "Output:Meter:MeterFileOnly", "Output:Meter:Cumulative", "Output:Meter:Cumulative:MeterFileOnly")) { - assert(is_mdd(mdd)) + if (is_mdd(rdd)) stop("'mdd' must be an MddFile object") ver <- attr(mdd, "eplus_version") class <- match.arg(class) @@ -324,7 +325,7 @@ mdd_to_load <- function (mdd, reporting_frequency, class = c("Output:Meter", if (!missing(reporting_frequency)) { rep_freq <- validate_report_freq(reporting_frequency) set(mdd, NULL, "reporting_frequency", rep_freq) - } else if (!has_name(mdd, "reporting_frequency")) { + } else if (!has_names(mdd, "reporting_frequency")) { set(mdd, NULL, "reporting_frequency", "Timestep") } else { set(mdd, NULL, "reporting_frequency", @@ -350,20 +351,14 @@ mdd_to_load <- function (mdd, reporting_frequency, class = c("Output:Meter", # validate_report_freq {{{ validate_report_freq <- function (reporting_frequency, scalar = TRUE) { - if (scalar) assert(is_string(reporting_frequency)) + if (scalar) assert_string(reporting_frequency) all_freq <- c("Detailed", "Timestep", "Hourly", "Daily", "Monthly", "RunPeriod", "Environment", "Annual") freq <- match_in_vec(reporting_frequency, all_freq, label = TRUE) - assert(no_na(freq), - msg = paste0("Invalid reporting frequency found: ", - collapse(unique(reporting_frequency[is.na(freq)])), ". All possible values: ", - collapse(all_freq), "." - ), - err_type = "error_invalid_reporting_frequency" - ) + assert_subset(freq, all_freq, empty.ok = FALSE) freq } diff --git a/R/sql.R b/R/sql.R index 743f9fda8..d11a8ab40 100644 --- a/R/sql.R +++ b/R/sql.R @@ -66,13 +66,14 @@ EplusSql <- R6::R6Class(classname = "EplusSql", cloneable = FALSE, #' } #' } #' + #' @importFrom checkmate assert_file_exists initialize = function (sql) { - assert(is_string(sql), has_ext(sql, "sql")) + assert_file_exists(sql, "r", "sql") private$m_path_sql <- normalizePath(sql, mustWork = TRUE) private$m_path_idf <- paste0(tools::file_path_sans_ext(private$m_path_sql), ".idf") - if (!file.exists(private$m_path_idf)) { + if (!checkmate::test_file_exists(private$m_path_idf)) { private$m_path_idf <- file.path(dirname(private$m_path_sql), "in.idf") - if (!file.exists(private$m_path_idf)) { + if (!checkmate::test_file_exists(private$m_path_idf)) { private$m_path_idf <- NULL } } diff --git a/R/transition.R b/R/transition.R index b95fc071f..7bee5172b 100644 --- a/R/transition.R +++ b/R/transition.R @@ -1956,7 +1956,7 @@ trans_funs$f890t900 <- function (idf) { num_rep <- value[12L + 2L] if (!is.na(start_year)) { - if (!test_strint(start_year)) { + if (!checkmate::test_count(as.numeric(start_year))) { abort(paste0( "For 'RunPeriod' ", surround(name[[1L]]), " [ID:", id[[1L]], "]:\n", "Invalid 'Start Year' value (", surround(start_year), ") found." @@ -1969,7 +1969,7 @@ trans_funs$f890t900 <- function (idf) { # convert num of repeats to integer if (!is.na(num_rep)) { - if (!test_strint(num_rep)) { + if (!checkmate::test_count(as.numeric(num_rep))) { abort(paste0( "For 'RunPeriod' ", surround(name[[1L]]), " [ID:", id[[1L]], "]:\n", "Invalid 'Number of Times Runperiod to be Repeated' value (", @@ -2074,8 +2074,8 @@ trans_funs$f890t900 <- function (idf) { end_year <- start_year + num_rep value[7L] <- as.character(end_year) - end_month <- assert_strint(value[5L], coerce = TRUE, .var.name = "End Month") - end_day <- assert_strint(value[6L], coerce = TRUE, .var.name = "End Day of Month") + end_month <- assert_integerish(as.numeric(value[5L]), len = 1L, lower = 1L, upper = 12L, any.missing = FALSE, coerce = TRUE, .var.name = "End Month") + end_day <- assert_integerish(as.numeric(value[6L]), len = 1L, lower = 1L, upper = 31L, any.missing = FALSE, coerce = TRUE, .var.name = "End Day of Month") # check if leap day of end date is specified in an non-leap year if ((!leap_year(end_year)) && end_month == 2L && end_day == 29L) { diff --git a/man/assertion.Rd b/man/assertion.Rd index 8bdee4c81..d9d988ae5 100644 --- a/man/assertion.Rd +++ b/man/assertion.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/assertions.R +% Please edit documentation in R/assert.R \name{is_eplus_ver} \alias{is_eplus_ver} \alias{is_idd_ver} diff --git a/tests/testthat/test-assert.R b/tests/testthat/test-assert.R index d8deab687..3a492d36c 100644 --- a/tests/testthat/test-assert.R +++ b/tests/testthat/test-assert.R @@ -1,11 +1,13 @@ context("Assertions") -test_that("list checking", { +test_that("Assertion functions", { expect_equal(convert_to_eplus_ver(8), numeric_version("8.0.0")) - expect_equal(convert_to_eplus_ver(c(8, 8.1), max = TRUE), numeric_version(c("8.0.0", "8.1.0"))) + expect_equal(convert_to_eplus_ver(c(8, 9), max = TRUE), numeric_version(c("8.0.0", "9.0.1"))) + expect_equal(convert_to_eplus_ver(c(8, 9), max = FALSE), list(numeric_version(c("8.0.0")), numeric_version(c("9.0.0", "9.0.1")))) expect_equal(convert_to_idd_ver(8), numeric_version("8.0.0")) - expect_equal(convert_to_idd_ver(c(8, 8.1), max = TRUE), numeric_version(c("8.0.0", "8.1.0"))) + expect_equal(convert_to_idd_ver(c(8, 9), max = TRUE), numeric_version(c("8.0.0", "9.0.1"))) + expect_equal(convert_to_idd_ver(c(8, 9), max = FALSE), list(numeric_version(c("8.0.0")), numeric_version(c("9.0.0", "9.0.1")))) expect_false(is_eplus_ver("a")) expect_true(is_eplus_ver(8)) @@ -46,53 +48,25 @@ test_that("list checking", { expect_true(is_rdd(structure(data.table(), class = "RddFile"))) expect_true(is_mdd(structure(data.table(), class = "MddFile"))) - expect_true(is_range(ranger())) - - expect_error(assert_strint(1)) - expect_error(assert_strint("a")) - expect_equal(assert_strint("1"), "1") - expect_equal(assert_strint("1", coerce = TRUE), 1L) - - expect_true(has_len(1:2, 2)) - expect_true(has_len(1:2, ranger(0))) - expect_true(has_len(1:2, c(1,2))) - expect_true(has_len(1:2, 1, 1)) - expect_false(has_len(1:2, 3)) - expect_false(has_len(1:2, c(0,4))) - expect_false(has_len(1:2, 1, 2)) - expect_true(have_same_len(1:2, 3:4)) - expect_true(have_same_len(mtcars, seq_len(nrow(mtcars)))) - expect_false(have_same_len(1, 1:2)) + expect_error(assert_same_len(1:5, 1)) + expect_equal(assert_same_len(1:5, 1:5), 1:5) expect_true(in_range(1, ranger(1, TRUE, 2, FALSE))) expect_false(in_range(1, ranger(1, FALSE, 2, FALSE))) + expect_false(in_range(1, ranger(1, FALSE, 2, TRUE))) - expect_true(is_named(list(a = 1))) - expect_false(is_named(list(1))) - - expect_true(is_choice("yes", c("Yes", "no"))) - expect_true(is_choice("yes", c("Yes", "no"))) - - expect_true(has_name(c(a = 1), "a")) - expect_false(has_name(c(a = 1), "b")) - expect_true(has_name(c(a = 1, b = 2), "a")) - expect_false(has_name(c(a = 1, b = 2), c("b", "c"))) + expect_true(has_names(c(a = 1), "a")) + expect_false(has_names(c(a = 1), "b")) + expect_true(has_names(c(a = 1, b = 2), "a")) + expect_equal(has_names(c(a = 1, b = 2), c("b", "c")), c(TRUE, FALSE)) expect_true(has_ext(tempfile(fileext = ".idf"), "idf")) expect_false(has_ext(tempfile(fileext = ".idf"), "epw")) - expect_true(has_ext(tempfile(fileext = ".idf"), c("idf", "imf"))) - expect_false(has_ext(tempfile(fileext = ".idf"), c("epw", "imf"))) - expect_true(is_epwdate(epw_date(1))) expect_false(is_epwdate(epw_date(-1))) - expect_true(are_epwdate(epw_date(0:5))) - expect_false(are_epwdate(epw_date(-1:5))) - - expect_true(assert(8 > 5, 2 > 1)) - expect_is(tryCatch(assert(is_scalar(1:2)), error = identity), "error_not_scalar") - expect_error(assert(is_scalar(1:2)), class = "error_not_scalar") - expect_error(assert(is_scalar(1:2), msg = "a"), "a", class = "error_not_scalar") - expect_error(assert(is_scalar(1:2), prefix = "input"), "input is not a scalar", class = "error_not_scalar") + expect_is(is_windows(), "logical") + expect_is(is_linux(), 'logical') + expect_is(is_macos(), 'logical') }) diff --git a/tests/testthat/test_assert.R b/tests/testthat/test_assert.R deleted file mode 100644 index 00bc2e71e..000000000 --- a/tests/testthat/test_assert.R +++ /dev/null @@ -1,101 +0,0 @@ -context("Assertions") - -test_that("list checking", { - expect_true(is_version(8)) - expect_true(is_version(8.8)) - expect_true(is_version("8.8")) - expect_false(is_version("8.a")) - - expect_false(is_eplus_ver("a")) - expect_true(is_eplus_ver(8)) - expect_true(is_eplus_ver(8.5)) - expect_true(is_eplus_ver("latest")) - expect_false(is_eplus_ver("8.8.8")) - - expect_false(is_eplus_path(tempfile())) - expect_true({ - file.create(file.path(tempdir(), "Energy+.idd")) - file.create(file.path(tempdir(), "energyplus")) - file.create(file.path(tempdir(), "energyplus.exe")) - is_eplus_path(tempdir()) - }) - - expect_false(not_empty(NULL)) - expect_false(not_empty(data.frame())) - expect_true(is_empty(NULL)) - expect_true(is_empty(data.frame())) - - expect_true(is_integer(8)) - expect_false(is_integer(8.1)) - - expect_equal(are_integer(c(8, 0, NA_integer_)), FALSE) - expect_true(is_count(8)) - expect_true(is_count(8.0)) - expect_false(is_count(8.1)) - expect_false(is_count(0)) - expect_true(is_count(0, zero = TRUE)) - expect_false(is_count(c(8, 8))) - expect_false(is_count(NA_integer_)) - - expect_equal(are_count(8.0), TRUE) - expect_equal(are_count(c(0, 1, 8, NA_integer_)), FALSE) - expect_equal(are_count(c(0, 8), zero = TRUE), TRUE) - - expect_true(is_string("a")) - expect_false(is_string(1L)) - expect_false(is_string(NA)) - expect_false(is_string(NA_character_)) - - expect_true(is_flag(TRUE)) - expect_false(is_flag(NA)) - expect_false(is_flag(0)) - expect_false(is_flag(c(TRUE, TRUE))) - - expect_true(is_scalar("a")) - expect_false(is_scalar(NULL)) - expect_false(is_scalar(list())) - expect_false(is_scalar(1:2)) - - expect_true(has_len(1:2, 2)) - expect_true(has_len(1:2, ranger(0))) - expect_true(has_len(1:2, c(1,2))) - expect_true(has_len(1:2, 1, 1)) - expect_false(has_len(1:2, 3)) - expect_false(has_len(1:2, c(0,4))) - expect_false(has_len(1:2, 1, 2)) - expect_true(have_same_len(1:2, 3:4)) - expect_true(have_same_len(mtcars, seq_len(nrow(mtcars)))) - expect_false(have_same_len(1, 1:2)) - - expect_true(in_range(1, ranger(1, TRUE, 2, FALSE))) - expect_false(in_range(1, ranger(1, FALSE, 2, FALSE))) - - expect_true(is_named(list(a = 1))) - expect_false(is_named(list(1))) - - expect_true(is_choice("yes", c("Yes", "no"))) - expect_true(is_choice("yes", c("Yes", "no"))) - - expect_true(has_name(c(a = 1), "a")) - expect_false(has_name(c(a = 1), "b")) - expect_true(has_name(c(a = 1, b = 2), "a")) - expect_false(has_name(c(a = 1, b = 2), c("b", "c"))) - - expect_true(has_ext(tempfile(fileext = ".idf"), "idf")) - expect_false(has_ext(tempfile(fileext = ".idf"), "epw")) - - expect_true(has_ext(tempfile(fileext = ".idf"), c("idf", "imf"))) - expect_false(has_ext(tempfile(fileext = ".idf"), c("epw", "imf"))) - - expect_true(is_epwdate(epw_date(1))) - expect_false(is_epwdate(epw_date(-1))) - - expect_true(are_epwdate(epw_date(0:5))) - expect_false(are_epwdate(epw_date(-1:5))) - - expect_true(assert(8 > 5, 2 > 1)) - expect_is(tryCatch(assert(is_scalar(1:2)), error = identity), "error_not_scalar") - expect_error(assert(is_scalar(1:2)), class = "error_not_scalar") - expect_error(assert(is_scalar(1:2), msg = "a"), "a", class = "error_not_scalar") - expect_error(assert(is_scalar(1:2), prefix = "input"), "input is not a scalar", class = "error_not_scalar") -}) diff --git a/tests/testthat/test_format.R b/tests/testthat/test_format.R deleted file mode 100644 index 58619b3d5..000000000 --- a/tests/testthat/test_format.R +++ /dev/null @@ -1,435 +0,0 @@ -context("Format methods") - -test_that("Idd formatting", { - # only test on UTF-8 supported platform - skip_if_not(cli::is_utf8_output()) - - # IDD {{{ - idd_parsed <- parse_idd_file(text("idd", "9.9.9")) - - expect_equal(format_name(idd_parsed$field), - c("!- Test Field", - "!- Test Character Field 1", - "!- Test Numeric Field 1 {m}", - "!- Test Numeric Field 2", - "!- Test Character Field 2" - ) - ) - - expect_equal(format_index(idd_parsed$field), as.character(c(1, 1:4))) - - expect_equal(format_index(idd_parsed$field, required = TRUE), - c("1 ", "1*", "2 ", "3 ", "4 ") - ) - - expect_equal(format_field(idd_parsed$field, leading = 2), - c(" !- Test Field", - " !- Test Character Field 1", - " !- Test Numeric Field 1 {m}", - " !- Test Numeric Field 2", - " !- Test Character Field 2" - ) - ) - - expect_equal(format_field(idd_parsed$field, leading = 2, prefix = FALSE), - c(" Test Field", - " Test Character Field 1", - " Test Numeric Field 1 {m}", - " Test Numeric Field 2", - " Test Character Field 2" - ) - ) - expect_equal(format_objects(idd_parsed$group, component = "group")$out, - c("Group: ", "Group: ") - ) - expect_error(format_objects(idd_parsed$group, component = c("group", "class"))$out) - expect_equal(format_objects(idd_parsed$class, component = "class")$out, - c("Class: ", "Class: ") - ) - expect_equal( - format_objects(idd_parsed$group[idd_parsed$class, on = "group_id"], - component = c("group", "class"), brief = TRUE)$out, - c("[1] Group: ", "[1] Group: ") - ) - expect_equal( - format_objects(idd_parsed$group[idd_parsed$class, on = "group_id"], - component = c("group", "class"), brief = FALSE)$out, - list( - c("Group: ", "└─ Class: ", ""), - c("Group: ", "└─ Class: ", "") - ) - ) - expect_equal(format_objects(idd_parsed$field, component = "field")$out, - c("Field: <1: Test Field>", - "Field: <1: Test Character Field 1>", - "Field: <2: Test Numeric Field 1 {m}>", - "Field: <3: Test Numeric Field 2>", - "Field: <4: Test Character Field 2>" - ) - ) - expect_equal( - format_objects( - idd_parsed$class[, .(group_id, class_id, class_name)][ - idd_parsed$field[, .(class_id, field_id, field_index, field_name, units, ip_units)], on = "class_id"], - c("class", "field"), brief = FALSE)$out, - list( - c("Class: ", - "└─ Field: <1: Test Field>", "" - ), - c("Class: ", - "├─ Field: <1: Test Character Field 1>", - "│─ Field: <2: Test Numeric Field 1 {m}>", - "│─ Field: <3: Test Numeric Field 2>", - "└─ Field: <4: Test Character Field 2>", - "" - ) - ) - ) - expect_equal( - format_objects( - idd_parsed$group[ - idd_parsed$class[, .(group_id, class_id, class_name)], on = "group_id"][ - idd_parsed$field[, .(class_id, field_id, field_index, field_name, units, ip_units)], on = "class_id"], - c("group", "class", "field"))$out, - list( - c("Group: ", - "└─ [1] Class: ", - "" - ), - c("Group: ", - "└─ [4] Class: ", - "" - ) - ) - ) - expect_equal( - format_objects( - idd_parsed$group[ - idd_parsed$class[, .(group_id, class_id, class_name)], on = "group_id"][ - idd_parsed$field[, .(class_id, field_id, field_index, field_name, units, ip_units)], on = "class_id"], - c("group", "class", "field"), brief = FALSE)$out, - list( - list( "Group: ", - c("└─ Class: ", - " └─ Field: <1: Test Field>", - " ") - ), - list( "Group: ", - c("└─ Class: ", - " ├─ Field: <1: Test Character Field 1>", - " │─ Field: <2: Test Numeric Field 1 {m}>", - " │─ Field: <3: Test Numeric Field 2>", - " └─ Field: <4: Test Character Field 2>", - " ") - ) - ) - ) - - expect_equal( - format_objects( - idd_parsed$group[ - idd_parsed$class[, .(group_id, class_id, class_name)], on = "group_id"][ - idd_parsed$field[, .(class_id, field_id, field_index, field_name, units, ip_units)], on = "class_id"], - c("field", "class"), brief = FALSE)$out, - list( - c("Class: ", - "└─ Field: <1: Test Field>", - "" - ), - c("Class: ", - "├─ Field: <1: Test Character Field 1>", - "│─ Field: <2: Test Numeric Field 1 {m}>", - "│─ Field: <3: Test Numeric Field 2>", - "└─ Field: <4: Test Character Field 2>", - "" - ) - ) - ) - - expect_equal( - format_objects( - idd_parsed$group[ - idd_parsed$class[, .(group_id, class_id, class_name)], on = "group_id"][ - idd_parsed$field[, .(class_id, field_id, field_index, field_name, units, ip_units)], on = "class_id"], - c("field", "group"), brief = FALSE)$out, - list( - c("Group: ", - "└─ Field: <1: Test Field>", - "" - ), - c("Group: ", - "├─ Field: <1: Test Character Field 1>", - "│─ Field: <2: Test Numeric Field 1 {m}>", - "│─ Field: <3: Test Numeric Field 2>", - "└─ Field: <4: Test Character Field 2>", - "" - ) - ) - ) - - # Relation - expect_equal( - format_idd_relation(get_idd_relation(idd_parsed, direction = "ref_by", name = TRUE), "ref_by")$fmt, - c("Class: ", - "└─ Field: <1: Test Field>", - " ^~~~~~~~~~~~~~~~~~~~~~", - " └─ Class: ", - " └─ Field: <1: Test Character Field 1>", - "" - ) - ) - expect_equal( - format_idd_relation(get_idd_relation(idd_parsed, direction = "ref_to", name = TRUE), "ref_to")$fmt, - c("Class: ", - "└─ Field: <1: Test Character Field 1>", - " v~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~", - " └─ Class: ", - " └─ Field: <1: Test Field>", - "" - ) - ) - # }}} - # IDF {{{ - idd_parsed <- ._get_private(use_idd(8.8, "auto"))$m_idd_env - idf_parsed <- parse_idf_file(text("idf", "8.8")) - add_joined_cols(idd_parsed$field, idf_parsed$value, "field_id", c("field_index", "type_enum", "units", "ip_units")) - # object - expect_equal(format_objects(idf_parsed$object, component = "object")$out, - c("Object [ID:1] ", - "Object [ID:2] ", - "Object [ID:3] ", - "Object [ID:4] ", - "Object [ID:5]" - ) - ) - # value - expect_equal( - format_objects(get_idf_value(idd_parsed, idf_parsed, property = c("type_enum", "units", "ip_units")), - component = "value", merge = FALSE)$out[c(1,2,4,5)], - c('Value: <"WD01">', - 'Value: <"MediumSmooth">', - 'Value: <0.115>', - 'Value: <513>') - ) - expect_equal( - format_objects(get_idf_value(idd_parsed, idf_parsed), - component = "value", merge = TRUE)$out[c(1,2,4,5)], - c("1: \"WD01\", !- Name", - "2: \"MediumSmooth\",!- Roughness", - "4: 0.115, !- Conductivity {W/m-K}", - "5: 513, !- Density {kg/m3}" - ) - ) - expect_equal( - format_objects(get_idf_value(idd_parsed, idf_parsed, property = c("units", "ip_units", "type_enum")), - component = c("object", "value"))$out[c(1,2,4,5)], - c("[09] Object [ID:1] ", - "[05] Object [ID:2] ", - "[04] Object [ID:4] ", - "[01] Object [ID:5]" - ) - ) - expect_equal( - format_objects(get_idf_value(idd_parsed, idf_parsed), - component = c("object", "value"), - brief = FALSE)$out[[1L]], - c("Object [ID:1] ", - "├─ 1: \"WD01\", !- Name", - "│─ 2: \"MediumSmooth\",!- Roughness", - "│─ 3: 0.019099999, !- Thickness {m}", - "│─ 4: 0.115, !- Conductivity {W/m-K}", - "│─ 5: 513, !- Density {kg/m3}", - "│─ 6: 1381, !- Specific Heat {J/kg-K}", - "│─ 7: 0.9, !- Thermal Absorptance", - "│─ 8: 0.78, !- Solar Absorptance", - "└─ 9: 0.78; !- Visible Absorptance", - "" - ) - ) - expect_equal( - format_objects(get_idf_value(idd_parsed, idf_parsed), - component = c("object", "value"), - brief = FALSE, merge = FALSE)$out[[1L]], - c("Object [ID:1] ", - "├─ Value: <\"WD01\">", - "│─ Value: <\"MediumSmooth\">", - "│─ Value: <0.019099999>", - "│─ Value: <0.115>", - "│─ Value: <513>", - "│─ Value: <1381>", - "│─ Value: <0.9>", - "│─ Value: <0.78>", - "└─ Value: <0.78>", - "" - ) - ) - expect_equal( - unlist(format_objects(get_idf_value(idd_parsed, idf_parsed), - component = c("object", "field", "value"), - brief = FALSE, merge = FALSE)$out[[1L]]), - c("Object [ID:1] ", - "├─ Field: <1: Name>", - "│ └─ Value: <\"WD01\">", - "│ ", - "│─ Field: <2: Roughness>", - "│ └─ Value: <\"MediumSmooth\">", - "│ ", - "│─ Field: <3: Thickness {m}>", - "│ └─ Value: <0.019099999>", - "│ ", - "│─ Field: <4: Conductivity {W/m-K}>", - "│ └─ Value: <0.115>", - "│ ", - "│─ Field: <5: Density {kg/m3}>", - "│ └─ Value: <513>", - "│ ", - "│─ Field: <6: Specific Heat {J/kg-K}>", - "│ └─ Value: <1381>", - "│ ", - "│─ Field: <7: Thermal Absorptance>", - "│ └─ Value: <0.9>", - "│ ", - "│─ Field: <8: Solar Absorptance>", - "│ └─ Value: <0.78>", - "│ ", - "└─ Field: <9: Visible Absorptance>", - " └─ Value: <0.78>", - " " - ) - ) - expect_equal( - unlist(format_objects(get_idf_value(idd_parsed, idf_parsed), - component = c("class", "object", "value"), - brief = FALSE)$out[[1L]]), - c("Class: ", - "├─ Object [ID:1] ", - "│ ├─ 1: \"WD01\", !- Name", - "│ │─ 2: \"MediumSmooth\",!- Roughness", - "│ │─ 3: 0.019099999, !- Thickness {m}", - "│ │─ 4: 0.115, !- Conductivity {W/m-K}", - "│ │─ 5: 513, !- Density {kg/m3}", - "│ │─ 6: 1381, !- Specific Heat {J/kg-K}", - "│ │─ 7: 0.9, !- Thermal Absorptance", - "│ │─ 8: 0.78, !- Solar Absorptance", - "│ └─ 9: 0.78; !- Visible Absorptance", - "│ ", - "└─ Object [ID:4] ", - " ├─ 1: \"WD02\", !- Name", - " │─ 2: \"MediumSmooth\",!- Roughness", - " │─ 3: 0.019099999, !- Thickness {m}", - " └─ 4: 0.115; !- Conductivity {W/m-K}", - " " - ) - ) - expect_equal( - unlist(format_objects(get_idf_value(idd_parsed, idf_parsed), - component = c("class", "object", "field", "value"), - brief = FALSE, merge = FALSE)$out[[1L]]), - c("Class: ", - "├─ Object [ID:1] ", - "│ ├─ Field: <1: Name>", - "│ │ └─ Value: <\"WD01\">", - "│ │ ", - "│ │─ Field: <2: Roughness>", - "│ │ └─ Value: <\"MediumSmooth\">", - "│ │ ", - "│ │─ Field: <3: Thickness {m}>", - "│ │ └─ Value: <0.019099999>", - "│ │ ", - "│ │─ Field: <4: Conductivity {W/m-K}>", - "│ │ └─ Value: <0.115>", - "│ │ ", - "│ │─ Field: <5: Density {kg/m3}>", - "│ │ └─ Value: <513>", - "│ │ ", - "│ │─ Field: <6: Specific Heat {J/kg-K}>", - "│ │ └─ Value: <1381>", - "│ │ ", - "│ │─ Field: <7: Thermal Absorptance>", - "│ │ └─ Value: <0.9>", - "│ │ ", - "│ │─ Field: <8: Solar Absorptance>", - "│ │ └─ Value: <0.78>", - "│ │ ", - "│ └─ Field: <9: Visible Absorptance>", - "│ └─ Value: <0.78>", - "│ ", - "└─ Object [ID:4] ", - " ├─ Field: <1: Name>", - " │ └─ Value: <\"WD02\">", - " │ ", - " │─ Field: <2: Roughness>", - " │ └─ Value: <\"MediumSmooth\">", - " │ ", - " │─ Field: <3: Thickness {m}>", - " │ └─ Value: <0.019099999>", - " │ ", - " └─ Field: <4: Conductivity {W/m-K}>", - " └─ Value: <0.115>", - " " - ) - ) - - # Format IDF - # add field index, class id and class name - add_joined_cols(idf_parsed$object, idf_parsed$value, "object_id", "class_id") - add_joined_cols(idd_parsed$class, idf_parsed$value, "class_id", "class_name") - add_joined_cols(idd_parsed$field, idf_parsed$value, "field_id", c("field_index", "units", "ip_units", "field_name")) - expect_silent({fmt <- format_idf(idf_parsed$value, idf_parsed$object)}) - expect_equal(names(fmt), c("header", "format")) - expect_equal(fmt$header, - c("!-Generator eplusr", - "!-Option SortedOrder", - "", - "!-NOTE: All comments with '!-' are ignored by the IDFEditor and are generated automatically.", - "!- Use '!' comments if they need to be retained when using the IDFEditor." - ) - ) - expect_equal(fmt$format$class_id, c(1L, 55L, 90L, 103L)) - expect_equal(fmt$format$fmt[[2L]], - list("!- =========== ALL OBJECTS IN CLASS: MATERIAL ===========", - list(c("! this is a test comment for WD01"), - c("Material,", - " WD01, !- Name", - " MediumSmooth, !- Roughness", - " 0.019099999, !- Thickness {m}", - " 0.115, !- Conductivity {W/m-K}", - " 513, !- Density {kg/m3}", - " 1381, !- Specific Heat {J/kg-K}", - " 0.9, !- Thermal Absorptance", - " 0.78, !- Solar Absorptance", - " 0.78; !- Visible Absorptance") - ), - list(NULL, - c("Material,", - " WD02, !- Name", - " MediumSmooth, !- Roughness", - " 0.019099999, !- Thickness {m}", - " 0.115; !- Conductivity {W/m-K}" - ) - ) - ) - ) - - expect_null(format_idf(idf_parsed$value, idf_parsed$object, header = FALSE)$header) - expect_null(format_idf(idf_parsed$value, idf_parsed$object, comment = FALSE)$format$fmt[[2L]][[2L]][[1L]]) - expect_silent({fmt <- format_idf(idf_parsed$value, idf_parsed$object, - dt_order = data.table(object_id = 1:5, object_order = 0L), - save_format = "new_top")}) - expect_equal(fmt$format$object_id, 1:5) - expect_equal(fmt$format$fmt[[1L]], - list(c("! this is a test comment for WD01"), - c("Material,", - " WD01, !- Name", - " MediumSmooth, !- Roughness", - " 0.019099999, !- Thickness {m}", - " 0.115, !- Conductivity {W/m-K}", - " 513, !- Density {kg/m3}", - " 1381, !- Specific Heat {J/kg-K}", - " 0.9, !- Thermal Absorptance", - " 0.78, !- Solar Absorptance", - " 0.78; !- Visible Absorptance") - ) - ) - # }}} -}) diff --git a/tests/testthat/test_group.R b/tests/testthat/test_group.R deleted file mode 100644 index 36e2c3721..000000000 --- a/tests/testthat/test_group.R +++ /dev/null @@ -1,183 +0,0 @@ -context("Group metiods") - -test_that("Group methods", { - skip_on_cran() - eplusr_option(verbose_info = FALSE) - - if (!is_avail_eplus(8.8)) install_eplus(8.8) - - path_idfs <- normalizePath(file.path(eplus_config(8.8)$dir, "ExampleFiles", - c("1ZoneDataCenterCRAC_wPumpedDXCoolingCoil.idf", - "1ZoneEvapCooler.idf", - "1ZoneParameterAspect.idf", - "1ZoneUncontrolled_DD2009.idf", - "1ZoneUncontrolled_DDChanges.idf" - ) - )) - path_epws <- normalizePath(list.files(file.path(eplus_config(8.8)$dir, "WeatherData"), - "\\.epw", full.names = TRUE)[1:5]) - - expect_error(group_job(empty_idf(8.8)), class = "error_idf_not_local") - # can stop if input model is not saved after modification - expect_error( - group_job( - list( - {idf <- read_idf(path_idfs[[1]]); idf$RunPeriod <- NULL; idf}, - path_idfs[1] - ), - NULL - ), - class = "error_invalid_group_idf_input" - ) - expect_silent(group_job(path_idfs, path_epws[1L])) - expect_silent(group_job(path_idfs[1], path_epws)) - expect_silent(grp <- group_job(path_idfs, NULL)) - expect_equal(grp$status(), - list(run_before = FALSE, alive = FALSE, terminated = NA, - successful = NA, changed_after = NA, - job_status = data.table(index = 1:5, status = "idle", - idf = path_idfs, epw = NA_character_ - ) - ) - ) - - # Run and Status {{{ - # can run the simulation and get status of simulation - expect_equal({grp$run(dir = file.path(tempdir(), "test"), echo = FALSE); status <- grp$status(); names(status)}, - c("run_before", "alive", "terminated", "successful", "changed_after", "job_status") - ) - expect_equal(status[c("run_before", "alive", "terminated", "successful", "changed_after")], - list(run_before = TRUE, alive = FALSE, terminated = FALSE, - successful = FALSE, changed_after = FALSE - ) - ) - expect_equal(names(status$job_status), - c("index", "status", "idf", "epw", "exit_status", "start_time", "end_time", - "energyplus", "output_dir", "stdout", "stderr" - ) - ) - expect_equal(status$job_status$exit_status, c(0L, 0L, 1L, 0L, 0L)) - # }}} - - # Errors {{{ - expect_silent(grp$errors(2)) - expect_warning(grp$errors(3), class = "warn_job_error") - # }}} - - # Output Dir{{{ - expect_silent(grp$output_dir(1)) - expect_warning(grp$output_dir(3), class = "warn_job_error") - # }}} - - # Table {{{ - expect_error(grp$list_table()) - expect_silent(lsts <- grp$list_table(c(1,2,4))) - expect_is(lsts, "list") - expect_equal(length(lsts), 3L) - - expect_error(grp$read_table()) - expect_silent(tables <- grp$read_table(c(1, 2, 4), "Zones")) - expect_equal(names(tables)[1], "case") - # }}} - - # RDD & MDD {{{ - expect_error(grp$read_rdd(3)) - expect_silent(rdds <- grp$read_rdd(c(1,2,4))) - expect_is(rdds, "data.table") - expect_error(grp$read_mdd(3)) - expect_silent(mdds <- grp$read_mdd(c(1,2,4))) - expect_is(mdds, "data.table") - # }}} - - # Report Data Dict {{{ - expect_error(grp$report_data_dict(), class = "error_job_error") - expect_is(grp$report_data_dict(c(1,2,4,5)), "data.table") - expect_true(has_name(grp$report_data_dict(c(1,2,4,5)), "case")) - expect_equal(nrow(grp$report_data_dict(2)), 22) - expect_equal(nrow(grp$report_data_dict("1zoneevapcooler")), 22) - # }}} - - # Tabular Data {{{ - expect_equal(nrow(grp$tabular_data(c(1,2,4,5))), 14668) - expect_equal(nrow(grp$tabular_data(c(1,2,4,5), - report_name = c( - "AnnualBuildingUtilityPerformanceSummary", - "Initialization Summary" - ))), - 9032 - ) - expect_equal(nrow(grp$tabular_data(c(1,2,4,5), table_name = "Site and Source Energy")), 12 * 4) - expect_equal(nrow(grp$tabular_data(c(1,2,4,5), column_name = "Total Energy")), 4 * 4) - expect_equal(nrow(grp$tabular_data(c(1,2,4,5), row_name = "Total Site Energy")), 3 * 4) - expect_equal(nrow(grp$tabular_data(2)), 2172) - expect_equal(nrow(grp$tabular_data(2, - report_name = c( - "AnnualBuildingUtilityPerformanceSummary", - "Initialization Summary" - ))), - 769 - ) - expect_equal(nrow(grp$tabular_data("1zoneevapcooler", table_name = "Site and Source Energy")), 12) - expect_equal(nrow(grp$tabular_data("1zoneevapcooler" ,column_name = "Total Energy")), 4) - expect_equal(nrow(grp$tabular_data("1zoneevapcooler", row_name = "Total Site Energy")), 3) - # can convert to wide table - expect_silent(tab <- grp$tabular_data("1zoneevapcooler", row_name = "Total Site Energy", wide = TRUE)) - expect_equal(names(tab), "AnnualBuildingUtilityPerformanceSummary.Entire Facility.Site and Source Energy") - expect_equivalent(tab[[1L]][, lapply(.SD, class)], - data.table( - case = "character", - report_name = "character", - report_for = "character", - table_name = "character", - row_name = "character", - `Total Energy [GJ]` = "numeric", - `Energy Per Total Building Area [MJ/m2]` = "numeric", - `Energy Per Conditioned Building Area [MJ/m2]` = "numeric" - ) - ) - # }}} - - # Report Data {{{ - expect_equal(nrow(grp$report_data(2, grp$report_data_dict(2))), 872) - expect_equal(nrow(grp$report_data(2)), 872) - expect_equal(nrow(grp$report_data(2, "")), 8) - expect_equal(lubridate::tz(grp$report_data(2, tz = "Asia/Shanghai")$datetime), - "Asia/Shanghai" - ) - expect_equal(names(grp$report_data(2, all = TRUE)), - c("case", "datetime", "month", "day", "hour", "minute", "dst", "interval", - "simulation_days", "day_type", "environment_name", - "environment_period_index", "is_meter", "type", "index_group", - "timestep_type", "key_value", "name", "reporting_frequency", - "schedule_name", "units", "value" - ) - ) - grp$report_data(2) - expect_equal(nrow(grp$report_data(2, period = seq( - lubridate::ymd_hms("2019-12-21 1:0:0"), lubridate::ymd_hms("2019-12-22 0:0:0"), "1 hour") - )), 414) - expect_equal(nrow(grp$report_data(2, month = 12)), 436) - expect_equal(nrow(grp$report_data(2, month = 12, hour = 1)), 18) - expect_equal(nrow(grp$report_data(2, minute = 0)), 872) - expect_equal(nrow(grp$report_data(2, interval = 60)), 872) - expect_equal(nrow(grp$report_data(2, simulation_days = 1)), 872) - expect_equal(nrow(grp$report_data(2, day_type = "WinterDesignDay")), 436) - expect_equal(nrow(grp$report_data(2, environment_name = "DENVER CENTENNIAL ANN HTG 99.6% CONDNS DB")), 436) - # }}} - - # S3 {{{ - expect_true(grp == grp) - expect_false(grp != grp) - # }}} - - skip_on_os("mac") - # Locate Output {{{ - expect_error(grp$locate_output(suffix = ".sql")) - expect_equal(grp$locate_output(2, suffix = ".sql"), - normalizePath(file.path(tempdir(), "test", - tools::file_path_sans_ext(basename(path_idfs[2])), - paste0(tools::file_path_sans_ext(basename(path_idfs[2])), ".sql") - )) - ) - # }}} -}) diff --git a/tests/testthat/test_install.R b/tests/testthat/test_install.R deleted file mode 100644 index bdad3ace7..000000000 --- a/tests/testthat/test_install.R +++ /dev/null @@ -1,13 +0,0 @@ -test_that("Install", { - skip_on_cran() - expect_equal(as.character(avail_eplus()), names(.globals$eplus)) - if (is_avail_eplus(8.8)) expect_error(install_eplus(8.8, local = TRUE)) - if (is_macos()) expect_error(install_eplus(8.8, local = TRUE)) - else install_eplus(8.8, local = TRUE, force = TRUE) - - # test if patch on EnergyPlus v9.1 and above works - if (!is_avail_eplus(9.1)) install_eplus(9.1, local = TRUE) - if (!is_avail_eplus(9.2)) install_eplus(9.2, local = TRUE) - expect_true(is_avail_eplus(9.1)) - expect_true(is_avail_eplus(9.2)) -}) diff --git a/tests/testthat/test_job.R b/tests/testthat/test_job.R deleted file mode 100644 index 84960ed42..000000000 --- a/tests/testthat/test_job.R +++ /dev/null @@ -1,116 +0,0 @@ -context("Job methods") - -test_that("Job methods", { - eplusr_option(verbose_info = FALSE) - skip_on_cran() - if (!is_avail_eplus(8.8)) install_eplus(8.8) - - example <- copy_example() - - expect_silent(job <- eplus_job(example$idf, example$epw)) - - # can get job status - expect_equal( - job$status(), - list(run_before = FALSE, alive = FALSE, terminated = NA, - successful = NA, changed_after = NA) - ) - - # can run job in waiting mode - expect_silent(job$run(wait = TRUE, echo = FALSE)) - - # can refresh job status - expect_equal(job$status(), - list(run_before = TRUE, alive = FALSE, terminated = FALSE, - successful = TRUE, changed_after = FALSE) - ) - - # can kill job - expect_silent(job$kill()) - - example <- copy_example() - job <- eplus_job(example$idf, example$epw) - expect_is({job$run(echo = FALSE);job$errors()}, "ErrFile") - expect_is(job$errors(info = TRUE), "ErrFile") - expect_silent({err <- job$errors()}) - expect_equal(names(err), c("index", "envir_index", "envir", - "level_index", "level", "message" - )) - expect_equal(attr(err, "eplus_version"), numeric_version("8.8.0")) - expect_equal(attr(err, "eplus_build"), "7c3bbe4830") - expect_equal(attr(err, "idd_version"), numeric_version("8.8.0")) - expect_equal(attr(err, "successful"), TRUE) - expect_equal(attr(err, "terminated"), FALSE) - - # can retrieve simulation data - idf <- read_idf(example$idf) - job <- idf$run(example$epw, dir = NULL, echo = FALSE) - # can get all table names - expect_equal(length(job$list_table()), 44L) - - # can read table - expect_error(job$read_table("a"), "no such table") - expect_is(job$read_table("Zones"), "data.table") - - # can read report data dictionary - expect_is(job$report_data_dict(), "data.table") - - # can read report data - expect_equal(nrow(job$report_data()), 3840L) - expect_equal(nrow(job$report_data("")), 1344L) - expect_equal(nrow(job$report_data( - "TRANSFORMER 1", "Transformer Load Loss Rate")), - 192L - ) - expect_equal(nrow(job$report_data( - "TRANSFORMER 1", "Transformer Load Loss Rate")), - 192L - ) - expect_equal(year(job$report_data( - "TRANSFORMER 1", "Transformer Load Loss Rate", year = 2010)$datetime), - rep(2010, 192) - ) - expect_equal(lubridate::tz(job$report_data(tz = "Asia/Shanghai")$datetime), - "Asia/Shanghai" - ) - expect_equal(job$report_data(case = "test")$case, rep("test", 3840)) - expect_equal(names(job$report_data(all = TRUE)), - c("case", "datetime", "month", "day", "hour", "minute", "dst", "interval", - "simulation_days", "day_type", "environment_name", - "environment_period_index", "is_meter", "type", "index_group", - "timestep_type", "key_value", "name", "reporting_frequency", - "schedule_name", "units", "value" - ) - ) - expect_equal(nrow(job$report_data(period = seq( - lubridate::ymd_hms("2019-01-14 0:0:0"), lubridate::ymd_hms("2019-01-15 0:0:0"), "15 min") - )), 1900) - expect_equal(nrow(job$report_data(month = 1)), 1920) - expect_equal(nrow(job$report_data(month = 1, hour = 1)), 80) - expect_equal(nrow(job$report_data(minute = 0)), 960) - expect_equal(nrow(job$report_data(interval = 15)), 3840) - expect_equal(nrow(job$report_data(simulation_days = 1)), 3840) - expect_equal(nrow(job$report_data(day_type = "Tuesday")), 3840) - expect_equal(nrow(job$report_data(environment_name = "WINTERDAY")), 1920) - - expect_true(job == job) - expect_false(job != job) - - skip_on_os("mac") - # can get path - expect_equal(job$path(), c(idf = example$idf, epw = example$epw)) - expect_equal(job$path("idf"), c(example$idf)) - expect_equal(job$path("epw"), c(example$epw)) - - # can get output dir - expect_equal(job$output_dir(), dirname(example$idf)) - - # can get output file path - expect_equal( - job$locate_output(".err"), - normalizePath(file.path(tempdir(), "5Zone_Transformer.err")) - ) - - clean_wd(example$idf) - unlink(c(example$idf, example$epw)) -}) diff --git a/tests/testthat/test_param.R b/tests/testthat/test_param.R deleted file mode 100644 index 503dd8c03..000000000 --- a/tests/testthat/test_param.R +++ /dev/null @@ -1,281 +0,0 @@ -context("Parametric metiods") - -test_that("Parametric methods", { - skip_on_cran() - eplusr_option(verbose_info = FALSE) - - if (!is_avail_eplus(8.8)) install_eplus(8.8) - - expect_error(param_job(empty_idf(8.8), NULL), class = "error_idf_not_local") - - example <- copy_example() - - param <- param_job(example$idf, example$epw) - - priv <- get_priv_env(param) - - # Seed and Weather {{{ - expect_is(param$seed(), "Idf") - expect_is(param$weather(), "Epw") - expect_null(param$models()) - # }}} - - # Measure {{{ - pa <- param_job(example$idf, NULL) - test <- function(x, y) x - param$apply_measure(test, 1:5) - expect_equal(names(param$models()), sprintf("test_%i", 1:5)) - param$apply_measure(function (x, y) x, 1:5) - expect_equal(names(param$models()), sprintf("case_%i", 1:5)) - - # set_infil_rate {{{ - set_infil_rate <- function (idf, infil_rate) { - - # validate input value - # this is optional, as validations will be made when setting values to `Idf` - stopifnot(is.numeric(infil_rate), infil_rate >= 0) - - if (!idf$is_valid_class("ZoneInfiltration:DesignFlowRate")) - stop("Input model does not have any object in class `ZoneInfiltration:DesignFlowRate`") - - ids <- idf$object_id("ZoneInfiltration:DesignFlowRate", simplify = TRUE) - val <- rep(list(list(design_flow_rate_calculation_method = "AirChanges/Hour", air_changes_per_hour = infil_rate)), length(ids)) - setattr(val, "names", paste0("..", ids)) - idf$set(val) - - idf - } - # }}} - # names are unique - param$apply_measure(set_infil_rate, seq(0, 4, by = 1), .names = rep("A", 5)) - expect_equal(names(priv$m_idfs), c("A", paste0("A_", 1:4))) - - # auto assign name - param$apply_measure(set_infil_rate, seq(0, 4, by = 1), .names = NULL) - expect_equal(length(priv$m_idfs), 5) - expect_equal(names(priv$m_idfs), paste0("set_infil_rate_", 1:5)) - expect_equal(unname(vlapply(priv$m_idfs, is_idf)), rep(TRUE, times = 5)) - # }}} - - # Models {{{ - expect_is(param$models(), "list") - expect_equal(length(param$models()), 5) - expect_equal(names(param$models()), paste0("set_infil_rate_", 1:5)) - expect_equal(unname(vlapply(priv$m_idfs, is_idf)), rep(TRUE, times = 5)) - # }}} - - # Save {{{ - # can preserve name - param$apply_measure(set_infil_rate, seq(0, 4, by = 1), .names = 1:5) - expect_equal(names(param$models()), as.character(1:5)) - expect_silent(paths <- param$save()) - expect_equal(paths, - data.table::data.table( - model = normalizePath(file.path(tempdir(), 1:5, paste0(1:5, ".idf"))), - weather = normalizePath(file.path(tempdir(), 1:5, basename(param$weather()$path()))) - ) - ) - - param$apply_measure(set_infil_rate, seq(0, 4, by = 1), .names = NULL) - expect_silent(paths <- param$save()) - expect_equal(paths, - data.table::data.table( - model = normalizePath(file.path(tempdir(), paste0("set_infil_rate_", 1:5), paste0("set_infil_rate_", 1:5, ".idf"))), - weather = normalizePath(file.path(tempdir(), paste0("set_infil_rate_", 1:5), basename(param$weather()$path()))) - ) - ) - expect_silent(paths <- param$save(separate = FALSE)) - expect_equal(paths, - data.table::data.table( - model = normalizePath(file.path(tempdir(), paste0("set_infil_rate_", 1:5, ".idf"))), - weather = normalizePath(file.path(tempdir(), basename(param$weather()$path()))) - ) - ) - # can save when no weather are provided - expect_silent(paths <- { - empty <- empty_idf(8.8) - empty$save(tempfile(fileext = ".idf")) - par <- param_job(empty, NULL) - par$apply_measure(function (idf, x) idf, 1:2, .names = 1:2) - par$save() - }) - expect_equal(paths, - data.table::data.table( - model = normalizePath(file.path(tempdir(), 1:2, paste0(1:2, ".idf"))), - weather = NA_character_ - ) - ) - # }}} - - # Run and Status {{{ - - # Can detect if models are modified before running - model2 <- param$models()$set_infil_rate_2 - model2$Output_Variable <- NULL - expect_warning(param$run(echo = FALSE), class = "warn_param_modified") - - dir_nms <- paste0("set_infil_rate_", 1:5) - param$apply_measure(set_infil_rate, seq(0, 4, by = 1), .names = NULL) - # can run the simulation and get status of simulation - expect_equal({param$run(dir = NULL, echo = FALSE); status <- param$status(); names(status)}, - c("run_before", "alive", "terminated", "successful", "changed_after", "job_status") - ) - expect_equal(status[c("run_before", "alive", "terminated", "successful", "changed_after")], - list(run_before = TRUE, alive = FALSE, terminated = FALSE, - successful = TRUE, changed_after = FALSE - ) - ) - expect_equal(names(status$job_status), - c("index", "status", "idf", "epw", "exit_status", "start_time", "end_time", - "energyplus", "output_dir", "stdout", "stderr" - ) - ) - # }}} - - # Report Data Dict {{{ - expect_is(param$report_data_dict(), "data.table") - expect_true(has_name(param$report_data_dict(), "case")) - expect_equal(nrow(param$report_data_dict(2)), 20) - expect_equal(nrow(param$report_data_dict("set_infil_rate_2")), 20) - # }}} - - # Tabular Data {{{ - expect_equal(nrow(param$tabular_data()), 6662 * 5) - expect_equal(nrow(param$tabular_data( - report_name = c( - "AnnualBuildingUtilityPerformanceSummary", - "Initialization Summary" - ))), - 3774 * 5 - ) - expect_equal(nrow(param$tabular_data(table_name = "Site and Source Energy")), 12 * 5) - expect_equal(nrow(param$tabular_data(column_name = "Total Energy")), 4 * 5) - expect_equal(nrow(param$tabular_data(row_name = "Total Site Energy")), 3 * 5) - expect_equal(nrow(param$tabular_data(2)), 6662) - expect_equal(nrow(param$tabular_data(2, - report_name = c( - "AnnualBuildingUtilityPerformanceSummary", - "Initialization Summary" - ))), - 3774 - ) - expect_equal(nrow(param$tabular_data(2, table_name = "Site and Source Energy")), 12) - expect_equal(nrow(param$tabular_data(2, column_name = "Total Energy")), 4) - expect_equal(nrow(param$tabular_data(2, row_name = "Total Site Energy")), 3) - expect_equal(nrow(param$tabular_data("set_infil_rate_2")), 6662) - expect_equal(nrow(param$tabular_data("set_infil_rate_2", - report_name = c( - "AnnualBuildingUtilityPerformanceSummary", - "Initialization Summary" - ))), - 3774 - ) - expect_equal(nrow(param$tabular_data("set_infil_rate_2", table_name = "Site and Source Energy")), 12) - expect_equal(nrow(param$tabular_data("set_infil_rate_2" ,column_name = "Total Energy")), 4) - expect_equal(nrow(param$tabular_data("set_infil_rate_2", row_name = "Total Site Energy")), 3) - # }}} - - # Report Data {{{ - expect_equal(nrow(param$report_data(2, param$report_data_dict())), 3840) - expect_equal(nrow(param$report_data(2)), 3840) - expect_equal(nrow(param$report_data(2, "")), 1344L) - expect_equal(nrow(param$report_data(2, - "TRANSFORMER 1", "Transformer Load Loss Rate")), - 192L - ) - expect_equal(nrow(param$report_data(2, - "TRANSFORMER 1", "Transformer Load Loss Rate")), - 192L - ) - expect_equal(year(param$report_data(2, - "TRANSFORMER 1", "Transformer Load Loss Rate", year = 2010)$datetime), - rep(2010, 192) - ) - expect_equal(lubridate::tz(param$report_data(2, tz = "Asia/Shanghai")$datetime), - "Asia/Shanghai" - ) - expect_equal(names(param$report_data(2, all = TRUE)), - c("case", "datetime", "month", "day", "hour", "minute", "dst", "interval", - "simulation_days", "day_type", "environment_name", - "environment_period_index", "is_meter", "type", "index_group", - "timestep_type", "key_value", "name", "reporting_frequency", - "schedule_name", "units", "value" - ) - ) - expect_equal(nrow(param$report_data(2, period = seq( - lubridate::ymd_hms("2019-01-14 0:0:0"), lubridate::ymd_hms("2019-01-15 0:0:0"), "15 min") - )), 1900) - expect_equal(nrow(param$report_data(2, month = 1)), 1920) - expect_equal(nrow(param$report_data(2, month = 1, hour = 1)), 80) - expect_equal(nrow(param$report_data(2, minute = 0)), 960) - expect_equal(nrow(param$report_data(2, interval = 15)), 3840) - expect_equal(nrow(param$report_data(2, simulation_days = 1)), 3840) - expect_equal(nrow(param$report_data(2, day_type = "Tuesday")), 3840) - expect_equal(nrow(param$report_data(2, environment_name = "WINTERDAY")), 1920) - - expect_equal(nrow(param$report_data(NULL, param$report_data_dict())), 3840 * 5) - expect_equal(nrow(param$report_data()), 3840 * 5) - expect_equal(nrow(param$report_data(NULL, "")), 1344L * 5) - expect_equal(nrow(param$report_data(NULL, - "TRANSFORMER 1", "Transformer Load Loss Rate")), - 192L * 5 - ) - expect_equal(nrow(param$report_data(NULL, - "TRANSFORMER 1", "Transformer Load Loss Rate")), - 192L * 5 - ) - expect_equal(year(param$report_data(NULL, - "TRANSFORMER 1", "Transformer Load Loss Rate", year = 2010)$datetime), - rep(2010, 192 * 5) - ) - expect_equal(lubridate::tz(param$report_data(NULL, tz = "Asia/Shanghai")$datetime), - "Asia/Shanghai" - ) - expect_equal(names(param$report_data(all = TRUE)), - c("case", "datetime", "month", "day", "hour", "minute", "dst", "interval", - "simulation_days", "day_type", "environment_name", - "environment_period_index", "is_meter", "type", "index_group", - "timestep_type", "key_value", "name", "reporting_frequency", - "schedule_name", "units", "value" - ) - ) - expect_equal(nrow(param$report_data(period = seq( - lubridate::ymd_hms("2019-01-14 0:0:0"), lubridate::ymd_hms("2019-01-15 0:0:0"), "15 min") - )), 1900 * 5) - expect_equal(nrow(param$report_data(month = 1)), 1920 * 5) - expect_equal(nrow(param$report_data(month = 1, hour = 1)), 80 * 5) - expect_equal(nrow(param$report_data(minute = 0)), 960 * 5) - expect_equal(nrow(param$report_data(interval = 15)), 3840 * 5) - expect_equal(nrow(param$report_data(simulation_days = 1)), 3840 * 5) - expect_equal(nrow(param$report_data(day_type = "Tuesday")), 3840 * 5) - expect_equal(nrow(param$report_data(environment_name = "WINTERDAY")), 1920 * 5) - # }}} - - # S3 {{{ - expect_true(param == param) - expect_false(param != param) - # }}} - - skip_on_os("mac") - # Locate Output {{{ - expect_equal(param$locate_output(suffix = ".sql"), - normalizePath(file.path(dirname(example$idf), dir_nms, paste0(dir_nms, ".sql")))) - expect_equal(param$locate_output(2, suffix = ".sql"), - normalizePath(file.path(dirname(example$idf), dir_nms[2], paste0(dir_nms[2], ".sql")))) - expect_equal(param$locate_output("set_infil_rate_2", suffix = ".sql"), - normalizePath(file.path(dirname(example$idf), dir_nms[2], paste0(dir_nms[2], ".sql")))) - # }}} - - # Output Dir {{{ - expect_equal(param$output_dir(), - normalizePath(file.path(dirname(example$idf), dir_nms))) - expect_equal(param$output_dir(2), - normalizePath(file.path(dirname(example$idf), dir_nms[2]))) - expect_equal(param$output_dir("set_infil_rate_2"), - normalizePath(file.path(dirname(example$idf), dir_nms[2]))) - # }}} - - # clean - lapply(dir_nms, unlink, recursive = TRUE, force = TRUE) - unlink(c(example$idf, example$epw)) -}) diff --git a/tests/testthat/test_rdd.R b/tests/testthat/test_rdd.R deleted file mode 100644 index 476c052f8..000000000 --- a/tests/testthat/test_rdd.R +++ /dev/null @@ -1,58 +0,0 @@ -context("Rdd") - -test_that("Rdd", { - skip_on_cran() - if (!is_avail_eplus(8.8)) install_eplus(8.8) - - idf <- read_idf(example()) - job <- idf$run(NULL, dir = tempdir(), echo = FALSE) - - expect_silent(rdd <- job$read_rdd()) - expect_silent(mdd <- job$read_mdd()) - - expect_equal(names(rdd), c("index", "reported_time_step", "report_type", "variable", "units")) - expect_equal(names(mdd), c("index", "reported_time_step", "report_type", "variable", "units")) - expect_equal(attr(rdd, "eplus_version"), idf$version()) - expect_equal(attr(mdd, "eplus_version"), idf$version()) - - expect_error(rdd_to_load(rdd, reporting_frequency = "hour"), - class = "error_invalid_reporting_frequency" - ) - expect_error(mdd_to_load(mdd, reporting_frequency = "hour"), - class = "error_invalid_reporting_frequency" - ) - expect_error(rdd_to_load(rdd[1:2][, reporting_frequency := c(1, 2)]), - class = "error_invalid_reporting_frequency" - ) - expect_error(mdd_to_load(mdd[1:2][, reporting_frequency := c(1, 2)]), - class = "error_invalid_reporting_frequency" - ) - expect_error(mdd_to_load(mdd, class = "")) - - expect_equivalent(rdd_to_load(rdd[1L]), - data.table(id = 1L, class = "Output:Variable", index = 1:3, - field = c("Key Value", "Variable Name", "Reporting Frequency"), - value = c("*", "Site Outdoor Air Drybulb Temperature", "Timestep") - ) - ) - - expect_equivalent(rdd_to_load(rdd[1L][, key_value := "Environment"]), - data.table(id = 1L, class = "Output:Variable", index = 1:3, - field = c("Key Value", "Variable Name", "Reporting Frequency"), - value = c("Environment", "Site Outdoor Air Drybulb Temperature", "Timestep") - ) - ) - - expect_equivalent(mdd_to_load(mdd[1L]), - data.table(id = 1L, class = "Output:Meter", index = 1:2, - field = c("Key Name", "Reporting Frequency"), - value = c("Electricity:Facility", "Timestep") - ) - ) - expect_equivalent(mdd_to_load(mdd[1L], class = "Output:Meter:MeterFileOnly"), - data.table(id = 1L, class = "Output:Meter:MeterFileOnly", index = 1:2, - field = c("Key Name", "Reporting Frequency"), - value = c("Electricity:Facility", "Timestep") - ) - ) -}) diff --git a/tests/testthat/test_reload.R b/tests/testthat/test_reload.R deleted file mode 100644 index b045e0293..000000000 --- a/tests/testthat/test_reload.R +++ /dev/null @@ -1,83 +0,0 @@ -context("Reload") - -# Reload {{{ -test_that("Reload", { - eplusr_option(verbose_info = FALSE) - if (!is_avail_eplus(8.8)) install_eplus(8.8) - - example <- copy_example() - - idf <- read_idf(example$idf) - epw <- read_epw(example$epw) - job <- idf$run(NULL, tempdir(), echo = FALSE) - grp <- group_job(idf, NULL)$run(tempdir()) - par <- param_job(idf, NULL) - par$apply_measure(function (x, y) x, 1:2) - par$run(tempdir()) - - f_idf <- tempfile(fileext = ".rds") - f_epw <- tempfile(fileext = ".rds") - f_job <- tempfile(fileext = ".rds") - f_grp <- tempfile(fileext = ".rds") - f_par <- tempfile(fileext = ".rds") - saveRDS(idf, f_idf) - saveRDS(epw, f_epw) - saveRDS(job, f_job) - saveRDS(grp, f_grp) - saveRDS(par, f_par) - - idf <- readRDS(f_idf) - epw <- readRDS(f_epw) - job <- readRDS(f_job) - grp <- readRDS(f_grp) - par <- readRDS(f_par) - - expect_equal(data.table::truelength(get_priv_env(idf)$idd_env()$group), 0L) - expect_equal(data.table::truelength(get_priv_env(idf)$idd_env()$class), 0L) - expect_equal(data.table::truelength(get_priv_env(idf)$idd_env()$field), 0L) - expect_equal(data.table::truelength(get_priv_env(idf)$idd_env()$reference), 0L) - expect_equal(data.table::truelength(get_priv_env(idf)$idf_env()$object), 0L) - expect_equal(data.table::truelength(get_priv_env(idf)$idf_env()$value), 0L) - expect_equal(data.table::truelength(get_priv_env(idf)$idf_env()$reference), 0L) - expect_equal(data.table::truelength(get_priv_env(epw)$m_header$typical), 0L) - expect_equal(data.table::truelength(get_priv_env(epw)$m_header$ground), 0L) - expect_equal(data.table::truelength(get_priv_env(epw)$m_header$holiday$holiday), 0L) - expect_equal(data.table::truelength(get_priv_env(epw)$m_header$period$period), 0L) - expect_equal(data.table::truelength(get_priv_env(epw)$m_data), 0L) - - expect_silent(reload(idf)) - expect_silent(reload(epw)) - expect_silent(reload(job)) - expect_silent(reload(grp)) - expect_silent(reload(par)) - - expect_idf_reloaded <- function (idf) { - expect_true(data.table::truelength(get_priv_env(idf)$idd_env()$group) > 0L) - expect_true(data.table::truelength(get_priv_env(idf)$idd_env()$class) > 0L) - expect_true(data.table::truelength(get_priv_env(idf)$idd_env()$field) > 0L) - expect_true(data.table::truelength(get_priv_env(idf)$idd_env()$reference) > 0L) - expect_true(data.table::truelength(get_priv_env(idf)$idf_env()$object) > 0L) - expect_true(data.table::truelength(get_priv_env(idf)$idf_env()$value) > 0L) - expect_true(data.table::truelength(get_priv_env(idf)$idf_env()$reference) > 0L) - } - - expect_true(data.table::truelength(get_priv_env(epw)$m_header$typical) > 0L) - expect_true(data.table::truelength(get_priv_env(epw)$m_header$ground) > 0L) - expect_true(data.table::truelength(get_priv_env(epw)$m_header$holiday$holiday) > 0L) - expect_true(data.table::truelength(get_priv_env(epw)$m_header$period$period) > 0L) - expect_true(data.table::truelength(get_priv_env(epw)$m_data) > 0L) - - expect_idf_reloaded(idf) - expect_idf_reloaded(get_priv_env(job)$m_idf) - expect_idf_reloaded(get_priv_env(par)$m_seed) - lapply(get_priv_env(grp)$m_idfs, expect_idf_reloaded) - lapply(get_priv_env(par)$m_idfs, expect_idf_reloaded) - expect_true(data.table::truelength(get_priv_env(grp)$m_job) > 0L) - expect_true(data.table::truelength(get_priv_env(par)$m_job) > 0L) - - expect_true(job$status()$successful) - expect_true(grp$status()$successful) - expect_true(par$status()$successful) - -}) -# }}} diff --git a/tests/testthat/test_sql.R b/tests/testthat/test_sql.R deleted file mode 100644 index 393bcfecc..000000000 --- a/tests/testthat/test_sql.R +++ /dev/null @@ -1,164 +0,0 @@ -context("Sql methods") - -test_that("Sql methods", { - skip_on_cran() - if (!is_avail_eplus(8.8)) install_eplus(8.8) - - example <- copy_example() - idf <- read_idf(example$idf) - - expect_is(job <- read_idf(example$idf)$run(example$epw, NULL, echo = FALSE), "EplusJob") - expect_silent(sql <- eplus_sql(job$locate_output(".sql"))) - - # path - expect_equal(sql$path(), normalizePath(file.path(tempdir(), "5Zone_Transformer.sql"))) - expect_equal(sql$path_idf(), normalizePath(file.path(tempdir(), "5Zone_Transformer.idf"))) - - # can get all table names - expect_equal(length(sql$list_table()), 44L) - - # can read table - expect_error(sql$read_table("a"), "no such table") - expect_is(sql$read_table("Zones"), "data.table") - - # can read report data dictionary - expect_is(sql$report_data_dict(), "data.table") - - # can read report data - expect_equal(nrow(sql$report_data(sql$report_data_dict())), 3840L) - expect_equal(nrow(sql$report_data()), 3840L) - expect_equal(nrow(sql$report_data("")), 1344L) - expect_equal(nrow(sql$report_data( - "TRANSFORMER 1", "Transformer Load Loss Rate")), - 192L - ) - expect_equal(nrow(sql$report_data( - "TRANSFORMER 1", "Transformer Load Loss Rate")), - 192L - ) - expect_equal(year(sql$report_data( - "TRANSFORMER 1", "Transformer Load Loss Rate", year = 2010)$datetime), - rep(2010, 192) - ) - expect_equal(lubridate::tz(sql$report_data(tz = "Asia/Shanghai")$datetime), - "Asia/Shanghai" - ) - expect_equal(sql$report_data(case = "test")$case, rep("test", 3840)) - expect_equal(names(sql$report_data(all = TRUE)), - c("case", "datetime", "month", "day", "hour", "minute", "dst", "interval", - "simulation_days", "day_type", "environment_name", - "environment_period_index", "is_meter", "type", "index_group", - "timestep_type", "key_value", "name", "reporting_frequency", - "schedule_name", "units", "value" - ) - ) - expect_equal(nrow(sql$report_data(period = seq( - lubridate::ymd_hms("2019-01-14 0:0:0"), lubridate::ymd_hms("2019-01-15 0:0:0"), "15 min") - )), 1900) - expect_equal(nrow(sql$report_data(month = 1)), 1920) - expect_equal(nrow(sql$report_data(month = 1, hour = 1)), 80) - expect_equal(nrow(sql$report_data(minute = 0)), 960) - expect_equal(nrow(sql$report_data(interval = 15)), 3840) - expect_equal(nrow(sql$report_data(simulation_days = 1)), 3840) - expect_equal(nrow(sql$report_data(day_type = "Tuesday")), 3840) - expect_equal(nrow(sql$report_data(day_type = "normalday")), 3840) - expect_equal(nrow(sql$report_data(day_type = "designday")), 0) - expect_equal(nrow(sql$report_data(environment_name = "WINTERDAY")), 1920) - - expect_equal(nrow(sql$tabular_data()), 6662) - expect_equal(nrow(sql$tabular_data( - report_name = c( - "AnnualBuildingUtilityPerformanceSummary", - "Initialization Summary" - ))), - 3774 - ) - expect_equal(nrow(sql$tabular_data(table_name = "Site and Source Energy")), 12) - expect_equal(nrow(sql$tabular_data(column_name = "Total Energy")), 4) - expect_equal(nrow(sql$tabular_data(row_name = "Total Site Energy")), 3) - # can convert to wide table - expect_silent(tab <- sql$tabular_data(row_name = "Total Site Energy", wide = TRUE, case = NULL)) - expect_equal(names(tab), "AnnualBuildingUtilityPerformanceSummary.Entire Facility.Site and Source Energy") - expect_equivalent( - read_idf(file.path(eplus_config(8.8)$dir, "ExampleFiles/1ZoneUncontrolled.idf"))$ - run(NULL, tempdir(), echo = FALSE)$ - tabular_data(table_name = "Site and Source Energy", wide = TRUE)[[1]][ - , lapply(.SD, class)], - data.table( - case = "character", - report_name = "character", - report_for = "character", - table_name = "character", - row_name = "character", - `Total Energy [GJ]` = "numeric", - `Energy Per Total Building Area [MJ/m2]` = "numeric", - `Energy Per Conditioned Building Area [MJ/m2]` = "numeric" - ) - ) - expect_equivalent(tab[[1L]][, lapply(.SD, class)], - data.table( - report_name = "character", - report_for = "character", - table_name = "character", - row_name = "character", - `Total Energy [GJ]` = "numeric", - `Energy Per Total Building Area [MJ/m2]` = "numeric", - `Energy Per Conditioned Building Area [MJ/m2]` = "numeric" - ) - ) - - skip_on_os("mac") - # can get path - expect_equal(sql$path(), job$locate_output(".sql")) - clean_wd(example$idf) - unlink(c(example$idf, example$epw)) - - skip_on_travis() - skip_on_appveyor() - # can handle multiple time resolution - example <- copy_example() - all_freq <- c("Detailed", "Timestep", "Hourly", "Daily", "Monthly", - "RunPeriod", "Environment", "Annual" - ) - idf <- read_idf(example$idf) - job <- idf$run(NULL, echo = FALSE) - # remove original run periods - idf$RunPeriod <- NULL - # define new run periods - idf$add(RunPeriod = list("Long", 1, 1, 12, 31), RunPeriod = list("Short", 7, 1, 8, 15)) - - # add new output variables to cover all possible report frequency - idf$`Output:Variable` <- NULL - idf$`Output:Meter:MeterFileOnly` <- NULL - rdd <- job$read_rdd()[seq_along(all_freq)][, reporting_frequency := all_freq] - mdd <- job$read_mdd()[seq_along(all_freq)][, reporting_frequency := all_freq] - idf$load(rdd_to_load(rdd)) - idf$load(mdd_to_load(mdd)) - - # save as temp file - idf$save(tempfile(fileext = ".idf")) - # run with weather file - job <- idf$run(example$epw, echo = FALSE) - - res1 <- job$report_data(wide = TRUE) - res2 <- job$report_data(all = TRUE, wide = TRUE) - expect_equal(nrow(res1), nrow(res2)) - - jobs <- lapply(all_freq, function (freq) { - idf$`Output:Variable`<- NULL - - dt <- idf$to_table(class = "Output:Meter") - dt[index == 2L, value := freq] - idf$update(dt) - - idf$save(tempfile(fileext = ".idf")) - - idf$run(NULL, echo = FALSE) - }) - - expect_silent(data_all <- lapply(jobs, function (job) get_sql_report_data(job$locate_output(".sql"), all = TRUE))) - expect_silent(data_wide <- lapply(jobs, function (job) get_sql_report_data(job$locate_output(".sql"), all = TRUE, wide = TRUE))) - - clean_wd(example$idf) - unlink(c(example$idf, example$epw)) -}) diff --git a/tests/testthat/test_units.R b/tests/testthat/test_units.R deleted file mode 100644 index fc46ea776..000000000 --- a/tests/testthat/test_units.R +++ /dev/null @@ -1,124 +0,0 @@ -test_that("Units conversion", { - expect_silent(reg_custom_units()) - - expect_equal(units::set_units(1, "person") + units::set_units(1, "person"), - units::set_units(2, "person") - ) - expect_equal(units::set_units(1, "dollar") + units::set_units(1, "dollar"), - units::set_units(2, "dollar") - ) - expect_equal(units::set_units(1, "Wh") + units::set_units(3600, "J"), - units::set_units(2, "Wh") - ) - expect_equal(units::set_units(units::set_units(1, "inH2O"), "inch_H2O_39F"), - units::set_units(1, "inch_H2O_39F") - ) - - expect_equal(NULL %||% 1, 1) - expect_equal(1 %||% 2, 1) - - expect_equal(collapse(1:3), "'1', '2' and '3'") - expect_equal(collapse(1:3, out = NULL), "1, 2 and 3") - expect_equal(collapse(1, out = NULL), "1") - expect_equal(collapse(1:3, or = NULL), "'1', '2', '3'") - expect_equal(collapse(1:3, or = TRUE), "'1', '2' or '3'") - - expect_equal(surround(1:3), c("'1'", "'2'", "'3'")) - expect_equal(surround(1:3, out = NULL), as.character(1:3)) - - expect_null(rpad(NULL)) - expect_equal(rpad(c(1, 10)), c("1 ", "10")) - expect_equal(rpad(c(1, 10), width = 3), c("1 ", "10 ")) - - expect_null(lpad(NULL)) - expect_equal(lpad(c(1, 10)), c(" 1", "10")) - expect_equal(lpad(c(1, 10), width = 3), c(" 1", " 10")) - - expect_error(read_lines(NULL), "Failed to read input file") - expect_equal(read_lines("a\n b \n c \n"), data.table(line = 1:3, string = c("a", "b", "c"))) - - f <- tempfile() - expect_silent(write_lines(read_lines("a\nb"), f)) - expect_equal(read_lines(f), data.table(line = 1:2, string = c("a", "b"))) - expect_silent(write_lines(c("a", "b"), f)) - expect_equal(read_lines(f), data.table(line = 1:2, string = c("a", "b"))) - expect_silent(write_lines(c("c", "d"), f, append = TRUE)) - expect_equal(read_lines(f), data.table(line = 1:4, string = c("a", "b", "c", "d"))) - expect_error(write_lines(1:3, f), "Must be of type 'character'") - - expect_equal(standardize_ver("latest"), numeric_version("9.2.0")) - expect_equal(standardize_ver("latest", strict = TRUE), numeric_version(NA, strict = FALSE)) - expect_equal(standardize_ver(c(1, 1.1)), numeric_version(c("1.0.0", "1.1.0"))) - expect_equal(standardize_ver(c(1, 1.1), complete = FALSE), numeric_version(c("1.0", "1.1"))) - expect_equal(standardize_ver(c("1.0", "1.1.0.01")), numeric_version(c("1.0.0", "1.1.0"))) - expect_equal(standardize_ver(c("1.0", "1.1.0.01"), complete = FALSE), numeric_version(c("1.0", "1.1.0"))) - - expect_error(match_minor_ver(1), "numeric_version") - expect_error(match_minor_ver(numeric_version(1:2)), "length 1") - expect_equal(match_minor_ver(numeric_version("0.0"), ALL_IDD_VER), numeric_version(NA, strict = FALSE)) - expect_equal(match_minor_ver(numeric_version("9.1"), ALL_IDD_VER), numeric_version("9.1.0")) - expect_equal(match_minor_ver(numeric_version("9.0"), ALL_IDD_VER), numeric_version("9.0.1")) - - expect_equal(vec_depth(NULL), 0L) - expect_equal(vec_depth(character()), 1L) - expect_equal(vec_depth(list()), 1L) - expect_equal(vec_depth(list(list())), 2L) - expect_equal(vec_depth(list(list(NULL))), 2L) - expect_equal(vec_depth(list(list(1))), 3L) - expect_error(vec_depth(environment()), "must be a vector") - - expect_equal(vlapply(1:3, is.integer), rep(TRUE, 3L)) - expect_equal(vlapply(setNames(1:3, c("a", "b", "c")), is.integer), setNames(rep(TRUE, 3L), c("a", "b", "c"))) - expect_equal(vlapply(setNames(1:3, c("a", "b", "c")), is.integer, use.names = FALSE), rep(TRUE, 3L)) - - expect_equal(viapply(1:3, length), rep(1L, 3L)) - expect_equal(viapply(setNames(1:3, c("a", "b", "c")), length), setNames(rep(1L, 3L), c("a", "b", "c"))) - expect_equal(viapply(setNames(1:3, c("a", "b", "c")), length, use.names = FALSE), rep(1L, 3L)) - - expect_equal(vcapply(1:3, paste), as.character(1:3)) - expect_equal(vcapply(setNames(1:3, c("a", "b", "c")), paste), setNames(as.character(1:3), c("a", "b", "c"))) - expect_equal(vcapply(setNames(1:3, c("a", "b", "c")), paste, use.names = FALSE), as.character(1:3)) - - expect_equal(apply2(1:3, 4:6, "+"), list(5L, 7L, 9L)) - expect_equal(apply2_int(1:3, 4:6, "+"), c(5L, 7L, 9L)) - expect_equal(apply2_lgl(1:3, 4:6, ">"), rep(FALSE, 3L)) - expect_equal(apply2_chr(1:3, 4:6, paste0), c("14", "25", "36")) - - expect_equal(underscore_name("Class Name"), "Class_Name") - expect_equal(underscore_name("Class:Name"), "Class_Name") - expect_equal(lower_name("Class:Name"), "class_name") - expect_equal(lower_name("Class Name"), "class_name") - - expect_equal(make_filename(c("", "")), c("_a____", "_a_____1")) - expect_equal(make_filename(c("", ""), unique = FALSE), c("_a____", "_a____")) - - expect_equal(names2(1:3), rep(NA_character_, 3)) - expect_equal(names2(c(a = 1, 2)), c("a", NA_character_)) - - expect_equal(each_length(list(1, 2:3)), c(1L, 2L)) - - expect_equal(ranger()[], list(minimum = -Inf, lower_incbounds = FALSE, maximum = Inf, upper_incbounds = FALSE)) - expect_equal(format(ranger()), "(-Inf, Inf)") - expect_equal(ranger(1, TRUE)[], list(minimum = 1, lower_incbounds = TRUE, maximum = Inf, upper_incbounds = FALSE)) - expect_equal(format(ranger(1, TRUE)), "[1, Inf)") - - expect_error(append_dt(data.table(a = 1), data.table())) - expect_equal(append_dt(data.table(), data.table()), data.table()) - expect_equal(append_dt(data.table(a = 1), data.table(a = 2, b = 1)), data.table(a = c(1, 2))) - expect_equal(append_dt(data.table(a = 1, b = 1), data.table(a = c(1, 2), b = c(3, 4)), "a"), data.table(a = c(1, 2), b = c(3, 4))) - - expect_equal(fmt_dbl(1.111), "1.11") - expect_equal(fmt_dbl(1.111, 1), "1.1") - expect_equal(fmt_int(1), "1.0") - expect_equal(fmt_int(1, 0), "1") - - expect_equal(wday(as.Date("2020-01-01")), 3L) - expect_equal(as.character(wday(as.Date("2020-01-01"), label = TRUE)), "Wednesday") - - expect_equal(str_trunc("abcdefghij", 10), "abcde...") - - expect_equal(match_in_vec("a", LETTERS), 1L) - expect_equal(match_in_vec("a", LETTERS, "aa"), 1L) - expect_equal(match_in_vec("a", LETTERS, "aa", label = TRUE), "A") - expect_equal(match_in_vec("aa", LETTERS, "aa", label = TRUE), "A") -}) diff --git a/tests/testthat/test_validate.R b/tests/testthat/test_validate.R deleted file mode 100644 index 71ff0c9a8..000000000 --- a/tests/testthat/test_validate.R +++ /dev/null @@ -1,256 +0,0 @@ -context("validate") - -# VALIDTATE {{{ -test_that("Validate method", { - idf <- read_idf(example(), use_idd(8.8, "auto")) - idf_env <- ._get_private(idf)$m_idf_env - idd_env <- ._get_private(idf)$idd_env() - - expect_is(empty_validity(), "IdfValidity") - expect_equal(names(empty_validity()), - 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" - ) - ) - - - # MISSING OBJECT {{{ - env_in <- parse_idf_file(text("idf", 8.8)) - expect_equal( - check_missing_object(idd_env, idf_env, env_in)$validity$missing_object, - c("Building", "GlobalGeometryRules") - ) - ids <- get_idd_class(idd_env, c("Building", "GlobalGeometryRules"))$class_id - expect_equal( - check_missing_object(idd_env, idf_env, list(object = list(class_id = ids)))$validity$missing_object, - character(0) - ) - # }}} - - # DUPLICATE OBJECT {{{ - env_in <- list2env(parse_idf_file(text("idf", 8.8))) - env_in$validity <- empty_validity() - expect_equal(nrow(check_duplicate_object(idd_env, idf_env, env_in)$validity$duplicate_object), 0L) - env_in$object <- rbindlist(list( - env_in$object, - data.table( - object_id = 6:7, object_name = c("Bld", "Bld"), - object_name_lower = c("bld", "bld"), - class_id = get_idd_class(idd_env, "Building")$class_id, - comment = list(NULL, NULL) - ) - ), use.names = TRUE) - env_in$value <- rbindlist(list( - env_in$value, - data.table( - object_id = 6:7, - object_name = "Bld", - class_id = get_idd_class(idd_env, "Building")$class_id, - class_name = "Building", - field_id = get_idd_field(idd_env, "Building", "Name")$field_id, - field_index = 1L, - field_name = "Name", - units = NA_character_, - ip_units = NA_character_, - type_enum = IDDFIELD_TYPE$alpha, - value_id = 45:46, - value_chr = "Bld", - value_num = NA_real_ - ) - ), fill = TRUE) - expect_equal(check_duplicate_object(idd_env, idf_env, env_in)$validity$duplicate_object$object_id, - c(6L, 7L) - ) - # }}} - - # CONFLICT NAME {{{ - env_in <- list2env(parse_idf_file(text("idf", 8.8))) - env_in$validity <- empty_validity() - env_in$check_whole <- TRUE - expect_equal(nrow(check_conflict_name(idd_env, idf_env, env_in)$validity$conflict_name), 0L) - env_in$object <- rbindlist(list( - env_in$object, - data.table( - object_id = 6:7, object_name = "Bld", - object_name_lower = "bld", - class_id = get_idd_class(idd_env, "Building")$class_id, - comment = list(NULL, NULL) - ) - ), use.names = TRUE) - env_in$value <- rbindlist(list( - env_in$value, - data.table( - object_id = 6:7, - object_name = c("Bld", "Bld"), - class_id = rep(get_idd_class(idd_env, "Building")$class_id, 2), - class_name = rep("Building", 2), - field_id = rep(get_idd_field(idd_env, "Building", "Name")$field_id, 2), - field_index = rep(1L, 2), - field_name = rep("Name", 2), - units = rep(NA_character_, 2), - ip_units = rep(NA_character_, 2), - type_enum = rep(IDDFIELD_TYPE$alpha, 2), - value_id = 45:46, - value_chr = c("Bld", "Bld"), - value_num = rep(NA_real_, 2) - ) - ), fill = TRUE) - expect_equal(check_conflict_name(idd_env, idf_env, env_in)$validity$conflict_name$object_id, - c(6L, 7L) - ) - # }}} - - # INCOMPLETE EXTENSIBLE {{{ - env_in <- list2env(parse_idf_file(text("idf", 8.8))) - env_in$validity <- empty_validity() - add_joined_cols(env_in$object, env_in$value, "object_id", c("class_id", "object_name")) - add_class_property(idd_env, env_in$value, c("class_id", "class_name")) - add_field_property(idd_env, env_in$value, c("extensible_group", "field_index", "field_name", "units", "ip_units", "type_enum")) - expect_equal(nrow(check_incomplete_extensible(idd_env, idf_env, env_in)$validity$incomplete_extensible), 0L) - invisible(env_in$value[extensible_group == 3L, value_chr := NA_character_]) - expect_silent({err <- check_incomplete_extensible(idd_env, idf_env, env_in)$validity$incomplete_extensible}) - expect_equal(err$object_id, rep(3L, 3)) - expect_equal(err$field_index, 17:19) - expect_equal(err$value_id, 31:33) - # }}} - - # MISSING VALUE {{{ - env_in <- list2env(parse_idf_file(text("idf", 8.8))) - env_in$validity <- empty_validity() - add_joined_cols(env_in$object, env_in$value, "object_id", c("class_id", "object_name")) - add_class_property(idd_env, env_in$value, c("class_id", "class_name")) - add_field_property(idd_env, env_in$value, c("required_field", "field_index", "field_name", "units", "ip_units", "type_enum")) - invisible(env_in$value[J(c(1L, 10L, 15L)), on = "value_id", value_chr := NA_character_]) - - expect_silent({mis <- check_missing_value(idd_env, idf_env, env_in)$validity$missing_value}) - expect_equal(mis$object_id, 1:3) - expect_equal(mis$value_id, c(1L, 10L, 15L)) - # }}} - - # INVALID AUTOSIZE {{{ - env_in <- list2env(parse_idf_file(text("idf", 8.8))) - env_in$validity <- empty_validity() - add_joined_cols(env_in$object, env_in$value, "object_id", c("class_id", "object_name")) - add_class_property(idd_env, env_in$value, c("class_id", "class_name")) - add_field_property(idd_env, env_in$value, c("autosizable", "field_index", "field_name", "units", "ip_units", "type_enum")) - invisible(env_in$value[field_name == "Name", value_chr := "autosize"]) - set(env_in$value, NULL, "value_lower", stri_trans_tolower(env_in$value$value_chr)) - - expect_silent({autosize <- check_invalid_autosize(idd_env, idf_env, env_in)$validity$invalid_autosize}) - expect_equal(autosize$object_id, 1:4) - expect_equal(autosize$field_index, rep(1L, 4L)) - expect_equal(autosize$value_id, c(1L, 10L, 15L, 40L)) - # }}} - - # INVALID AUTOCALCULATE {{{ - env_in <- list2env(parse_idf_file(text("idf", 8.8))) - env_in$validity <- empty_validity() - add_joined_cols(env_in$object, env_in$value, "object_id", c("class_id", "object_name")) - add_class_property(idd_env, env_in$value, c("class_id", "class_name")) - add_field_property(idd_env, env_in$value, c("autocalculatable", "field_index", "field_name", "units", "ip_units", "type_enum")) - invisible(env_in$value[field_name == "Name", value_chr := "autocalculate"]) - set(env_in$value, NULL, "value_lower", stri_trans_tolower(env_in$value$value_chr)) - - expect_silent({autocal <- check_invalid_autocalculate(idd_env, idf_env, env_in)$validity$invalid_autocalculate}) - expect_equal(autocal$object_id, 1:4) - expect_equal(autocal$field_index, rep(1L, 4L)) - expect_equal(autocal$value_id, c(1L, 10L, 15L, 40L)) - # }}} - - # INVALID CHARACTER {{{ - env_in <- list2env(parse_idf_file(text("idf", 8.8))) - env_in$validity <- empty_validity() - add_joined_cols(env_in$object, env_in$value, "object_id", c("class_id", "object_name")) - add_class_property(idd_env, env_in$value, c("class_id", "class_name")) - add_field_property(idd_env, env_in$value, c("field_index", "field_name", "units", "ip_units", "type_enum")) - invisible(env_in$value[field_name == "Name", `:=`(value_chr = "1", value_num = 1L)]) - - expect_silent({chr <- check_invalid_character(idd_env, idf_env, env_in)$validity$invalid_character}) - expect_equal(chr$object_id, 1:4) - expect_equal(chr$field_index, rep(1L, 4L)) - expect_equal(chr$value_id, c(1L, 10L, 15L, 40L)) - # }}} - - # INVALID NUMERIC {{{ - env_in <- list2env(parse_idf_file(text("idf", 8.8))) - env_in$validity <- empty_validity() - add_joined_cols(env_in$object, env_in$value, "object_id", c("class_id", "object_name")) - add_class_property(idd_env, env_in$value, c("class_id", "class_name")) - add_field_property(idd_env, env_in$value, c("field_index", "field_name", "units", "ip_units", "type_enum")) - invisible(env_in$value[object_id == 1L & type_enum <= IDDFIELD_TYPE$real, `:=`(value_num = NA_real_)]) - - expect_silent({num <- check_invalid_numeric(idd_env, idf_env, env_in)$validity$invalid_numeric}) - expect_equal(num$object_id, c(rep(1L, 7), rep(3L, 3))) - expect_equal(num$value_id, c(3:9, 37:39)) - # }}} - - # INVALID INTEGER {{{ - env_in <- list2env(parse_idf_file(text("idf", 8.8))) - env_in$validity <- empty_validity() - add_joined_cols(env_in$object, env_in$value, "object_id", c("class_id", "object_name")) - add_class_property(idd_env, env_in$value, c("class_id", "class_name")) - add_field_property(idd_env, env_in$value, c("field_index", "field_name", "units", "ip_units", "type_enum")) - - invisible(env_in$value[object_id == 1L & type_enum == IDDFIELD_TYPE$real, `:=`(type_enum = IDDFIELD_TYPE$integer)]) - expect_silent({int <- check_invalid_integer(idd_env, idf_env, env_in)$validity$invalid_integer}) - expect_equal(int$object_id, rep(1L, 5)) - expect_equal(int$value_id, c(3L, 4L, 7:9)) - # }}} - - # INVALID CHOICE {{{ - env_in <- list2env(parse_idf_file(text("idf", 8.8))) - env_in$validity <- empty_validity() - add_joined_cols(env_in$object, env_in$value, "object_id", c("class_id", "object_name")) - add_class_property(idd_env, env_in$value, c("class_id", "class_name")) - add_field_property(idd_env, env_in$value, c("choice", "field_index", "field_name", "units", "ip_units", "type_enum")) - invisible(env_in$value[object_id == 1L & type_enum == IDDFIELD_TYPE$choice, value_chr := "wrong"]) - set(env_in$value, NULL, "value_lower", stri_trans_tolower(env_in$value$value_chr)) - - expect_silent({cho <- check_invalid_choice(idd_env, idf_env, env_in)$validity$invalid_choice}) - expect_equal(cho$object_id, 1L) - expect_equal(cho$value_id, 2L) - # }}} - - # INVALID RANGE {{{ - env_in <- list2env(parse_idf_file(text("idf", 8.8))) - env_in$validity <- empty_validity() - add_joined_cols(env_in$object, env_in$value, "object_id", c("class_id", "object_name")) - add_class_property(idd_env, env_in$value, c("class_id", "class_name")) - add_field_property(idd_env, env_in$value, - c("has_range", "maximum", "minimum", "lower_incbounds", "upper_incbounds", - "field_index", "field_name", "units", "ip_units", "type_enum") - ) - invisible(env_in$value[value_id == 3L, value_num := -1]) - - expect_silent({ran <- check_invalid_range(idd_env, idf_env, env_in)$validity$invalid_range}) - expect_equal(ran$object_id, 1L) - expect_equal(ran$value_id, 3L) - # }}} - - # INVALID REFERENCE {{{ - env_in <- list2env(parse_idf_file(text("idf", 8.8))) - env_in$validity <- empty_validity() - env_in$check_whole <- TRUE - add_joined_cols(env_in$object, env_in$value, "object_id", c("class_id", "object_name")) - add_class_property(idd_env, env_in$value, c("class_id", "class_name")) - add_field_property(idd_env, env_in$value, - c("src_enum", "field_index", "field_name", "units", "ip_units", "type_enum") - ) - - expect_silent({ref <- check_invalid_reference(idd_env, env_in, env_in)$validity$invalid_reference}) - expect_equal(ref$object_id, c(rep(2L, 3), rep(3L, 2))) - expect_equal(ref$value_id, c(12:14, 18L, 20L)) - # }}} -}) -# }}} From a08fc8b2792612c16c6520f17045805bf6a6a340 Mon Sep 17 00:00:00 2001 From: Hongyuan Jia Date: Sun, 26 Jul 2020 19:33:11 +0800 Subject: [PATCH 28/43] [fix] Fix tests --- DESCRIPTION | 2 +- R/epw.R | 2 +- R/format.R | 4 +- R/group.R | 20 +++--- R/idf.R | 12 ++-- R/idfobj.R | 8 ++- R/impl-epw.R | 27 +++----- R/impl-idf.R | 31 +++++---- R/impl-sql.R | 25 ++++--- R/job.R | 22 +++--- R/parse.R | 11 +-- R/rdd.R | 6 +- R/reload.R | 9 ++- R/run.R | 3 +- R/transition.R | 4 +- man/EplusGroupJob.Rd | 15 ++++ man/EplusJob.Rd | 17 +++++ man/EplusSql.Rd | 9 +++ man/Epw.Rd | 33 +++++++++ man/Idd.Rd | 21 ++++++ man/IddObject.Rd | 46 +++++++++++++ man/Idf.Rd | 47 +++++++++++++ man/IdfObject.Rd | 26 +++++++ man/ParametricJob.Rd | 9 +++ tests/testthat/test-epw.R | 6 +- tests/testthat/test-format.R | 30 +++++--- tests/testthat/test-group.R | 17 ++--- tests/testthat/test-idf.R | 13 ++-- tests/testthat/test-idfobj.R | 7 +- tests/testthat/test-impl-epw.R | 45 ++++++------ tests/testthat/test-impl-idf.R | 114 ++++++++++++++----------------- tests/testthat/test-install.R | 3 +- tests/testthat/test-param.R | 8 +-- tests/testthat/test-parse.R | 10 +-- tests/testthat/test-rdd.R | 8 +-- tests/testthat/test-reload.R | 7 +- tests/testthat/test-transition.R | 30 ++++---- tests/testthat/test-validate.R | 8 +-- 38 files changed, 472 insertions(+), 243 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 8660441da..f97f1633a 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -46,7 +46,7 @@ Encoding: UTF-8 LazyData: true Roxygen: list(markdown = TRUE, roclets = c("rd", "namespace", "collate")) -RoxygenNote: 7.0.2 +RoxygenNote: 7.1.1 SystemRequirements: EnergyPlus (>= 8.3, optional) (); udunits2 Collate: diff --git a/R/epw.R b/R/epw.R index c8c578842..dbeadf474 100644 --- a/R/epw.R +++ b/R/epw.R @@ -1920,7 +1920,7 @@ epw_is_unsaved <- function (self, private) { epw_save <- function (self, private, path = NULL, overwrite = FALSE, purge = FALSE) { if (is.null(path)) { if (is.null(private$m_path)) { - abort("The Epw object is not created from local file. Please give the path to save.") + abort("The Epw object is not created from local file. Please give the path to save.", "epw_not_local") } else { path <- private$m_path } diff --git a/R/format.R b/R/format.R index 8e4b7a05c..3b7df41af 100644 --- a/R/format.R +++ b/R/format.R @@ -756,7 +756,9 @@ format_field_by_parent <- function (dt, col = "value", sep_at = 15L, required = format_objects <- function (dt, component = c("group", "class", "object", "field", "value"), brief = TRUE, merge = TRUE, sep_at = 15L, nest = TRUE, order = FALSE, required = FALSE) { - assert_subset(component, c("group", "class", "object", "field", "value"), FALSE) + choices <- c("group", "class", "object", "field", "value") + assert_subset(component, choices, FALSE) + component <- choices[choices %in% component] # create each component {{{ if ("group" %chin% component) { diff --git a/R/group.R b/R/group.R index 50ee10f2d..2e57bdd35 100644 --- a/R/group.R +++ b/R/group.R @@ -791,13 +791,13 @@ epgroup_run <- function (self, private, output_dir = NULL, wait = TRUE, force = # check if generated models have been modified outside uuid <- vcapply(private$m_idfs, function (idf) get_priv_env(idf)$m_log$uuid) if (any(uuid != private$m_log$idf_uuid)) { - warn("warning_param_modified", paste0( + warn(paste0( "Some of the grouped models have been modified. ", "Running these models will result in simulation outputs that may be not reproducible. ", paste0(" # ", seq_along(uuid)[uuid != private$m_log$idf_uuid]," | ", names(uuid)[uuid != private$m_log$idf_uuid], collapse = "\n" ) - )) + ), "group_model_modified") } log_new_uuid(private$m_log) @@ -810,7 +810,7 @@ epgroup_run <- function (self, private, output_dir = NULL, wait = TRUE, force = epgroup_run_models <- function (self, private, output_dir = NULL, wait = TRUE, force = FALSE, copy_external = FALSE, echo = wait) { path_idf <- vcapply(private$m_idfs, function (idf) idf$path()) - if (checkmate::test_names(private$m_idfs)) { + if (checkmate::test_names(names(private$m_idfs))) { # for parametric job nms <- paste0(make_filename(names(private$m_idfs)), ".idf") } else { @@ -1165,13 +1165,13 @@ get_epgroup_input <- function (idfs, epws, sql = TRUE, dict = TRUE) { epws <- lapply(epws, function (x) { tryCatch(get_epw(x), - error_epw_not_local = function (e) e, - error_epw_path_not_exist = function (e) e, - error_epw_not_saved = function (e) e + eplusr_error_epw_not_local = function (e) e, + eplusr_error_epw_path_not_exist = function (e) e, + eplusr_error_epw_not_saved = function (e) e ) }) - err <- c("error_epw_not_local", "error_epw_path_not_exist", "error_epw_not_saved") + err <- c("eplusr_error_epw_not_local", "eplusr_error_epw_path_not_exist", "eplusr_error_epw_not_saved") if (any(invld <- vlapply(epws, inherits, err))) { abort(paste0("Invalid EPW input found:\n", paste0(lpad(paste0(" #", which(invld))), ": ", vcapply(epws[invld], conditionMessage), @@ -1264,15 +1264,15 @@ epgroup_job_from_which <- function (self, private, which, keep_unsucess = FALSE) incomplete <- job[status != "completed"] msg <- incomplete[, sim_status(rpad(toupper(status)), index, idf, epw)] if (keep_unsucess) { - warn("error_job_error", paste0("Some of jobs failed to complete. ", + warn(paste0("Some of jobs failed to complete. ", "Simulation results may not be correct:\n", paste0(msg, collapse = "\n") - )) + ), "job_error") } else { abort(paste0("Some of jobs failed to complete. ", "Please fix the problems and re-run it before collecting output:\n", paste0(msg, collapse = "\n") - )) + ), "job_error") } } diff --git a/R/idf.R b/R/idf.R index 4714e0ba4..5e4e0e2ab 100644 --- a/R/idf.R +++ b/R/idf.R @@ -2989,7 +2989,7 @@ idf_return_matched <- function (self, private, matched, object_id) { res <- apply2(matched$object_id, matched$class_id, IdfObject$new, list(parent = self)) res <- lapply(res, add_idfobj_field_bindings) - setattr(res, "names", matched$object_name) + setattr(res, "names", matched$object_name)[] } # }}} # idf_update_idf_env {{{ @@ -3291,7 +3291,7 @@ idf_save <- function (self, private, path = NULL, format = eplusr_option("save_f overwrite = FALSE, copy_external = TRUE) { if (is.null(path)) { if (is.null(private$m_path)) { - abort("The Idf object is not created from local file. Please give the path to save.") + abort("The Idf object is not created from local file. Please give the path to save.", "idf_not_local") } else { path <- private$m_path } @@ -3466,14 +3466,14 @@ idf_add_output_sqlite <- function (idf) { type <- toupper(sql$value()[[1]]) if (type != "SIMPLEANDTABULAR") { sql$set("SimpleAndTabular") - verbose_info("Setting `Option Type` in ", - "`Output:SQLite` to from ", surround(type), " to `SimpleAndTabular`.") + verbose_info("Setting 'Option Type' in ", + "'Output:SQLite' to from ", surround(type), " to 'SimpleAndTabular'.") added <- TRUE } } else { idf$add(Output_SQLite = list("SimpleAndTabular")) - verbose_info("Adding an object in class `Output:SQLite` and setting its ", - "`Option Type` to `SimpleAndTabular` in order to create SQLite output file.") + verbose_info("Adding an object in class 'Output:SQLite' and setting its ", + "'Option Type' to 'SimpleAndTabular' in order to create SQLite output file.") added <- TRUE } added diff --git a/R/idfobj.R b/R/idfobj.R index 10f845c4e..1d5a59ce4 100644 --- a/R/idfobj.R +++ b/R/idfobj.R @@ -1601,7 +1601,7 @@ idfobj_comment <- function (self, private, comment, append = TRUE, width = 0L) { log_new_uuid(private$log_env()) # update object in parent - private$idf_env()[obj, on = "object_id", `:=`(comment = i.comment)] + private$idf_env()$object[obj, on = "object_id", `:=`(comment = i.comment)] self } @@ -1613,10 +1613,12 @@ idfobj_value <- function (self, private, which = NULL, all = FALSE, simplify = F # }}} # idfobj_set {{{ idfobj_set <- function (self, private, ..., .default = TRUE, .empty = FALSE) { - lst <- list(list(...)) + # support value input in a list format + lst <- list(...) + if (!(length(lst) == 1L && is.list(lst[[1L]]))) lst <- list(lst) names(lst) <- paste0("..", private$m_object_id) idf_set(get_self_env(private$m_parent), get_priv_env(private$m_parent), - lst, .default = .default, .empty = .empty, .env = environment() + lst, .default = .default, .empty = .empty ) self diff --git a/R/impl-epw.R b/R/impl-epw.R index 582391224..9cb01e5ac 100644 --- a/R/impl-epw.R +++ b/R/impl-epw.R @@ -425,14 +425,14 @@ parse_epw_header_holiday <- function (header, strict = FALSE, transform = TRUE) invld <- val[J(i, 2L), on = c("extensible_group", "extensible_field_index")] issue_epw_header_parse_error_single(obj, invld, i) } - if (any(realyr <- is_epwdate_type(holiday, EPWDATE_TYPE$ymd))) { + if (any(realyr <- is_epwdate_type(holiday, "ymd"))) { i <- which(realyr) invld <- val[J(i, 2L), on = c("extensible_group", "extensible_field_index")] issue_epw_header_parse_error_single(obj, invld, i, ". Can not contain year specification.") } # check if duplicated names - name = val[J(1L), on = "extensible_field_index", value_chr] + name <- val[J(1L), on = "extensible_field_index", value_chr] if (anyDuplicated(tolower(name))) { i <- which(duplicated(tolower(name))) invld <- val[J(i, 1L), on = c("extensible_group", "extensible_field_index")] @@ -595,10 +595,11 @@ parse_epw_header_period <- function (header, strict = FALSE, transform = TRUE) { # check each period does not overlap {{{ n <- val$value_num[[1]] if (n > 1) { - comb <- utils::combn(seq_len(n), 2L, simplify = FALSE) + comb <- utils::combn(n, 2L, simplify = FALSE) for (i in comb) { - overlapped <- !(start_day[i[1L]] > end_day[i[2L]] || end_day[i[1L]] < start_day[i[2L]]) + overlapped <- !(as_date(start_day[i[1L]]) > as_date(end_day[i[2L]]) || + as_date(end_day[i[1L]]) < as_date(start_day[i[2L]])) if (overlapped) { parse_error("epw", paste("Invalid", obj$class_name[[1L]], "header"), num = 1L, post = paste0( @@ -712,8 +713,8 @@ update_epw_header_num_field <- function (header, dt_object, dt_value, i = 1L, st subtype = "header_num_field" ) - set(dt_value, i, "value_num", as.double(dt_object$num_extensible_group)) - set(dt_value, i, "value_chr", as.character(dt_object$num_extensible_group)) + set(dt_value, i, "value_num", as.double(num)) + set(dt_value, i, "value_chr", as.character(num)) # update the value table header$value[dt_value[i], on = "value_id", `:=`( @@ -855,14 +856,6 @@ align_epwdate_type <- function (x, to) { x[can_align] <- set_epwdate_year(x[can_align], lubridate::year(to[can_align])) x } -set_epwdate_type <- function(x, type = ("md")) { - type <- match.arg(type, c("md", "ymd")) - assert(is_epwdate_type(x, c("md", "ymd"))) - is_leap <- lubridate::leap_year(x) - y_l <- EPWDATE_TYPE$leap[[type]] - y_nol <- EPWDATE_TYPE$noleap[[type]] - x[t] -} reset_epwdate_year <- function (x, leapyear) { # expect empty and real year t <- get_epwdate_type(x) @@ -1496,7 +1489,7 @@ check_epw_data_range <- function (epw_data, range, merge = TRUE) { # check_epw_data_type{{{ check_epw_data_type <- function (epw_data, type = NULL) { if (is.null(type)) type <- unlist(get_epw_data_type()) - assert_names(type) + assert_names(names(type)) assert_data_table(epw_data) assert_names(names(epw_data), must.include = names(type)) setcolorder(epw_data, names(type)) @@ -1510,7 +1503,7 @@ check_epw_data_type <- function (epw_data, type = NULL) { } else { parse_error("epw", "Failed to parse variables as integer", num = 1L, post = paste0("Failed variables: ", - get_idd_field(idd_env, EPW_CLASS$data, names(type)[[j]], underscore = TRUE)$field_name), + get_idd_field(get_epw_idd_env(), EPW_CLASS$data, names(type)[[j]], underscore = TRUE)$field_name), subtype = "data_type" ) } @@ -1522,7 +1515,7 @@ check_epw_data_type <- function (epw_data, type = NULL) { } else { parse_error("epw", "Failed to parse variables as double", num = 1L, post = paste0("Failed variables: ", - get_idd_field(idd_env, EPW_CLASS$data, names(type)[[j]], underscore = TRUE)$field_name), + get_idd_field(get_epw_idd_env(), EPW_CLASS$data, names(type)[[j]], underscore = TRUE)$field_name), subtype = "data_type" ) } diff --git a/R/impl-idf.R b/R/impl-idf.R index b1cd0be18..2e8d41819 100644 --- a/R/impl-idf.R +++ b/R/impl-idf.R @@ -1085,7 +1085,7 @@ parse_dots_value <- function (..., .scalar = TRUE, .pair = FALSE, # for 'c(Obj, Obj) := list()' } else if (as.character(li[[2L]][[1L]]) %chin% c("c", ".")) { li[[2L]][[1L]] <- as.name("c") - name <- eval(li[[2L]], envir = .env) + name <- eval(li[[2L]], .env) name <- assert_valid_type(name, "ID | Name | Index") if (is.character(name)) { set(dt_in, i, "name", list(name)) @@ -1097,7 +1097,7 @@ parse_dots_value <- function (..., .scalar = TRUE, .pair = FALSE, # for '..(Cls) := list()' } else if (as.character(li[[2L]][[1L]]) == "..") { li[[2L]][[1L]] <- as.name("c") - name <- eval(li[[2L]], envir = .env) + name <- eval(li[[2L]], .env) name <- assert_valid_type(name, "Name", len = 1L, type = "name") set(dt_in, i, "name", list(name)) # indicate that LHS is a single name @@ -1111,7 +1111,7 @@ parse_dots_value <- function (..., .scalar = TRUE, .pair = FALSE, } } - if (!evaluated) val <- eval(li, envir = .env) + if (!evaluated) val <- eval(li, .env) assert_list(val, c("character", "integer", "double", "null"), .var.name = "Input", all.missing = .empty ) @@ -2226,6 +2226,7 @@ expand_idf_dots_literal <- function (idd_env, idf_env, ..., .default = TRUE, .ex parse_error("idf", "Adding a different Version object is prohibited", data, subtype = "ver") } + get_idf_value(idd_env, parsed, complete = ) # remove inserted version object id <- parsed$object[J(1L), on = "class_id", object_id] obj_chr <- parsed$object[!J(id), on = "object_id"] @@ -2619,7 +2620,7 @@ dup_idf_object <- function (idd_env, idf_env, dt_object, level = eplusr_option(" # extract value table val <- get_idf_value(idd_env, idf_env, object = obj$object_id, property = "is_name") - # assign new id + # assign new object id obj <- assign_new_id(idf_env, obj, "object") add_joined_cols(obj, val, "rleid", "object_id") @@ -2627,23 +2628,25 @@ dup_idf_object <- function (idd_env, idf_env, dt_object, level = eplusr_option(" val[obj, on = "object_id", object_name := i.object_name] val[obj[J(TRUE), on = "has_name", nomatch = NULL], on = c("object_id", is_name = "has_name"), value_chr := i.object_name] + # assign new value id + set(val, NULL, "new_value_id", new_id(idf_env$value, "value_id", nrow(val))) + # value reference # extract value reference # directly copy old field references excepting the name field - ref <- idf_env$reference[J(val$value_id[!val$is_name]), on = "value_id", nomatch = 0L] + dt_id <- fast_subset(val, c("object_id", "value_id", "new_value_id")) + setnames(dt_id, "object_id", "new_object_id") + ref <- idf_env$reference[dt_id, on = "value_id", nomatch = 0L] - # assign new id - set(obj, NULL, "new_object_id", id_obj) - val[obj, on = "object_id", new_object_id := i.new_object_id] - set(val, NULL, "new_value_id", new_id(idf_env$value, "value_id", nrow(val))) # update ids in ref - if (nrow(ref)) ref[val, on = c("object_id", "value_id"), `:=`(object_id = i.new_object_id, value_id = i.new_value_id)] + if (nrow(ref)) { + set(ref, NULL, c("object_id", "value_id"), NULL) + setnames(ref, c("new_object_id", "new_value_id"), c("object_id", "value_id")) + } # remove original ids - set(obj, NULL, "object_id", NULL) - setnames(obj, "new_object_id", "object_id") - set(val, NULL, c("object_id", "value_id"), NULL) - setnames(val, c("new_object_id", "new_value_id"), c("object_id", "value_id")) + set(val, NULL, "value_id", NULL) + setnames(val, "new_value_id", "value_id") # NOTE: For original objects whose fields are referred by others, just keep # the original relation and no new relation needs to be created as one value diff --git a/R/impl-sql.R b/R/impl-sql.R index 4d90d2632..b4836aae5 100644 --- a/R/impl-sql.R +++ b/R/impl-sql.R @@ -105,12 +105,12 @@ get_sql_report_data <- function (sql, key_value = NULL, name = NULL, year = NULL if (!is.null(key_value)) { subset_rpvar <- TRUE if (is.data.frame(key_value)) { - assert(has_name(key_value, c("key_value", "name"))) + assert_names(names(key_value), must.include = c("key_value", "name")) if (ncol(key_value) > 2) set(key_value, NULL, setdiff(names(key_value), c("key_value", "name")), NULL) kv <- unique(key_value) rpvar_dict <- rpvar_dict[kv, on = c("key_value", "name"), nomatch = NULL] } else { - assert(is.character(key_value), no_na(key_value)) + assert_character(key_value, any.missing = FALSE) KEY_VALUE <- key_value rpvar_dict <- rpvar_dict[J(KEY_VALUE), on = "key_value", nomatch = NULL] } @@ -118,7 +118,7 @@ get_sql_report_data <- function (sql, key_value = NULL, name = NULL, year = NULL if (!is.null(name)) { subset_rpvar <- TRUE - assert(is.character(name), no_na(name)) + assert_character(name, any.missing = FALSE) NAME <- name rpvar_dict <- rpvar_dict[J(NAME), on = "name"] } @@ -139,39 +139,38 @@ get_sql_report_data <- function (sql, key_value = NULL, name = NULL, year = NULL subset_time <- FALSE if (!is.null(month)) { subset_time <- TRUE - assert(are_count(month), month <= 12L) + assert_integerish(month, lower = 1L, upper = 12L, any.missing = FALSE) time <- time[J(unique(month)), on = "MONTH", nomatch = NULL] } if (!is.null(day)) { subset_time <- TRUE - assert(are_count(day), day <= 31L) + assert_integerish(day, lower = 1L, upper = 31L, any.missing = FALSE) time <- time[J(unique(day)), on = "DAY", nomatch = NULL] } if (!is.null(hour)) { subset_time <- TRUE - assert(are_count(hour, TRUE), hour <= 24L) + assert_integerish(hour, lower = 0L, upper = 24L, any.missing = FALSE) time <- time[J(unique(hour)), on = "HOUR", nomatch = NULL] } if (!is.null(minute)) { subset_time <- TRUE - assert(are_count(minute, TRUE), minute <= 60L) + assert_integerish(minute, lower = 0L, upper = 60L, any.missing = FALSE) time <- time[J(unique(minute)), on = "MINUTE", nomatch = NULL] } if (!is.null(interval)) { subset_time <- TRUE - assert(are_count(interval), interval <= 527040) # 366 days + assert_integerish(interval, lower = 1L, upper = 527040, any.missing = FALSE) time <- time[J(unique(interval)), on = "INTERVAL", nomatch = NULL] } if (!is.null(simulation_days)) { subset_time <- TRUE - assert(are_count(simulation_days), simulation_days <= 366) # 366 days + assert_integerish(simulation_days, lower = 1L, upper = 366, any.missing = FALSE) time <- time[J(unique(simulation_days)), on = "SIMULATION_DAYS", nomatch = NULL] } if (!is.null(period)) { subset_time <- TRUE - assert(any(c("Date", "POSIXt") %in% class(period)), - msg = "`period` should be a Date or DateTime vector." - ) + if (!any(c("Date", "POSIXt") %in% class(period))) + abort("`period` should be a Date or DateTime vector.") p <- unique(period) if (inherits(period, "Date")) { period <- data.table( @@ -202,7 +201,7 @@ get_sql_report_data <- function (sql, key_value = NULL, name = NULL, year = NULL c(weekday, weekend, designday, customday, specialday, normalday, "Weekday", "Weekend", "DesignDay", "CustomDay", "SpecialDay", "NormalDay" ))) - assert(!is.na(dt), msg = paste0("Invalid day type found: ", collapse(day_type[is.na(dt)]), ".")) + if (anyNA(dt)) abort(paste0("Invalid day type found: ", collapse(day_type[is.na(dt)]), ".")) # expand expd <- c() if ("Weekday" %chin% dt) {expd <- c(expd, weekday); dt <- setdiff(dt, "Weekday")} diff --git a/R/job.R b/R/job.R index 836212e01..5fad875d7 100644 --- a/R/job.R +++ b/R/job.R @@ -1034,9 +1034,7 @@ job_output_errors <- function (self, private, info = FALSE) { # job_sql_path {{{ job_sql_path <- function (self, private) { path_sql <- job_locate_output(self, private, ".sql", must_exist = FALSE) - if (!file.exists(path_sql)) { - abort("Simulation SQL output does not exist.") - } + checkmate::assert_file_exists(path_sql, "r", .var.name = "Simulation SQL output") path_sql } # }}} @@ -1049,7 +1047,7 @@ job_rdd_path <- function (self, private, type = c("rdd", "mdd")) { mdd = "Meter Data Dictionary (MDD) file" ) - if (must_exist) checkmate::assert_file_exists(out, "r", .var.name = name) + checkmate::assert_file_exists(path, "r", .var.name = name) path } @@ -1182,18 +1180,18 @@ get_init_idf <- function (idf, sql = TRUE, dict = TRUE) { idf <- if (!is_idf(idf)) read_idf(idf) else idf$clone(deep = TRUE) if (is.null(idf$path())) { - abort("The Idf object is not created from local file. Please save it using `$save()` before running.") + abort("The Idf object is not created from local file. Please save it using `$save()` before running.", "idf_not_local") } if (!utils::file_test("-f", idf$path())) { abort(paste0("Failed to locate the local IDF file of input Idf object. ", "Path: ", surround(idf$path()), " ", "Please re-save it to disk using `$save()` before running." - )) + ), "idf_path_not_exist") } if (idf$is_unsaved()) { - abort("Idf has been modified since read or last saved. Please save it using `$save()` before running.") + abort("Idf has been modified since read or last saved. Please save it using `$save()` before running.", "idf_not_saved") } # add Output:SQLite if necessary @@ -1211,28 +1209,28 @@ get_init_idf <- function (idf, sql = TRUE, dict = TRUE) { #' @importFrom checkmate test_string get_init_epw <- function (epw) { if (checkmate::test_string(epw)) { - if (!file.exists(epw)) { + if (!utils::file_test("-f", epw)) { abort(paste0("Input EPW file does not exist. ", "Path: ", surround(normalizePath(epw, mustWork = FALSE)) - )) + ), "epw_path_not_exist") } path <- epw } else { epw <- if (!is_epw(epw)) read_epw(epw) else epw$clone(deep = TRUE) if (is.null(epw$path())) { - abort("The Epw object is not created from local file. Please save it using `$save()` before running.") + abort("The Epw object is not created from local file. Please save it using `$save()` before running.", "epw_not_local") } if (!utils::file_test("-f", epw$path())) { abort(paste0("Failed to locate the local EPW file of input Epw object. ", "Path: ", surround(epw$path()), " ", "Please re-save it to disk using `$save()` before running." - )) + ), "epw_path_not_exist") } if (epw$is_unsaved()) { - abort("Epw has been modified since read or last saved. Please save it using `$save()` before running.") + abort("Epw has been modified since read or last saved. Please save it using `$save()` before running.", "epw_not_saved") } path <- epw$path() diff --git a/R/parse.R b/R/parse.R index 6f7b8fce4..479c855cc 100644 --- a/R/parse.R +++ b/R/parse.R @@ -1346,12 +1346,11 @@ get_value_table <- function (dt, idd, escape = FALSE) { dt[stri_isempty(value_chr), `:=`(value_chr = NA_character_)] # in order to get the object id with wrong field number - dt_max <- dt[, list(field_index = max(field_index)), by = c("class_id", "object_id")] - dt_uni <- dt_max[, list(field_index = unique(field_index)), by = "class_id"] + dt_max <- dt[, list(class_id = class_id[[1L]], field_index = max(field_index)), by = "object_id"] # only use the max field index to speed up fld <- tryCatch( - get_idd_field(idd, dt_uni$class_id, dt_uni$field_index, + get_idd_field(idd, dt_max$class_id, dt_max$field_index, c("type_enum", "src_enum", "is_name", "units", "ip_units"), complete = TRUE ), @@ -1371,8 +1370,12 @@ get_value_table <- function (dt, idd, escape = FALSE) { } # bind columns + # NOTE: make sure all necessary fields are there + add_rleid(dt_max) + add_joined_cols(dt_max, fld, "rleid", "object_id") set(fld, NULL, c("rleid", "field_in"), NULL) - dt <- dt[unique(fld, by = "field_id"), on = c("class_id", "field_index")] + set(dt, NULL, "class_id", NULL) + dt <- dt[fld, on = c("object_id", "field_index")] # fill data for missing fields dt[is.na(line), `:=`(value_id = new_id(dt, "value_id", length(value_id)))] diff --git a/R/rdd.R b/R/rdd.R index 4c995cbac..056f53918 100644 --- a/R/rdd.R +++ b/R/rdd.R @@ -256,7 +256,7 @@ parse_rdd_file <- function (path, mdd = FALSE) { #' @importFrom checkmate assert_string # rdd_to_load {{{ rdd_to_load <- function (rdd, key_value, reporting_frequency) { - if (is_rdd(rdd)) abort("'rdd' must be an RddFile object") + if (!is_rdd(rdd)) abort("'rdd' must be an RddFile object") # copy the original rdd <- copy(rdd) @@ -310,7 +310,7 @@ mdd_to_load <- function (mdd, reporting_frequency, class = c("Output:Meter", "Output:Meter:MeterFileOnly", "Output:Meter:Cumulative", "Output:Meter:Cumulative:MeterFileOnly")) { - if (is_mdd(rdd)) stop("'mdd' must be an MddFile object") + if (!is_mdd(mdd)) abort("'mdd' must be an MddFile object") ver <- attr(mdd, "eplus_version") class <- match.arg(class) @@ -358,7 +358,7 @@ validate_report_freq <- function (reporting_frequency, scalar = TRUE) { freq <- match_in_vec(reporting_frequency, all_freq, label = TRUE) - assert_subset(freq, all_freq, empty.ok = FALSE) + if (anyNA(freq)) abort(sprintf("Invalid reporting frequency found: %s.", collapse(reporting_frequency[is.na(freq)]))) freq } diff --git a/R/reload.R b/R/reload.R index 6cde2f3fa..e7baa9d71 100644 --- a/R/reload.R +++ b/R/reload.R @@ -56,7 +56,7 @@ reload.default <- function (x, ...) { reload.Idf <- function (x, ...) { reload_idd_env(get_priv_env(x)$idd_env()) reload_idf_env(get_priv_env(x)$idf_env()) - reload_log_env(get_priv_env(x)$log_env()) + reload_log_env(get_priv_env(x)$m_log) x } @@ -75,10 +75,9 @@ reload.IddObject <- function (x, ...) { #' @export reload.Epw <- function (x, ...) { priv <- get_priv_env(x) - priv$m_header$typical <- setDT(priv$m_header$typical) - priv$m_header$ground <- setDT(priv$m_header$ground) - priv$m_header$holiday$holiday <- setDT(priv$m_header$holiday$holiday) - priv$m_header$period$period <- setDT(priv$m_header$period$period) + reload_idd_env(priv$idd_env()) + reload_idf_env(priv$idf_env()) + reload_log_env(priv$m_log) priv$m_data <- setDT(priv$m_data) x } diff --git a/R/run.R b/R/run.R index a62db84b2..ca137c4d2 100644 --- a/R/run.R +++ b/R/run.R @@ -327,10 +327,11 @@ run_multi <- function (model, weather, output_dir, design_day = FALSE, ver <- unlist(ver_list) energyplus_exe <- vcapply(ver, eplus_exe) + ver <- vcapply(ver, function (v) as.character(eplus_config(v)$version)) } else { energyplus_exe <- vcapply(eplus, eplus_exe) + ver <- vcapply(eplus, function (v) as.character(eplus_config(v)$version)) } - ver <- vcapply(ver, function (v) as.character(eplus_config(v)$version)) if (anyDuplicated(model) & is.null(output_dir)) { abort("'model' cannot have any duplications when 'output_dir' is NULL.", "duplicated_sim") diff --git a/R/transition.R b/R/transition.R index 7bee5172b..c300ca643 100644 --- a/R/transition.R +++ b/R/transition.R @@ -102,7 +102,7 @@ transition <- function (idf, ver, keep_all = FALSE, save = FALSE, dir = NULL) { # check if original file exists if (is.null(idf$path())) { - abort("The Idf object is not created from local file. Please save Idf using '$save()' before transition.") + abort("The Idf object is not created from local file. Please save Idf using '$save()' before transition.", "idf_not_local") } if (is.null(dir)) { @@ -3545,7 +3545,7 @@ version_updater <- function (idf, ver, dir = NULL, keep_all = FALSE) { if (is.null(idf$path()) || !utils::file_test("-f", idf$path())) { abort(paste0("The Idf object is not created from local file or local file has ", "been deleted from disk. Please save Idf using '$save()' before transition." - )) + ), "idf_not_local") } # stop if unsaved diff --git a/man/EplusGroupJob.Rd b/man/EplusGroupJob.Rd index 7f2b49154..2641511a6 100644 --- a/man/EplusGroupJob.Rd +++ b/man/EplusGroupJob.Rd @@ -251,6 +251,7 @@ Hongyuan Jia } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-new}{}}} \subsection{Method \code{new()}}{ Create an \code{EplusGroupJob} object \subsection{Usage}{ @@ -299,6 +300,7 @@ if (is_avail_eplus(8.8)) { } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-run}{}}} \subsection{Method \code{run()}}{ Run grouped simulations \subsection{Usage}{ @@ -383,6 +385,7 @@ group$run(copy_external = TRUE, echo = FALSE) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-kill}{}}} \subsection{Method \code{kill()}}{ Kill current running jobs \subsection{Usage}{ @@ -412,6 +415,7 @@ group$kill() } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-status}{}}} \subsection{Method \code{status()}}{ Get the group job status \subsection{Usage}{ @@ -462,6 +466,7 @@ group$status() } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-errors}{}}} \subsection{Method \code{errors()}}{ Read group simulation errors \subsection{Usage}{ @@ -506,6 +511,7 @@ group$errors(info = TRUE) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-output_dir}{}}} \subsection{Method \code{output_dir()}}{ Get simulation output directory \subsection{Usage}{ @@ -546,6 +552,7 @@ group$output_dir(c(1, 4)) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-locate_output}{}}} \subsection{Method \code{locate_output()}}{ Get paths of output file \subsection{Usage}{ @@ -594,6 +601,7 @@ group$locate_output(c(1, 4), ".expidf", strict = TRUE) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-list_table}{}}} \subsection{Method \code{list_table()}}{ List all table names in EnergyPlus SQL outputs \subsection{Usage}{ @@ -632,6 +640,7 @@ group$list_table(c(1, 4)) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-read_table}{}}} \subsection{Method \code{read_table()}}{ Read the same table from EnergyPlus SQL outputs \subsection{Usage}{ @@ -676,6 +685,7 @@ group$read_table(c(1, 4), "Zones") } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-read_rdd}{}}} \subsection{Method \code{read_rdd()}}{ Read Report Data Dictionary (RDD) files \subsection{Usage}{ @@ -715,6 +725,7 @@ group$read_rdd(c(1, 4)) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-read_mdd}{}}} \subsection{Method \code{read_mdd()}}{ Read Meter Data Dictionary (MDD) files \subsection{Usage}{ @@ -754,6 +765,7 @@ group$read_mdd(c(1, 4)) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-report_data_dict}{}}} \subsection{Method \code{report_data_dict()}}{ Read report data dictionary from EnergyPlus SQL outputs \subsection{Usage}{ @@ -812,6 +824,7 @@ group$report_data_dict(c(1, 4)) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-report_data}{}}} \subsection{Method \code{report_data()}}{ Read report data \subsection{Usage}{ @@ -1047,6 +1060,7 @@ group$report_data(c(1, 4), dict[1], hour = 8:18, day_type = "monday", simulation } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-tabular_data}{}}} \subsection{Method \code{tabular_data()}}{ Read tabular data \subsection{Usage}{ @@ -1150,6 +1164,7 @@ str(group$tabular_data(c(1, 4), } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-print}{}}} \subsection{Method \code{print()}}{ Print \code{EplusGroupJob} object \subsection{Usage}{ diff --git a/man/EplusJob.Rd b/man/EplusJob.Rd index ba6744c2b..c7da6d007 100644 --- a/man/EplusJob.Rd +++ b/man/EplusJob.Rd @@ -297,6 +297,7 @@ Hongyuan Jia } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-new}{}}} \subsection{Method \code{new()}}{ Create an \code{EplusJob} object \subsection{Usage}{ @@ -334,6 +335,7 @@ An \code{EplusJob} object. } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-version}{}}} \subsection{Method \code{version()}}{ Get the version of IDF in current job \subsection{Usage}{ @@ -361,6 +363,7 @@ job$version() } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-path}{}}} \subsection{Method \code{path()}}{ Get the paths of file that current \code{EpwSql} uses \subsection{Usage}{ @@ -400,6 +403,7 @@ job$path("epw") } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-run}{}}} \subsection{Method \code{run()}}{ Run simulationA \subsection{Usage}{ @@ -496,6 +500,7 @@ job$run(copy_external = TRUE) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-kill}{}}} \subsection{Method \code{kill()}}{ Kill current running job \subsection{Usage}{ @@ -524,6 +529,7 @@ job$kill() } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-status}{}}} \subsection{Method \code{status()}}{ Get the job status \subsection{Usage}{ @@ -563,6 +569,7 @@ job$status() } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-errors}{}}} \subsection{Method \code{errors()}}{ Read simulation errors \subsection{Usage}{ @@ -603,6 +610,7 @@ job$errors(info = TRUE) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-output_dir}{}}} \subsection{Method \code{output_dir()}}{ Get simulation output directory \subsection{Usage}{ @@ -637,6 +645,7 @@ job$output_dir(open = TRUE) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-locate_output}{}}} \subsection{Method \code{locate_output()}}{ Get path of output file \subsection{Usage}{ @@ -678,6 +687,7 @@ job$locate_output(".expidf", strict = TRUE) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-read_rdd}{}}} \subsection{Method \code{read_rdd()}}{ Read Report Data Dictionary (RDD) file \subsection{Usage}{ @@ -706,6 +716,7 @@ job$read_rdd() } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-read_mdd}{}}} \subsection{Method \code{read_mdd()}}{ Read Report Data Dictionary (RDD) file \subsection{Usage}{ @@ -734,6 +745,7 @@ job$read_mdd() } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-list_table}{}}} \subsection{Method \code{list_table()}}{ List all table names in EnergyPlus SQL output \subsection{Usage}{ @@ -762,6 +774,7 @@ job$list_table() } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-read_table}{}}} \subsection{Method \code{read_table()}}{ Read a single table from EnergyPlus SQL output \subsection{Usage}{ @@ -799,6 +812,7 @@ job$read_table("Zones") } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-report_data_dict}{}}} \subsection{Method \code{report_data_dict()}}{ Read report data dictionary from EnergyPlus SQL output \subsection{Usage}{ @@ -846,6 +860,7 @@ job$report_data_dict() } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-report_data}{}}} \subsection{Method \code{report_data()}}{ Read report data \subsection{Usage}{ @@ -1076,6 +1091,7 @@ job$report_data(dict[1], all = TRUE)[environment_period_index == 3L] } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-tabular_data}{}}} \subsection{Method \code{tabular_data()}}{ Read tabular data \subsection{Usage}{ @@ -1173,6 +1189,7 @@ str(job$tabular_data( } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-print}{}}} \subsection{Method \code{print()}}{ Print \code{EplusSql} object \subsection{Usage}{ diff --git a/man/EplusSql.Rd b/man/EplusSql.Rd index 917fe7f99..938e901e2 100644 --- a/man/EplusSql.Rd +++ b/man/EplusSql.Rd @@ -202,6 +202,7 @@ Hongyuan Jia } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-new}{}}} \subsection{Method \code{new()}}{ Create an \code{EplusSql} object \subsection{Usage}{ @@ -245,6 +246,7 @@ if (is_avail_eplus(8.8)) { } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-path}{}}} \subsection{Method \code{path()}}{ Get the file path of current \code{EpwSql} object \subsection{Usage}{ @@ -273,6 +275,7 @@ sql$path() } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-path_idf}{}}} \subsection{Method \code{path_idf()}}{ Get the path of corresponding IDF file \subsection{Usage}{ @@ -303,6 +306,7 @@ sql$path_idf() } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-list_table}{}}} \subsection{Method \code{list_table()}}{ List all table names in current EnergyPlus SQL output \subsection{Usage}{ @@ -331,6 +335,7 @@ sql$list_table() } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-read_table}{}}} \subsection{Method \code{read_table()}}{ Read a single table from current EnergyPlus SQL output \subsection{Usage}{ @@ -368,6 +373,7 @@ sql$read_table("Zones") } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-report_data_dict}{}}} \subsection{Method \code{report_data_dict()}}{ Read report data dictionary from current EnergyPlus SQL output \subsection{Usage}{ @@ -415,6 +421,7 @@ sql$report_data_dict() } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-report_data}{}}} \subsection{Method \code{report_data()}}{ Read report data \subsection{Usage}{ @@ -655,6 +662,7 @@ sql$report_data(dict[1], all = TRUE)[environment_period_index == 3L] } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-tabular_data}{}}} \subsection{Method \code{tabular_data()}}{ Read tabular data \subsection{Usage}{ @@ -758,6 +766,7 @@ str(sql$tabular_data( } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-print}{}}} \subsection{Method \code{print()}}{ Print \code{EplusSql} object \subsection{Usage}{ diff --git a/man/Epw.Rd b/man/Epw.Rd index a7d2736a9..f453bb476 100644 --- a/man/Epw.Rd +++ b/man/Epw.Rd @@ -473,6 +473,7 @@ Hongyuan Jia } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-new}{}}} \subsection{Method \code{new()}}{ Create an \code{Epw} object \subsection{Usage}{ @@ -529,6 +530,7 @@ if (is_avail_eplus(8.8)) { } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-path}{}}} \subsection{Method \code{path()}}{ Get the file path of current \code{Epw} \subsection{Usage}{ @@ -559,6 +561,7 @@ epw$path() } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-definition}{}}} \subsection{Method \code{definition()}}{ Get the \link{IddObject} object for specified EPW class. \subsection{Usage}{ @@ -605,6 +608,7 @@ epw$definition("LOCATION") } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-location}{}}} \subsection{Method \code{location()}}{ Get and modify LOCATION header \subsection{Usage}{ @@ -681,6 +685,7 @@ epw$location(city = "MyCity") } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-design_condition}{}}} \subsection{Method \code{design_condition()}}{ Get DESIGN CONDITION header \subsection{Usage}{ @@ -717,6 +722,7 @@ epw$design_condition() } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-typical_extreme_period}{}}} \subsection{Method \code{typical_extreme_period()}}{ Get TYPICAL/EXTREME header \subsection{Usage}{ @@ -755,6 +761,7 @@ epw$typical_extreme_period() } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-ground_temperature}{}}} \subsection{Method \code{ground_temperature()}}{ Get GROUND TEMPERATURE header \subsection{Usage}{ @@ -792,6 +799,7 @@ epw$ground_temperature() } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-holiday}{}}} \subsection{Method \code{holiday()}}{ Get and modify HOLIDAYS/DAYLIGHT SAVINGS header \subsection{Usage}{ @@ -883,6 +891,7 @@ epw$holiday(dst = c(3.10, 11.3)) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-comment1}{}}} \subsection{Method \code{comment1()}}{ Get and modify COMMENT1 header \subsection{Usage}{ @@ -921,6 +930,7 @@ epw$comment1("Comment1") } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-comment2}{}}} \subsection{Method \code{comment2()}}{ Get and modify COMMENT2 header \subsection{Usage}{ @@ -959,6 +969,7 @@ epw$comment2("Comment2") } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-num_period}{}}} \subsection{Method \code{num_period()}}{ Get number of data periods in DATA PERIODS header \subsection{Usage}{ @@ -987,6 +998,7 @@ epw$num_period() } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-interval}{}}} \subsection{Method \code{interval()}}{ Get the time interval in DATA PERIODS header \subsection{Usage}{ @@ -1015,6 +1027,7 @@ epw$interval() } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-period}{}}} \subsection{Method \code{period()}}{ Get and modify data period meta data in DATA PERIODS header \subsection{Usage}{ @@ -1071,6 +1084,7 @@ epw$period(1, start_day_of_week = 3) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-missing_code}{}}} \subsection{Method \code{missing_code()}}{ Get missing code for weather data variables \subsection{Usage}{ @@ -1099,6 +1113,7 @@ epw$missing_code() } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-initial_missing_value}{}}} \subsection{Method \code{initial_missing_value()}}{ Get initial value for missing data of weather data variables \subsection{Usage}{ @@ -1128,6 +1143,7 @@ epw$initial_missing_value() } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-range_exist}{}}} \subsection{Method \code{range_exist()}}{ Get value ranges for existing values of weather data variables \subsection{Usage}{ @@ -1157,6 +1173,7 @@ epw$range_exist() } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-range_valid}{}}} \subsection{Method \code{range_valid()}}{ Get value ranges for valid values of weather data variables \subsection{Usage}{ @@ -1186,6 +1203,7 @@ epw$range_valid() } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-fill_action}{}}} \subsection{Method \code{fill_action()}}{ Get fill actions for abnormal values of weather data variables \subsection{Usage}{ @@ -1231,6 +1249,7 @@ epw$fill_action("out_of_range") } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-data}{}}} \subsection{Method \code{data()}}{ Get weather data \subsection{Usage}{ @@ -1334,6 +1353,7 @@ attributes(epw$data(tz = "Etc/GMT+8")$datetime) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-abnormal_data}{}}} \subsection{Method \code{abnormal_data()}}{ Get abnormal weather data \subsection{Usage}{ @@ -1416,6 +1436,7 @@ epw$abnormal_data(cols = c("dry_bulb_temperature", "liquid_precip_rate"), } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-redundant_data}{}}} \subsection{Method \code{redundant_data()}}{ Get redundant weather data \subsection{Usage}{ @@ -1450,6 +1471,7 @@ epw$redundant_data() } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-make_na}{}}} \subsection{Method \code{make_na()}}{ Convert abnormal data into NAs \subsection{Usage}{ @@ -1508,6 +1530,7 @@ summary(epw$data()$liquid_precip_rate) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-fill_abnormal}{}}} \subsection{Method \code{fill_abnormal()}}{ Fill abnormal data using prescribed pattern \subsection{Usage}{ @@ -1577,6 +1600,7 @@ summary(epw$data()$liquid_precip_rate) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-add_unit}{}}} \subsection{Method \code{add_unit()}}{ Add units to weather data variables \subsection{Usage}{ @@ -1630,6 +1654,7 @@ head(t_dry_bulb) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-drop_unit}{}}} \subsection{Method \code{drop_unit()}}{ Remove units in weather data variables \subsection{Usage}{ @@ -1674,6 +1699,7 @@ epw$data() } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-purge}{}}} \subsection{Method \code{purge()}}{ Delete redundant weather data observations \subsection{Usage}{ @@ -1702,6 +1728,7 @@ epw$purge() } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-add}{}}} \subsection{Method \code{add()}}{ Add a data period \subsection{Usage}{ @@ -1790,6 +1817,7 @@ epw$add(epw$data()) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-set}{}}} \subsection{Method \code{set()}}{ Replace a data period \subsection{Usage}{ @@ -1874,6 +1902,7 @@ epw$set(epw$data(), warning = FALSE) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-del}{}}} \subsection{Method \code{del()}}{ Delete a data period \subsection{Usage}{ @@ -1899,6 +1928,7 @@ The modified \code{Epw} object itself, invisibly. } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-is_unsaved}{}}} \subsection{Method \code{is_unsaved()}}{ Check if there are unsaved changes in current \code{Epw} \subsection{Usage}{ @@ -1928,6 +1958,7 @@ epw$is_unsaved() } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-save}{}}} \subsection{Method \code{save()}}{ Save \code{Epw} object as an EPW file \subsection{Usage}{ @@ -1973,6 +2004,7 @@ epw$save(file.path(tempdir(), "weather.epw"), overwrite = TRUE) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-print}{}}} \subsection{Method \code{print()}}{ Print \code{Idf} object \subsection{Usage}{ @@ -2002,6 +2034,7 @@ epw$print() } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-clone}{}}} \subsection{Method \code{clone()}}{ The objects of this class are cloneable with this method. \subsection{Usage}{ diff --git a/man/Idd.Rd b/man/Idd.Rd index 9c56b9b9e..6c2219e5f 100644 --- a/man/Idd.Rd +++ b/man/Idd.Rd @@ -315,6 +315,7 @@ Hongyuan Jia } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-new}{}}} \subsection{Method \code{new()}}{ Create an \code{Idd} object \subsection{Usage}{ @@ -359,6 +360,7 @@ idd <- use_idd(8.8, download = "auto") } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-version}{}}} \subsection{Method \code{version()}}{ Get the version of current \code{Idd} \subsection{Usage}{ @@ -390,6 +392,7 @@ idd$version() } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-build}{}}} \subsection{Method \code{build()}}{ Get the build tag of current \code{Idd} \subsection{Usage}{ @@ -419,6 +422,7 @@ idd$build() } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-group_name}{}}} \subsection{Method \code{group_name()}}{ Get names of groups \subsection{Usage}{ @@ -447,6 +451,7 @@ idd$group_name() } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-from_group}{}}} \subsection{Method \code{from_group()}}{ Get the name of group that specified class belongs to \subsection{Usage}{ @@ -483,6 +488,7 @@ idd$from_group(c("Version", "Schedule:Compact")) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-class_name}{}}} \subsection{Method \code{class_name()}}{ Get names of classes \subsection{Usage}{ @@ -528,6 +534,7 @@ idd$class_name(by_group = TRUE) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-required_class_name}{}}} \subsection{Method \code{required_class_name()}}{ Get the names of required classes \subsection{Usage}{ @@ -557,6 +564,7 @@ idd$required_class_name() } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-unique_class_name}{}}} \subsection{Method \code{unique_class_name()}}{ Get the names of unique-object classes \subsection{Usage}{ @@ -586,6 +594,7 @@ idd$unique_class_name() } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-extensible_class_name}{}}} \subsection{Method \code{extensible_class_name()}}{ Get the names of classes with extensible fields \subsection{Usage}{ @@ -616,6 +625,7 @@ idd$extensible_class_name() } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-group_index}{}}} \subsection{Method \code{group_index()}}{ Get the indices of specified groups \subsection{Usage}{ @@ -652,6 +662,7 @@ idd$group_index() } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-class_index}{}}} \subsection{Method \code{class_index()}}{ Get the indices of specified classes \subsection{Usage}{ @@ -691,6 +702,7 @@ idd$class_index() } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-is_valid_group}{}}} \subsection{Method \code{is_valid_group()}}{ Check if elements in input character vector are valid group names. \subsection{Usage}{ @@ -731,6 +743,7 @@ idd$is_valid_group(c("Schedules", "Compliance Objects")) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-is_valid_class}{}}} \subsection{Method \code{is_valid_class()}}{ Check if elements in input character vector are valid class names. \subsection{Usage}{ @@ -771,6 +784,7 @@ idd$is_valid_class(c("Building", "ShadowCalculation")) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-object}{}}} \subsection{Method \code{object()}}{ Extract an \link{IddObject} object using class index or name. \subsection{Usage}{ @@ -815,6 +829,7 @@ idd$object("Building") } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-objects}{}}} \subsection{Method \code{objects()}}{ Extract multiple \link{IddObject} objects using class indices or names. \subsection{Usage}{ @@ -859,6 +874,7 @@ idd$objects(c("Version", "Material")) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-object_relation}{}}} \subsection{Method \code{object_relation()}}{ Extract the relationship between class fields. \subsection{Usage}{ @@ -952,6 +968,7 @@ idd$object_relation("Construction", "ref_by") } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-objects_in_relation}{}}} \subsection{Method \code{objects_in_relation()}}{ Extract multiple \link{IddObject} objects referencing each others. \subsection{Usage}{ @@ -1030,6 +1047,7 @@ idd$objects_in_relation("Construction", "ref_by") } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-objects_in_group}{}}} \subsection{Method \code{objects_in_group()}}{ Extract all \link{IddObject} objects in one group. \subsection{Usage}{ @@ -1067,6 +1085,7 @@ idd$objects_in_group("Schedules") } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-to_table}{}}} \subsection{Method \code{to_table()}}{ Format \code{Idd} classes as a data.frame \subsection{Usage}{ @@ -1115,6 +1134,7 @@ idd$to_table(c("Construction", "Material")) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-to_string}{}}} \subsection{Method \code{to_string()}}{ Format \code{Idf} classes as a character vector \subsection{Usage}{ @@ -1169,6 +1189,7 @@ idd$to_string(c("Material", "Construction"), leading = 0, sep_at = 0, sep_each = } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-print}{}}} \subsection{Method \code{print()}}{ Print \code{Idd} object \subsection{Usage}{ diff --git a/man/IddObject.Rd b/man/IddObject.Rd index e061b8f36..aad2dd6fb 100644 --- a/man/IddObject.Rd +++ b/man/IddObject.Rd @@ -603,6 +603,7 @@ Hongyuan Jia } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-new}{}}} \subsection{Method \code{new()}}{ Create an \code{IddObject} object \subsection{Usage}{ @@ -641,6 +642,7 @@ surf <- IddObject$new("BuildingSurface:Detailed", use_idd(8.8, download = "auto" } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-version}{}}} \subsection{Method \code{version()}}{ Get the version of parent \code{Idd} \subsection{Usage}{ @@ -672,6 +674,7 @@ surf$version() } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-parent}{}}} \subsection{Method \code{parent()}}{ Get parent \link{Idd} \subsection{Usage}{ @@ -699,6 +702,7 @@ surf$parent() } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-group_name}{}}} \subsection{Method \code{group_name()}}{ Get the group name \subsection{Usage}{ @@ -726,6 +730,7 @@ surf$group_name() } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-group_index}{}}} \subsection{Method \code{group_index()}}{ Get the group index \subsection{Usage}{ @@ -755,6 +760,7 @@ surf$group_index() } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-class_name}{}}} \subsection{Method \code{class_name()}}{ Get the class name of current \code{IddObject} \subsection{Usage}{ @@ -782,6 +788,7 @@ surf$class_name() } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-class_index}{}}} \subsection{Method \code{class_index()}}{ Get the class index \subsection{Usage}{ @@ -811,6 +818,7 @@ surf$class_index() } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-class_format}{}}} \subsection{Method \code{class_format()}}{ Get the class format \subsection{Usage}{ @@ -839,6 +847,7 @@ surf$class_format() } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-min_fields}{}}} \subsection{Method \code{min_fields()}}{ Get the minimum field number of current class \subsection{Usage}{ @@ -867,6 +876,7 @@ surf$min_fields() } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-num_fields}{}}} \subsection{Method \code{num_fields()}}{ Get the total field number of current class \subsection{Usage}{ @@ -895,6 +905,7 @@ surf$num_fields() } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-memo}{}}} \subsection{Method \code{memo()}}{ Get the memo string of current class \subsection{Usage}{ @@ -923,6 +934,7 @@ surf$memo() } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-num_extensible}{}}} \subsection{Method \code{num_extensible()}}{ Get the field number of the extensible group in current class \subsection{Usage}{ @@ -957,6 +969,7 @@ surf$num_extensible() } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-first_extensible_index}{}}} \subsection{Method \code{first_extensible_index()}}{ Get the minimum field number of current class \subsection{Usage}{ @@ -991,6 +1004,7 @@ surf$first_extensible_index() } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-extensible_group_num}{}}} \subsection{Method \code{extensible_group_num()}}{ Get the number of extensible groups in current class \subsection{Usage}{ @@ -1025,6 +1039,7 @@ surf$extensible_group_num() } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-add_extensible_group}{}}} \subsection{Method \code{add_extensible_group()}}{ Add extensible groups in current class \subsection{Usage}{ @@ -1078,6 +1093,7 @@ surf$extensible_group_num() } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-del_extensible_group}{}}} \subsection{Method \code{del_extensible_group()}}{ Delete extensible groups in current class \subsection{Usage}{ @@ -1131,6 +1147,7 @@ surf$extensible_group_num() } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-has_name}{}}} \subsection{Method \code{has_name()}}{ Check if current class has name attribute \subsection{Usage}{ @@ -1162,6 +1179,7 @@ surf$has_name() } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-is_required}{}}} \subsection{Method \code{is_required()}}{ Check if current class is required \subsection{Usage}{ @@ -1193,6 +1211,7 @@ surf$is_required() } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-is_unique}{}}} \subsection{Method \code{is_unique()}}{ Check if current class is unique \subsection{Usage}{ @@ -1224,6 +1243,7 @@ surf$is_unique() } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-is_extensible}{}}} \subsection{Method \code{is_extensible()}}{ Check if current class is extensible \subsection{Usage}{ @@ -1256,6 +1276,7 @@ surf$is_extensible() } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-field_name}{}}} \subsection{Method \code{field_name()}}{ Get field names \subsection{Usage}{ @@ -1313,6 +1334,7 @@ surf$field_name(unit = TRUE, in_ip = TRUE) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-field_index}{}}} \subsection{Method \code{field_index()}}{ Get field indices \subsection{Usage}{ @@ -1355,6 +1377,7 @@ surf$field_index(c("number of vertices", "vertex 10 z-coordinate")) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-field_type}{}}} \subsection{Method \code{field_type()}}{ Get field types \subsection{Usage}{ @@ -1405,6 +1428,7 @@ surf$field_type(c("name", "zone name", "vertex 10 z-coordinate")) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-field_note}{}}} \subsection{Method \code{field_note()}}{ Get field notes \subsection{Usage}{ @@ -1448,6 +1472,7 @@ surf$field_note(c("name", "zone name", "vertex 10 z-coordinate")) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-field_unit}{}}} \subsection{Method \code{field_unit()}}{ Get field units \subsection{Usage}{ @@ -1493,6 +1518,7 @@ surf$field_unit(c("name", "zone name", "vertex 10 z-coordinate")) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-field_default}{}}} \subsection{Method \code{field_default()}}{ Get field default value \subsection{Usage}{ @@ -1538,6 +1564,7 @@ surf$field_default(c("name", "zone name", "vertex 10 z-coordinate")) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-field_choice}{}}} \subsection{Method \code{field_choice()}}{ Get choices of field values \subsection{Usage}{ @@ -1580,6 +1607,7 @@ surf$field_choice(c("name", "sun exposure", "wind exposure")) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-field_range}{}}} \subsection{Method \code{field_range()}}{ Get field value ranges \subsection{Usage}{ @@ -1645,6 +1673,7 @@ surf$field_range(c("name", "number of vertices", "vertex 10 z-coordinate")) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-field_relation}{}}} \subsection{Method \code{field_relation()}}{ Extract the relationship among fields \subsection{Usage}{ @@ -1737,6 +1766,7 @@ surf$field_relation(c("name", "zone name", "vertex 10 z-coordinate")) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-field_possible}{}}} \subsection{Method \code{field_possible()}}{ Get field possible values \subsection{Usage}{ @@ -1796,6 +1826,7 @@ surf$field_possible(6:10) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-is_valid_field_num}{}}} \subsection{Method \code{is_valid_field_num()}}{ Check if input is a valid field number \subsection{Usage}{ @@ -1837,6 +1868,7 @@ surf$is_valid_field_num(c(10, 14, 100)) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-is_extensible_index}{}}} \subsection{Method \code{is_extensible_index()}}{ Check if input field index indicates an extensible field \subsection{Usage}{ @@ -1875,6 +1907,7 @@ surf$is_extensible_index(c(10, 14, 100)) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-is_valid_field_name}{}}} \subsection{Method \code{is_valid_field_name()}}{ Check if input character is a valid field name \subsection{Usage}{ @@ -1917,6 +1950,7 @@ surf$is_valid_field_name(c("Name", "Sun_Exposure"), strict = TRUE) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-is_valid_field_index}{}}} \subsection{Method \code{is_valid_field_index()}}{ Check if input integer is a valid field index \subsection{Usage}{ @@ -1952,6 +1986,7 @@ surf$is_valid_field_index(1:10) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-is_autosizable_field}{}}} \subsection{Method \code{is_autosizable_field()}}{ Check if input field can be autosized \subsection{Usage}{ @@ -1991,6 +2026,7 @@ surf$is_autosizable_field(c("name", "sun_exposure")) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-is_autocalculatable_field}{}}} \subsection{Method \code{is_autocalculatable_field()}}{ Check if input field can be autocalculated \subsection{Usage}{ @@ -2030,6 +2066,7 @@ surf$is_autocalculatable_field(c("name", "sun_exposure")) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-is_numeric_field}{}}} \subsection{Method \code{is_numeric_field()}}{ Check if input field value should be numeric \subsection{Usage}{ @@ -2069,6 +2106,7 @@ surf$is_numeric_field(c("name", "sun_exposure")) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-is_real_field}{}}} \subsection{Method \code{is_real_field()}}{ Check if input field value should be a real number \subsection{Usage}{ @@ -2108,6 +2146,7 @@ surf$is_real_field(c("name", "number of vertices")) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-is_integer_field}{}}} \subsection{Method \code{is_integer_field()}}{ Check if input field value should be an integer \subsection{Usage}{ @@ -2147,6 +2186,7 @@ surf$is_integer_field(c("name", "number of vertices")) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-is_required_field}{}}} \subsection{Method \code{is_required_field()}}{ Check if input field is required \subsection{Usage}{ @@ -2185,6 +2225,7 @@ surf$is_required_field(c("name", "number of vertices")) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-has_ref}{}}} \subsection{Method \code{has_ref()}}{ Check if input field can refer to or can be referred by other fields \subsection{Usage}{ @@ -2236,6 +2277,7 @@ surf$has_ref(c("name", "zone name")) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-has_ref_to}{}}} \subsection{Method \code{has_ref_to()}}{ Check if input field can refer to other fields \subsection{Usage}{ @@ -2287,6 +2329,7 @@ surf$has_ref_to(c("name", "zone name")) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-has_ref_by}{}}} \subsection{Method \code{has_ref_by()}}{ Check if input field can be referred by other fields \subsection{Usage}{ @@ -2338,6 +2381,7 @@ surf$has_ref_by(c("name", "zone name")) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-to_table}{}}} \subsection{Method \code{to_table()}}{ Format an \code{IddObject} as a data.frame \subsection{Usage}{ @@ -2383,6 +2427,7 @@ surf$to_table(TRUE) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-to_string}{}}} \subsection{Method \code{to_string()}}{ Format an \code{IdfObject} as a character vector \subsection{Usage}{ @@ -2435,6 +2480,7 @@ surf$to_string(c("This", "will", "be", "comments")) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-print}{}}} \subsection{Method \code{print()}}{ Print \code{IddObject} object \subsection{Usage}{ diff --git a/man/Idf.Rd b/man/Idf.Rd index 2fbd00985..ed5bf7dff 100644 --- a/man/Idf.Rd +++ b/man/Idf.Rd @@ -912,6 +912,7 @@ Hongyuan Jia } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-new}{}}} \subsection{Method \code{new()}}{ Create an \code{Idf} object \subsection{Usage}{ @@ -985,6 +986,7 @@ Idf$new(string_idf, use_idd(8.8, download = "auto")) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-version}{}}} \subsection{Method \code{version()}}{ Get the version of current \code{Idf} \subsection{Usage}{ @@ -1016,6 +1018,7 @@ idf$version() } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-path}{}}} \subsection{Method \code{path()}}{ Get the file path of current \code{Idf} \subsection{Usage}{ @@ -1049,6 +1052,7 @@ Idf$new("Version, 8.8;\n")$path() } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-group_name}{}}} \subsection{Method \code{group_name()}}{ Get names of groups \subsection{Usage}{ @@ -1098,6 +1102,7 @@ idf$group_name(all = TRUE) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-class_name}{}}} \subsection{Method \code{class_name()}}{ Get names of classes \subsection{Usage}{ @@ -1159,6 +1164,7 @@ idf$class_name(all = TRUE, by_group = TRUE) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-is_valid_group}{}}} \subsection{Method \code{is_valid_group()}}{ Check if elements in input character vector are valid group names. \subsection{Usage}{ @@ -1207,6 +1213,7 @@ idf$is_valid_group(c("Schedules", "Compliance Objects"), all = TRUE) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-is_valid_class}{}}} \subsection{Method \code{is_valid_class()}}{ Check if elements in input character vector are valid class names. \subsection{Usage}{ @@ -1256,6 +1263,7 @@ idf$is_valid_class(c("Building", "ShadowCalculation"), all = TRUE) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-definition}{}}} \subsection{Method \code{definition()}}{ Get the \link{IddObject} object for specified class. \subsection{Usage}{ @@ -1296,6 +1304,7 @@ idf$definition("Version") } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-object_id}{}}} \subsection{Method \code{object_id()}}{ Get the unique ID for each object in specified classes in the \code{Idf}. \subsection{Usage}{ @@ -1357,6 +1366,7 @@ idf$object_id(c("Version", "Zone"), simplify = TRUE) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-object_name}{}}} \subsection{Method \code{object_name()}}{ Get names for objects in specified classes in the \code{Idf}. \subsection{Usage}{ @@ -1421,6 +1431,7 @@ idf$object_name(c("Version", "Zone"), simplify = TRUE) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-object_num}{}}} \subsection{Method \code{object_num()}}{ Get number of objects in specified classes in the \link{Idf} object. \subsection{Usage}{ @@ -1463,6 +1474,7 @@ idf$object_num(c("Zone", "Schedule:Compact")) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-is_valid_id}{}}} \subsection{Method \code{is_valid_id()}}{ Check if elements in input integer vector are valid object IDs. \subsection{Usage}{ @@ -1499,6 +1511,7 @@ idf$is_valid_id(c(51, 1000)) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-is_valid_name}{}}} \subsection{Method \code{is_valid_name()}}{ Check if elements in input character vector are valid object names. \subsection{Usage}{ @@ -1542,6 +1555,7 @@ idf$is_valid_name(c("simple one zone (wireframe dxf)", "zone one", "a")) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-object}{}}} \subsection{Method \code{object()}}{ Extract an \link{IdfObject} object using object ID or name. \subsection{Usage}{ @@ -1599,6 +1613,7 @@ idf$object("simple one zone (wireframe dxf)") } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-objects}{}}} \subsection{Method \code{objects()}}{ Extract multiple \link{IdfObject} objects using object IDs or names. \subsection{Usage}{ @@ -1652,6 +1667,7 @@ idf$objects(c("Simple One Zone (Wireframe DXF)", "zone one")) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-object_unique}{}}} \subsection{Method \code{object_unique()}}{ Extract the \link{IdfObject} in class with \code{unique-object} attribute. \subsection{Usage}{ @@ -1714,6 +1730,7 @@ idf[["SimulationControl"]] } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-objects_in_class}{}}} \subsection{Method \code{objects_in_class()}}{ Extract all \link{IdfObject} objects in one class. \subsection{Usage}{ @@ -1772,6 +1789,7 @@ idf[["Zone"]] } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-objects_in_group}{}}} \subsection{Method \code{objects_in_group()}}{ Extract all \link{IdfObject} objects in one group. \subsection{Usage}{ @@ -1809,6 +1827,7 @@ idf$objects_in_group("Schedules") } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-object_relation}{}}} \subsection{Method \code{object_relation()}}{ Extract the relationship between object field values. \subsection{Usage}{ @@ -1932,6 +1951,7 @@ idf$object_relation("floor", "ref_by") } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-objects_in_relation}{}}} \subsection{Method \code{objects_in_relation()}}{ Extract multiple \link{IdfObject} objects referencing each others. \subsection{Usage}{ @@ -2048,6 +2068,7 @@ idf$objects_in_relation("floor", "ref_by", "BuildingSurface:Detailed") } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-search_object}{}}} \subsection{Method \code{search_object()}}{ Extract multiple \link{IdfObject} objects using regular expression on names. @@ -2099,6 +2120,7 @@ idf$search_object("floor", ignore.case = TRUE) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-dup}{}}} \subsection{Method \code{dup()}}{ Duplicate existing objects. \subsection{Usage}{ @@ -2158,6 +2180,7 @@ idf$dup(floors_1, floors_2) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-add}{}}} \subsection{Method \code{add()}}{ Add new objects. \subsection{Usage}{ @@ -2260,6 +2283,7 @@ empty$add(objs1, rp) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-set}{}}} \subsection{Method \code{set()}}{ Set values of existing objects. \subsection{Usage}{ @@ -2389,6 +2413,7 @@ idf$set(sets) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-del}{}}} \subsection{Method \code{del()}}{ Delete existing objects \subsection{Usage}{ @@ -2498,6 +2523,7 @@ idf$del(ids) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-purge}{}}} \subsection{Method \code{purge()}}{ Purge resource objects that are not used \subsection{Usage}{ @@ -2556,6 +2582,7 @@ idf$purge(group = "Schedules") } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-duplicated}{}}} \subsection{Method \code{duplicated()}}{ Determine duplicated objects \subsection{Usage}{ @@ -2621,6 +2648,7 @@ idf$duplicated(class = "Material", group = "Schedules") } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-unique}{}}} \subsection{Method \code{unique()}}{ Remove duplicated objects \subsection{Usage}{ @@ -2681,6 +2709,7 @@ idf$unique(class = "Material", group = "Schedules") } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-rename}{}}} \subsection{Method \code{rename()}}{ Rename existing objects \subsection{Usage}{ @@ -2726,6 +2755,7 @@ idf$rename(on_off = "on/off", test_352a = 51) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-insert}{}}} \subsection{Method \code{insert()}}{ Insert new objects from \link{IdfObject}s \subsection{Usage}{ @@ -2791,6 +2821,7 @@ idf$insert(idf$SizingPeriod_DesignDay) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-load}{}}} \subsection{Method \code{load()}}{ Load new objects from characters or data.frames \subsection{Usage}{ @@ -2949,6 +2980,7 @@ idf$load("Material, mat2, smooth, 0.5, 0.2, 500, 1000,,,;", } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-update}{}}} \subsection{Method \code{update()}}{ Update existing object values from characters or data.frames \subsection{Usage}{ @@ -3076,6 +3108,7 @@ idf$update(dt) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-paste}{}}} \subsection{Method \code{paste()}}{ Paste new objects from IDF Editor \subsection{Usage}{ @@ -3128,6 +3161,7 @@ A named list of loaded \link{IdfObject} objects. } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-search_value}{}}} \subsection{Method \code{search_value()}}{ Search objects by field values using regular expression \subsection{Usage}{ @@ -3185,6 +3219,7 @@ idf$search_value("floor", "Construction", ignore.case = TRUE) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-replace_value}{}}} \subsection{Method \code{replace_value()}}{ Replace object field values using regular expression \subsection{Usage}{ @@ -3248,6 +3283,7 @@ idf$replace_value("win", "windows") } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-validate}{}}} \subsection{Method \code{validate()}}{ Check possible object field value errors \subsection{Usage}{ @@ -3430,6 +3466,7 @@ idf$validate(custom_validate(auto_field = TRUE, choice = TRUE)) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-is_valid}{}}} \subsection{Method \code{is_valid()}}{ Check if there is any error in current \code{Idf} \subsection{Usage}{ @@ -3477,6 +3514,7 @@ idf$is_valid(custom_validate(auto_field = TRUE, choice = TRUE)) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-to_string}{}}} \subsection{Method \code{to_string()}}{ Format \code{Idf} as a character vector \subsection{Usage}{ @@ -3561,6 +3599,7 @@ head(idf$to_string("floor", leading = 0, sep_at = 0)) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-to_table}{}}} \subsection{Method \code{to_table()}}{ Format \code{Idf} as a data.frame \subsection{Usage}{ @@ -3735,6 +3774,7 @@ idf$to_table(class = "BuildingSurface:Detailed", init = TRUE) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-is_unsaved}{}}} \subsection{Method \code{is_unsaved()}}{ Check if there are unsaved changes in current \code{Idf} \subsection{Usage}{ @@ -3764,6 +3804,7 @@ idf$is_unsaved() } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-save}{}}} \subsection{Method \code{save()}}{ Save \code{Idf} object as an IDF file \subsection{Usage}{ @@ -3842,6 +3883,7 @@ idf$save(path = file.path(tempdir(), "test1.idf"), copy_external = TRUE) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-run}{}}} \subsection{Method \code{run()}}{ Run simulation using EnergyPlus \subsection{Usage}{ @@ -3966,6 +4008,7 @@ job$report_data() } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-last_job}{}}} \subsection{Method \code{last_job()}}{ Get the last simulation job \subsection{Usage}{ @@ -3996,6 +4039,7 @@ idf$last_job() } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-view}{}}} \subsection{Method \code{view()}}{ View 3D \code{Idf} geometry \subsection{Usage}{ @@ -4141,6 +4185,7 @@ idf$view(new, render_by = "construction") } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-save_view}{}}} \subsection{Method \code{save_view()}}{ Capture and save current rgl view as an image \subsection{Usage}{ @@ -4199,6 +4244,7 @@ idf$save_view(tempfile(fileext = ".png")) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-print}{}}} \subsection{Method \code{print()}}{ Print \code{Idf} object \subsection{Usage}{ @@ -4265,6 +4311,7 @@ idf$print("field", order = FALSE) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-clone}{}}} \subsection{Method \code{clone()}}{ The objects of this class are cloneable with this method. \subsection{Usage}{ diff --git a/man/IdfObject.Rd b/man/IdfObject.Rd index 842829340..6cb077636 100644 --- a/man/IdfObject.Rd +++ b/man/IdfObject.Rd @@ -447,6 +447,7 @@ Hongyuan Jia } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-new}{}}} \subsection{Method \code{new()}}{ Create an \code{IdfObject} object \subsection{Usage}{ @@ -497,6 +498,7 @@ mat <- idf$Material[["C5 - 4 IN HW CONCRETE"]] } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-version}{}}} \subsection{Method \code{version()}}{ Get the version of parent \code{Idf} \subsection{Usage}{ @@ -528,6 +530,7 @@ roof$version() } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-parent}{}}} \subsection{Method \code{parent()}}{ Get parent \link{Idf} \subsection{Usage}{ @@ -555,6 +558,7 @@ roof$parent() } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-id}{}}} \subsection{Method \code{id()}}{ Get the unique ID for current object \subsection{Usage}{ @@ -586,6 +590,7 @@ roof$id() } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-name}{}}} \subsection{Method \code{name()}}{ Get the name for current object. \subsection{Usage}{ @@ -624,6 +629,7 @@ idf$Version$name() } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-group_name}{}}} \subsection{Method \code{group_name()}}{ Get name of group for current object. \subsection{Usage}{ @@ -652,6 +658,7 @@ roof$group_name() } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-class_name}{}}} \subsection{Method \code{class_name()}}{ Get name of class for current object. \subsection{Usage}{ @@ -680,6 +687,7 @@ roof$class_name() } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-definition}{}}} \subsection{Method \code{definition()}}{ Get the \link{IddObject} object for current class. \subsection{Usage}{ @@ -709,6 +717,7 @@ roof$definition() } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-comment}{}}} \subsection{Method \code{comment()}}{ Get and modify object comments \subsection{Usage}{ @@ -789,6 +798,7 @@ roof$comment() } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-value}{}}} \subsection{Method \code{value()}}{ Get object field values. \subsection{Usage}{ @@ -860,6 +870,7 @@ mat[c("Name", "Density")] } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-set}{}}} \subsection{Method \code{set()}}{ Modify object field values. \subsection{Usage}{ @@ -917,6 +928,7 @@ mat$Thickness } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-value_possible}{}}} \subsection{Method \code{value_possible()}}{ Get possible object field values. \subsection{Usage}{ @@ -1011,6 +1023,7 @@ mat$value_possible() } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-validate}{}}} \subsection{Method \code{validate()}}{ Check possible object field value errors \subsection{Usage}{ @@ -1191,6 +1204,7 @@ mat$validate(custom_validate(auto_field = TRUE, choice = TRUE)) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-is_valid}{}}} \subsection{Method \code{is_valid()}}{ Check if there is any error in current object \subsection{Usage}{ @@ -1247,6 +1261,7 @@ mat$is_valid(custom_validate(auto_field = TRUE, choice = TRUE)) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-value_relation}{}}} \subsection{Method \code{value_relation()}}{ Get value relations \subsection{Usage}{ @@ -1371,6 +1386,7 @@ roof$value_relation("name", direction = "ref_by") } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-ref_to_object}{}}} \subsection{Method \code{ref_to_object()}}{ Extract multiple \code{IdfObject} objects referred by specified field values \subsection{Usage}{ @@ -1456,6 +1472,7 @@ mat$ref_to_object() # not referencing other objects } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-ref_by_object}{}}} \subsection{Method \code{ref_by_object()}}{ Extract multiple \code{IdfObject} objects referring to specified field values \subsection{Usage}{ @@ -1541,6 +1558,7 @@ mat$ref_by_object() # referenced by construction "FLOOR" } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-ref_to_node}{}}} \subsection{Method \code{ref_to_node()}}{ Extract multiple \code{IdfObject} objects referring to same nodes \subsection{Usage}{ @@ -1606,6 +1624,7 @@ if (is_avail_eplus(8.8)) { } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-has_ref_to}{}}} \subsection{Method \code{has_ref_to()}}{ Check if object field values refer to others \subsection{Usage}{ @@ -1689,6 +1708,7 @@ mat$has_ref_to() } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-has_ref_by}{}}} \subsection{Method \code{has_ref_by()}}{ Check if object field values are referred by others \subsection{Usage}{ @@ -1772,6 +1792,7 @@ mat$has_ref_by() } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-has_ref_node}{}}} \subsection{Method \code{has_ref_node()}}{ Check if object field values refer to other nodes \subsection{Usage}{ @@ -1832,6 +1853,7 @@ mat$has_ref_node() } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-has_ref}{}}} \subsection{Method \code{has_ref()}}{ Check if object field values refer to or are referred by others \subsection{Usage}{ @@ -1895,6 +1917,7 @@ mat$has_ref() } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-to_table}{}}} \subsection{Method \code{to_table()}}{ Format \code{IdfObject} as a data.frame \subsection{Usage}{ @@ -2022,6 +2045,7 @@ surf$to_table(group_ext = "index", wide = TRUE, string_value = FALSE, unit = TRU } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-to_string}{}}} \subsection{Method \code{to_string()}}{ Format current object as a character vector \subsection{Usage}{ @@ -2074,6 +2098,7 @@ mat$to_string(leading = 0) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-print}{}}} \subsection{Method \code{print()}}{ Print \code{IdfObject} object \subsection{Usage}{ @@ -2131,6 +2156,7 @@ mat$print(auto_sep = TRUE) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-clone}{}}} \subsection{Method \code{clone()}}{ The objects of this class are cloneable with this method. \subsection{Usage}{ diff --git a/man/ParametricJob.Rd b/man/ParametricJob.Rd index a1c210567..f048eafed 100644 --- a/man/ParametricJob.Rd +++ b/man/ParametricJob.Rd @@ -198,6 +198,7 @@ Hongyuan Jia } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-new}{}}} \subsection{Method \code{new()}}{ Create a \code{ParametricJob} object \subsection{Usage}{ @@ -242,6 +243,7 @@ if (is_avail_eplus(8.8)) { } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-version}{}}} \subsection{Method \code{version()}}{ Get the version of seed IDF \subsection{Usage}{ @@ -269,6 +271,7 @@ param$version() } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-seed}{}}} \subsection{Method \code{seed()}}{ Get the seed \link{Idf} object \subsection{Usage}{ @@ -293,6 +296,7 @@ param$seed() } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-weather}{}}} \subsection{Method \code{weather()}}{ Get the \link{Epw} object \subsection{Usage}{ @@ -318,6 +322,7 @@ param$weather() } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-models}{}}} \subsection{Method \code{models()}}{ Get created parametric \link{Idf} objects \subsection{Usage}{ @@ -354,6 +359,7 @@ param$models() } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-apply_measure}{}}} \subsection{Method \code{apply_measure()}}{ Create parametric models \subsection{Usage}{ @@ -440,6 +446,7 @@ param$apply_measure(rotate_building, degree = seq(30, 360, 30), } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-save}{}}} \subsection{Method \code{save()}}{ Save parametric models \subsection{Usage}{ @@ -498,6 +505,7 @@ param$save(tempdir(), separate = FALSE) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-run}{}}} \subsection{Method \code{run()}}{ Run parametric simulations \subsection{Usage}{ @@ -570,6 +578,7 @@ print(param) } \if{html}{\out{
}} \if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-print}{}}} \subsection{Method \code{print()}}{ Print \code{ParametricJob} object \subsection{Usage}{ diff --git a/tests/testthat/test-epw.R b/tests/testthat/test-epw.R index f1ecd53af..9fd2b27de 100644 --- a/tests/testthat/test-epw.R +++ b/tests/testthat/test-epw.R @@ -296,7 +296,7 @@ test_that("Data Tagger", { rad <- epw$data()$direct_normal_radiation } ) - expect_equal(units(rad)$numerator, c("h", "W")) + expect_equal(units(rad)$numerator, c("W", "h")) expect_equal(units(rad)$denominator, c("m", "m")) expect_message(with_option(list(verbose_info = TRUE), epw$add_unit()), "already") @@ -323,7 +323,7 @@ test_that("Data Setter", { # $set() {{{ expect_is(d <- epw$data(), "data.table") - expect_message(with_option(list(verbose_info = TRUE), epw$set(d, realyear = TRUE))) + expect_output(with_option(list(verbose_info = TRUE), epw$set(d, realyear = TRUE))) expect_equal(epw$period(), data.table(index = 1L, name = "Data", start_day_of_week = "Sunday", start_day = epw_date("2017/1/1"), end_day = epw_date("2017/12/31") @@ -349,7 +349,7 @@ test_that("Data Setter", { expect_error(epw$add(epw$data()), class = "eplusr_error_parse_epw") # after 0L - expect_message(with_option(list(verbose_info = TRUE), epw$add(epw$data(start_year = 2017), realyear = TRUE))) + expect_output(with_option(list(verbose_info = TRUE), epw$add(epw$data(start_year = 2017), realyear = TRUE))) expect_equal(epw$period()$name, c("Data1", "Data")) expect_equal(lubridate::year(epw$data(1, align_wday = FALSE)$datetime[1]), 2017) expect_equal(get_priv_env(epw)$m_log$matched, diff --git a/tests/testthat/test-format.R b/tests/testthat/test-format.R index 26f649cde..d134bcabb 100644 --- a/tests/testthat/test-format.R +++ b/tests/testthat/test-format.R @@ -225,7 +225,7 @@ test_that("Idd formatting", { component = c("object", "value"))$out[c(1,2,4,5)], c("[09] Object [ID:1] ", "[05] Object [ID:2] ", - "[04] Object [ID:4] ", + "[06] Object [ID:4] ", "[01] Object [ID:5]" ) ) @@ -298,9 +298,9 @@ test_that("Idd formatting", { ) ) expect_equal( - unlist(format_objects(get_idf_value(idd_parsed, idf_parsed), - component = c("class", "object", "value"), - brief = FALSE)$out[[1L]]), + unlist(with_nocolor(format_objects(get_idf_value(idd_parsed, idf_parsed), + component = c("class", "object", "value"), + brief = FALSE)$out[[1L]])), c("Class: ", "├─ Object [ID:1] ", "│ ├─ 1: \"WD01\", !- Name", @@ -317,14 +317,16 @@ test_that("Idd formatting", { " ├─ 1: \"WD02\", !- Name", " │─ 2: \"MediumSmooth\",!- Roughness", " │─ 3: 0.019099999, !- Thickness {m}", - " └─ 4: 0.115; !- Conductivity {W/m-K}", + " │─ 4: 0.115, !- Conductivity {W/m-K}", + " │─ 5: , !- Density {kg/m3}", + " └─ 6: ; !- Specific Heat {J/kg-K}", " " ) ) expect_equal( - unlist(format_objects(get_idf_value(idd_parsed, idf_parsed), + unlist(with_nocolor(format_objects(get_idf_value(idd_parsed, idf_parsed), component = c("class", "object", "field", "value"), - brief = FALSE, merge = FALSE)$out[[1L]]), + brief = FALSE, merge = FALSE)$out[[1L]])), c("Class: ", "├─ Object [ID:1] ", "│ ├─ Field: <1: Name>", @@ -364,8 +366,14 @@ test_that("Idd formatting", { " │─ Field: <3: Thickness {m}>", " │ └─ Value: <0.019099999>", " │ ", - " └─ Field: <4: Conductivity {W/m-K}>", - " └─ Value: <0.115>", + " │─ Field: <4: Conductivity {W/m-K}>", + " │ └─ Value: <0.115>", + " │ ", + " │─ Field: <5: Density {kg/m3}>", + " │ └─ Value: <>", + " │ ", + " └─ Field: <6: Specific Heat {J/kg-K}>", + " └─ Value: <>", " " ) ) @@ -405,7 +413,9 @@ test_that("Idd formatting", { " WD02, !- Name", " MediumSmooth, !- Roughness", " 0.019099999, !- Thickness {m}", - " 0.115; !- Conductivity {W/m-K}" + " 0.115, !- Conductivity {W/m-K}", + " , !- Density {kg/m3}", + " ; !- Specific Heat {J/kg-K}" ) ) ) diff --git a/tests/testthat/test-group.R b/tests/testthat/test-group.R index 36e2c3721..130a3960b 100644 --- a/tests/testthat/test-group.R +++ b/tests/testthat/test-group.R @@ -17,7 +17,7 @@ test_that("Group methods", { path_epws <- normalizePath(list.files(file.path(eplus_config(8.8)$dir, "WeatherData"), "\\.epw", full.names = TRUE)[1:5]) - expect_error(group_job(empty_idf(8.8)), class = "error_idf_not_local") + expect_error(group_job(empty_idf(8.8)), "local", class = "eplusr_error") # can stop if input model is not saved after modification expect_error( group_job( @@ -27,7 +27,8 @@ test_that("Group methods", { ), NULL ), - class = "error_invalid_group_idf_input" + "save", + class = "eplusr_error" ) expect_silent(group_job(path_idfs, path_epws[1L])) expect_silent(group_job(path_idfs[1], path_epws)) @@ -52,8 +53,8 @@ test_that("Group methods", { ) ) expect_equal(names(status$job_status), - c("index", "status", "idf", "epw", "exit_status", "start_time", "end_time", - "energyplus", "output_dir", "stdout", "stderr" + c("index", "status", "idf", "epw", "version", "exit_status", "start_time", "end_time", + "output_dir", "energyplus", "stdout", "stderr" ) ) expect_equal(status$job_status$exit_status, c(0L, 0L, 1L, 0L, 0L)) @@ -61,12 +62,12 @@ test_that("Group methods", { # Errors {{{ expect_silent(grp$errors(2)) - expect_warning(grp$errors(3), class = "warn_job_error") + expect_warning(grp$errors(3), class = "eplusr_warning_job_error") # }}} # Output Dir{{{ expect_silent(grp$output_dir(1)) - expect_warning(grp$output_dir(3), class = "warn_job_error") + expect_warning(grp$output_dir(3), class = "eplusr_warning_job_error") # }}} # Table {{{ @@ -90,9 +91,9 @@ test_that("Group methods", { # }}} # Report Data Dict {{{ - expect_error(grp$report_data_dict(), class = "error_job_error") + expect_error(grp$report_data_dict(), class = "eplusr_error_job_error") expect_is(grp$report_data_dict(c(1,2,4,5)), "data.table") - expect_true(has_name(grp$report_data_dict(c(1,2,4,5)), "case")) + expect_true(has_names(grp$report_data_dict(c(1,2,4,5)), "case")) expect_equal(nrow(grp$report_data_dict(2)), 22) expect_equal(nrow(grp$report_data_dict("1zoneevapcooler")), 22) # }}} diff --git a/tests/testthat/test-idf.R b/tests/testthat/test-idf.R index 39539855d..699476833 100644 --- a/tests/testthat/test-idf.R +++ b/tests/testthat/test-idf.R @@ -690,7 +690,10 @@ test_that("$load()", { "Material,", " mat, !- Name", " MediumSmooth, !- Roughness", - " 0.667; !- Thickness {m}", + " 0.667, !- Thickness {m}", + " 0.5,", + " 800,", + " 300;", "Construction, const, mat;" ) ) @@ -717,7 +720,7 @@ test_that("$update()", { # can stop if trying to update non-named objects using string expect_error(idf$update("SimulationControl, no;\n")) - expect_is(idf$update("Material:NoMass, R13LAYER, Smooth;\n"), "list") + expect_is(idf$update("Material:NoMass, R13LAYER, Smooth, 2;\n"), "list") expect_equal(idf$Material_NoMass$R13LAYER$Roughness, "Smooth") expect_is(class = "list", @@ -738,7 +741,7 @@ test_that("$validate()", { expect_equal(nrow(val$duplicate_object), 0) expect_equal(nrow(val$conflict_name), 0) expect_equal(nrow(val$incomplete_extensible), 0) - expect_equal(nrow(val$missing_value), 0) + expect_equal(nrow(val$missing_value), 2) expect_equal(nrow(val$invalid_autosize), 0) expect_equal(nrow(val$invalid_autocalculate), 0) expect_equal(nrow(val$invalid_character), 0) @@ -1127,7 +1130,7 @@ test_that("add_idd_class_bindings", { expect_true(all(idf$class_name() %in% ls(idf))) expect_null(without_checking(idf$Timestep <- NULL)) - expect_output(print(idf)) + expect_output(with_option(list(autocomplete = TRUE), print(idf))) expect_false("Timestep" %in% ls(idf)) }) # }}} @@ -1241,7 +1244,7 @@ test_that("[[<-.Idf and $<-.Idf", { expect_null(without_checking(idf$SimulationControl <- NULL)) expect_false(idf$is_valid_class("SimulationControl")) expect_null(idf$SimulationControl) - expect_false({capture.output(print(idf)); "SimulationControl" %in% names(idf)}) + expect_false({capture.output(with_option(list(autocomplete = TRUE), print(idf))); "SimulationControl" %in% names(idf)}) # can insert unique-object class expect_silent(idf$SimulationControl <- tbl) diff --git a/tests/testthat/test-idfobj.R b/tests/testthat/test-idfobj.R index 14c90f4ce..17df9780b 100644 --- a/tests/testthat/test-idfobj.R +++ b/tests/testthat/test-idfobj.R @@ -267,6 +267,11 @@ test_that("$validate()", { value_num = rep(NA_real_, 3L) ) ) + + if (!is_avail_eplus(8.8)) install_eplus(8.8) + idf <- read_idf(file.path(eplus_config(8.8)$dir, "ExampleFiles/5Zone_Transformer.idf")) + idf$dup(c(my_roof = "ROOF-1", "ROOF-1", "WALL-1")) + expect_equal(nrow(idf$validate()$invalid_reference), 0L) }) # }}} @@ -604,7 +609,7 @@ test_that("add_idfobj_field_bindings()", { expect_is(idf <- read_idf(text("idf", 8.8), use_idd(8.8, "auto")), "Idf") expect_is(ver <- with_option(list(autocomplete = FALSE), add_idfobj_field_bindings(IdfObject$new(5, parent = idf))), "IdfObject") - expect_false("Version Identifier" %in% ls(obj)) + expect_false("Version Identifier" %in% ls(ver)) expect_is(ver <- with_option(list(autocomplete = TRUE), add_idfobj_field_bindings(IdfObject$new(5, parent = idf))), "IdfObject") expect_true("Version Identifier" %in% ls(ver)) diff --git a/tests/testthat/test-impl-epw.R b/tests/testthat/test-impl-epw.R index 0cbd8f394..fcf86e040 100644 --- a/tests/testthat/test-impl-epw.R +++ b/tests/testthat/test-impl-epw.R @@ -46,26 +46,29 @@ test_that("Epw Header", { expect_equal(h$value[object_id %in% c(6, 7), value_chr], rep(NA_character_, 2)) # can fix mismatched extensible group and value of number field - DC <- function (n = 1, m = n) { - htg <- c("heating", 1:15) - clg <- c("cooling", 1:32) - ext <- c("extremes", 1:16) - grp <- paste0(rep(c(htg, clg, ext), m), collapse = ",") - paste("DESIGN CONDITIONS", n, "src", "", grp, sep = ",", collapse = ",") - } expect_warning( - h <- parse_epw_header(paste0( - " - LOCATION,city,state,country,type,wmo,1,2,3,4 - ", DC(0, 1), " - TYPICAL/EXTREME PERIODS,0,period,typical,1/1,1/2 - GROUND TEMPERATURES,0,0.5,,,,", paste0(1:12, collapse = ","), " - HOLIDAYS/DAYLIGHT SAVINGS,yes,0,0,0,New year,1/1 - COMMENTS 1 - COMMENTS 2 - DATA PERIODS,1,1,Data,Friday,2016/01/01,2016/12/31,Data1,Friday,2017/01/01,2017/12/31 - " - )), + { + DC <- function (n = 1, m = n) { + htg <- c("heating", 1:15) + clg <- c("cooling", 1:32) + ext <- c("extremes", 1:16) + grp <- paste0(rep(c(htg, clg, ext), m), collapse = ",") + paste("DESIGN CONDITIONS", n, "src", "", grp, sep = ",", collapse = ",") + } + + h <- parse_epw_header(paste0( + " + LOCATION,city,state,country,type,wmo,1,2,3,4 + ", DC(0, 1), " + TYPICAL/EXTREME PERIODS,0,period,typical,1/1,1/2 + GROUND TEMPERATURES,0,0.5,,,,", paste0(1:12, collapse = ","), " + HOLIDAYS/DAYLIGHT SAVINGS,yes,0,0,0,New year,1/1 + COMMENTS 1 + COMMENTS 2 + DATA PERIODS,1,1,Data,Friday,2016/01/01,2016/12/31,Data1,Friday,2017/01/01,2017/12/31 + " + )) + }, "Number of Design Conditions" ) expect_equal(h$value[object_id == 2, value_num][1], 1L) @@ -287,7 +290,7 @@ test_that("Epw Header", { ) expect_error( - h <- parse_epw_header(paste0( + suppressWarnings(h <- parse_epw_header(paste0( " LOCATION,city,state,country,type,wmo,1,2,3,4 DESIGN CONDITIONS @@ -298,7 +301,7 @@ test_that("Epw Header", { COMMENTS 2 DATA PERIODS,1,1,Data,Friday,2016/2/29,2016/3/1 " - )), + ))), class = "eplusr_error_parse_epw" ) diff --git a/tests/testthat/test-impl-idf.R b/tests/testthat/test-impl-idf.R index f1b19af58..09831ff60 100644 --- a/tests/testthat/test-impl-idf.R +++ b/tests/testthat/test-impl-idf.R @@ -135,7 +135,7 @@ test_that("table", { # VALUE {{{ # get all value from current idf {{{ - expect_equivalent(nrow(get_idf_value(idd_env, idf_env)), 44L) + expect_equivalent(nrow(get_idf_value(idd_env, idf_env)), 46L) expect_equivalent(names(get_idf_value(idd_env, idf_env)), c("rleid", "class_id", "class_name", "object_id", "object_name", "field_id", "field_index", "field_name", "value_id", "value_chr", "value_num" @@ -145,26 +145,28 @@ test_that("table", { # get value from class {{{ # get values from certain class {{{ expect_silent({val <- get_idf_value(idd_env, idf_env, "Material")}) - expect_equivalent(val$value_id, c(1:9, 40:43)) - expect_equivalent(val$object_id, c(rep(1L, 9), rep(4L, 4))) - expect_equivalent(val$field_id, c(7081:7089, 7081:7084)) - expect_equivalent(val$class_id, rep(55L, 13)) - expect_equivalent(val$field_index, c(1:9, 1:4)) + expect_equivalent(val$value_id, c(1:9, 40:43, 45:46)) + expect_equivalent(val$object_id, c(rep(1L, 9), rep(4L, 6))) + expect_equivalent(val$field_id, c(7081:7089, 7081:7086)) + expect_equivalent(val$class_id, rep(55L, 15)) + expect_equivalent(val$field_index, c(1:9, 1:6)) expect_equivalent(val$field_name, c( c("Name", "Roughness", "Thickness", "Conductivity", "Density", "Specific Heat", "Thermal Absorptance", "Solar Absorptance", "Visible Absorptance"), - c("Name", "Roughness", "Thickness", "Conductivity") + c("Name", "Roughness", "Thickness", "Conductivity", "Density", + "Specific Heat" + ) ) ) - expect_equivalent(val$rleid, rep(1L, 13)) - expect_equivalent(val$class_name, rep("Material", 13)) - expect_equivalent(val$object_name, c(rep("WD01", 9), rep("WD02", 4))) + expect_equivalent(val$rleid, rep(1L, 15)) + expect_equivalent(val$class_name, rep("Material", 15)) + expect_equivalent(val$object_name, c(rep("WD01", 9), rep("WD02", 6))) # }}} # get values from class but ensure all objects have same field {{{ expect_silent({val <- get_idf_value(idd_env, idf_env, "Material", align = TRUE)}) - expect_equivalent(val$value_id, c(1:9, 40:43, -1:-5)) + expect_equivalent(val$value_id, c(1:9, 40:43, 45:46, -1:-3)) expect_equivalent(val$object_id, rep(c(1L, 4L), each = 9)) expect_equivalent(val$field_id, rep(7081:7089, 2)) expect_equivalent(val$class_id, rep(55L, 18)) @@ -183,7 +185,7 @@ test_that("table", { # }}} # get values from class and ensure all objects have min required fields {{{ expect_silent({val <- get_idf_value(idd_env, idf_env, "Material", complete = TRUE)}) - expect_equivalent(val$value_id, c(1:9, 40:43, -1:-2)) + expect_equivalent(val$value_id, c(1:9, 40:43, 45:46)) expect_equivalent(val$object_id, c(rep(1L, 9), rep(4L, 6))) expect_equivalent(val$field_id, c(7081:7089, 7081:7086)) expect_equivalent(val$class_id, rep(55L, 15)) @@ -202,7 +204,7 @@ test_that("table", { # }}} # get values from class and ensure all objects have min required fields and same field number {{{ expect_silent({val <- get_idf_value(idd_env, idf_env, "Material", align = TRUE, complete = TRUE)}) - expect_equivalent(val$value_id, c(1:9, 40:43, -1:-5)) + expect_equivalent(val$value_id, c(1:9, 40:43, 45:46, -1:-3)) expect_equivalent(val$object_id, rep(c(1L, 4L), each = 9)) expect_equivalent(val$field_id, rep(7081:7089, 2)) expect_equivalent(val$class_id, rep(55L, 18)) @@ -221,7 +223,7 @@ test_that("table", { # }}} # get values from class and ensure all objects have all fields {{{ expect_silent({val <- get_idf_value(idd_env, idf_env, "Material", all = TRUE)}) - expect_equivalent(val$value_id, c(1:9, 40:43, -1:-5)) + expect_equivalent(val$value_id, c(1:9, 40:43, 45:46, -1:-3)) expect_equivalent(val$object_id, rep(c(1L, 4L), each = 9)) expect_equivalent(val$field_id, rep(7081:7089, 2)) expect_equivalent(val$class_id, rep(55L, 18)) @@ -246,26 +248,27 @@ test_that("table", { # get value from object {{{ # get values from certain class {{{ expect_silent({val <- get_idf_value(idd_env, idf_env, object = c("WD01", "WD02"))}) - expect_equivalent(val$value_id, c(1:9, 40:43)) - expect_equivalent(val$object_id, c(rep(1L, 9), rep(4L, 4))) - expect_equivalent(val$field_id, c(7081:7089, 7081:7084)) - expect_equivalent(val$class_id, rep(55L, 13)) - expect_equivalent(val$field_index, c(1:9, 1:4)) + expect_equivalent(val$value_id, c(1:9, 40:43, 45:46)) + expect_equivalent(val$object_id, c(rep(1L, 9), rep(4L, 6))) + expect_equivalent(val$field_id, c(7081:7089, 7081:7086)) + expect_equivalent(val$class_id, rep(55L, 15)) + expect_equivalent(val$field_index, c(1:9, 1:6)) expect_equivalent(val$field_name, c( c("Name", "Roughness", "Thickness", "Conductivity", "Density", "Specific Heat", "Thermal Absorptance", "Solar Absorptance", "Visible Absorptance"), - c("Name", "Roughness", "Thickness", "Conductivity") + c("Name", "Roughness", "Thickness", "Conductivity", "Density", + "Specific Heat") ) ) - expect_equivalent(val$rleid, c(rep(1L, 9), rep(2L, 4))) - expect_equivalent(val$class_name, rep("Material", 13)) - expect_equivalent(val$object_name, c(rep("WD01", 9), rep("WD02", 4))) + expect_equivalent(val$rleid, c(rep(1L, 9), rep(2L, 6))) + expect_equivalent(val$class_name, rep("Material", 15)) + expect_equivalent(val$object_name, c(rep("WD01", 9), rep("WD02", 6))) # }}} # get values from class but ensure all objects have same field {{{ expect_silent({val <- get_idf_value(idd_env, idf_env, object = c("WD01", "WD02"), align = TRUE)}) - expect_equivalent(val$value_id, c(1:9, 40:43, -1:-5)) + expect_equivalent(val$value_id, c(1:9, 40:43, 45:46, -1:-3)) expect_equivalent(val$object_id, rep(c(1L, 4L), each = 9)) expect_equivalent(val$field_id, rep(7081:7089, 2)) expect_equivalent(val$class_id, rep(55L, 18)) @@ -284,7 +287,7 @@ test_that("table", { # }}} # get values from class and ensure all objects have min required fields {{{ expect_silent({val <- get_idf_value(idd_env, idf_env, object = c("WD01", "WD02"), complete = TRUE)}) - expect_equivalent(val$value_id, c(1:9, 40:43, -1:-2)) + expect_equivalent(val$value_id, c(1:9, 40:43, 45:46)) expect_equivalent(val$object_id, c(rep(1L, 9), rep(4L, 6))) expect_equivalent(val$field_id, c(7081:7089, 7081:7086)) expect_equivalent(val$class_id, rep(55L, 15)) @@ -303,7 +306,7 @@ test_that("table", { # }}} # get values from class and ensure all objects have min required fields and same field number {{{ expect_silent({val <- get_idf_value(idd_env, idf_env, object = c("WD01", "WD02"), align = TRUE, complete = TRUE)}) - expect_equivalent(val$value_id, c(1:9, 40:43, -1:-5)) + expect_equivalent(val$value_id, c(1:9, 40:43, 45:46, -1:-3)) expect_equivalent(val$object_id, rep(c(1L, 4L), each = 9)) expect_equivalent(val$field_id, rep(7081:7089, 2)) expect_equivalent(val$class_id, rep(55L, 18)) @@ -322,7 +325,7 @@ test_that("table", { # }}} # get values from class and ensure all objects have all fields {{{ expect_silent({val <- get_idf_value(idd_env, idf_env, object = c("WD01", "WD02"), all = TRUE)}) - expect_equivalent(val$value_id, c(1:9, 40:43, -1:-5)) + expect_equivalent(val$value_id, c(1:9, 40:43, 45:46, -1:-3)) expect_equivalent(val$object_id, rep(c(1L, 4L), each = 9)) expect_equivalent(val$field_id, rep(7081:7089, 2)) expect_equivalent(val$class_id, rep(55L, 18)) @@ -390,13 +393,13 @@ test_that("table", { expect_equal(get_idf_value(idd_env, idf_env, "Version")$value_id, 44L) expect_equal(get_idf_value(idd_env, idf_env, "Version", field = 1L)$value_id, 44L) expect_equal(get_idf_value(idd_env, idf_env, "Version", field = "Version Identifier")$value_id, 44L) - expect_equal(get_idf_value(idd_env, idf_env, "Material")$value_id, c(1L:9L, 40L:43L)) + expect_equal(get_idf_value(idd_env, idf_env, "Material")$value_id, c(1L:9L, 40L:43L, 45:46)) fld_nm <- c("Conductivity", "Visible Absorptance") expect_equal(get_idf_value(idd_env, idf_env, "Material", field = c(4L, 9L))$value_id, c(4L, 9L, 43L)) expect_equal(get_idf_value(idd_env, idf_env, "Material", field = fld_nm)$value_id, c(4L, 9L, 43L)) expect_equal(get_idf_value(idd_env, idf_env, "Material", field = c(4L, 9L), align = TRUE)$value_id, c(4L, 9L, 43L, -1L)) expect_equal(get_idf_value(idd_env, idf_env, "Material", field = fld_nm, align = TRUE)$value_id, c(4L, 9L, 43L, -1L)) - expect_equal(get_idf_value(idd_env, idf_env, "Material", field = c(4L, 3L), complete = TRUE)$value_id, c(1:6, 40:43, -1:-2)) + expect_equal(get_idf_value(idd_env, idf_env, "Material", field = c(4L, 3L), complete = TRUE)$value_id, c(1:6, 40:43, 45:46)) fld_nm <- c("Layer 3", "Visible Absorptance") expect_equal(get_idf_value(idd_env, idf_env, c("Construction", "Material"), field = c(4L, 9L))$value_id, c(13L, 9L)) expect_equal(get_idf_value(idd_env, idf_env, c("Construction", "Material"), field = fld_nm)$value_id, c(13L, 9L)) @@ -417,7 +420,7 @@ test_that("table", { object_id = NA_integer_, object_name = NA_character_, field_id = 7081:7086, field_index = 1:6, field_name = c("Name", "Roughness", "Thickness", "Conductivity", "Density", "Specific Heat"), - value_id = 45:50, value_chr = NA_character_, value_num = NA_real_ + value_id = 47:52, value_chr = NA_character_, value_num = NA_real_ ) ) expect_equivalent(init_idf_value(idd_env, idf_env, "Material", property = "is_name"), @@ -425,7 +428,7 @@ test_that("table", { object_id = NA_integer_, object_name = NA_character_, field_id = 7081:7086, field_index = 1:6, field_name = c("Name", "Roughness", "Thickness", "Conductivity", "Density", "Specific Heat"), - value_id = 45:50, value_chr = NA_character_, value_num = NA_real_, + value_id = 47:52, value_chr = NA_character_, value_num = NA_real_, is_name = c(TRUE, rep(FALSE, 5)) ) ) @@ -772,24 +775,12 @@ test_that("VALUE DOTS", { ) ) a <- "cls1" - b <- c("cls2", "cls3") - expect_equal(parse_dots_value(..(a) := list(), ..(b) := list(), .empty = TRUE), - list(object = data.table(rleid = c(1L, 2L, 2L), each_rleid = c(1L, 1L, 2L), - id = NA_integer_, name = paste0("cls", 1:3), - comment = list(), is_ref = TRUE, lhs_sgl = FALSE, rhs_sgl = TRUE, is_empty = TRUE), - value = data.table(rleid = c(1L, 2L, 2L), each_rleid = c(1L, 1L, 2L), - id = NA_integer_, name = paste0("cls", 1:3), - field_index = NA_integer_, field_name = NA_character_, - value_chr = NA_character_, value_num = NA_real_ - ) - ) - ) - expect_equal(parse_dots_value(..("cls1") := list(), ..("cls2", "cls3") := list(), .empty = TRUE), - list(object = data.table(rleid = c(1L, 2L, 2L), each_rleid = c(1L, 1L, 2L), - id = NA_integer_, name = paste0("cls", 1:3), - comment = list(), is_ref = TRUE, lhs_sgl = FALSE, rhs_sgl = TRUE, is_empty = TRUE), - value = data.table(rleid = c(1L, 2L, 2L), each_rleid = c(1L, 1L, 2L), - id = NA_integer_, name = paste0("cls", 1:3), + expect_equal(parse_dots_value(..(a) := list(), ..("cls2") := list(), .empty = TRUE), + list(object = data.table(rleid = c(1L, 2L), each_rleid = c(1L, 1L), + id = NA_integer_, name = paste0("cls", 1:2), + comment = list(), is_ref = TRUE, lhs_sgl = TRUE, rhs_sgl = TRUE, is_empty = TRUE), + value = data.table(rleid = c(1L, 2L), each_rleid = c(1L, 1L), + id = NA_integer_, name = paste0("cls", 1:2), field_index = NA_integer_, field_name = NA_character_, value_chr = NA_character_, value_num = NA_real_ ) @@ -1486,12 +1477,12 @@ test_that("LITERAL DOTS", { comment = c(list(" some comments;"), rep(list(NULL), 5L)) ) ) - expect_equal(l$value$rleid, c(rep(1L, 3), rep(2L, 2), rep(3:6, each = 6))) - expect_equal(l$value$class_id, c(rep(55L, 3), rep(90L, 2), rep(c(55L, 55L, 56L, 56L), each = 6))) - expect_equal(l$value$object_id, rep(NA_integer_, 29)) - expect_equal(l$value$object_name, rep(NA_character_, 29)) - expect_equal(l$value$value_id, rep(NA_integer_, 29)) - expect_equal(l$value$value_num, c(NA, NA, 0.667, rep(NA, 16), 2.290965, 0.9, 0.75, 0.75, NA, NA, 5.456, 0.9, 0.75, 0.75)) + expect_equal(l$value$rleid, c(rep(1L, 6), rep(2L, 2), rep(3:6, each = 6))) + expect_equal(l$value$class_id, c(rep(55L, 6), rep(90L, 2), rep(c(55L, 55L, 56L, 56L), each = 6))) + expect_equal(l$value$object_id, rep(NA_integer_, 32)) + expect_equal(l$value$object_name, rep(NA_character_, 32)) + expect_equal(l$value$value_id, rep(NA_integer_, 32)) + expect_equal(l$value$value_num, c(NA, NA, 0.667, rep(NA, 19), 2.290965, 0.9, 0.75, 0.75, NA, NA, 5.456, 0.9, 0.75, 0.75)) # whole game expect_is(class = "list", @@ -1509,6 +1500,7 @@ test_that("LITERAL DOTS", { ) ) ) + expect_equal(names(l), c("object", "value")) expect_equal(l$object, data.table( @@ -1520,12 +1512,12 @@ test_that("LITERAL DOTS", { comment = c(list(" some comments;"), rep(list(NULL), 5L)) ) ) - expect_equal(l$value$rleid, c(rep(1L, 3), rep(2L, 3), rep(3:6, each = 6))) - expect_equal(l$value$class_id, c(rep(55L, 6), rep(56L, 24))) - expect_equal(l$value$object_id, rep(c(14L, 12L, 13L, 12L, 13L), each = 6)) - expect_equal(l$value$object_name, c(rep("C5 - 4 IN HW CONCRETE", 6), rep(rep(c("R13LAYER", "R31LAYER"), 2), each = 6))) - expect_equal(l$value$value_id, c(rep(99:101, 2), rep(87:98, 2))) - expect_equal(l$value$value_num, c(rep(c(NA, NA, 0.2), 2), rep(c(NA, NA, 2.290965, 0.9, 0.75, 0.75, NA, NA, 5.456, 0.9, 0.75, 0.75), 2))) + expect_equal(l$value$rleid, c(rep(1L, 6), rep(2:6, each = 6))) + expect_equal(l$value$class_id, c(rep(55L, 12), rep(56L, 24))) + expect_equal(l$value$object_id, c(rep(14L, 12), rep(c(12L, 13L, 12L, 13L), each = 6))) + expect_equal(l$value$object_name, c(rep("C5 - 4 IN HW CONCRETE", 12), rep(rep(c("R13LAYER", "R31LAYER"), 2), each = 6))) + expect_equal(l$value$value_id, c(rep(99:104, 2), rep(87:98, 2))) + expect_equal(l$value$value_num, c(rep(c(NA, NA, 0.2, NA, NA, NA), 2), rep(c(NA, NA, 2.290965, 0.9, 0.75, 0.75, NA, NA, 5.456, 0.9, 0.75, 0.75), 2))) }) # }}} diff --git a/tests/testthat/test-install.R b/tests/testthat/test-install.R index bdad3ace7..1a184ffde 100644 --- a/tests/testthat/test-install.R +++ b/tests/testthat/test-install.R @@ -2,8 +2,7 @@ test_that("Install", { skip_on_cran() expect_equal(as.character(avail_eplus()), names(.globals$eplus)) if (is_avail_eplus(8.8)) expect_error(install_eplus(8.8, local = TRUE)) - if (is_macos()) expect_error(install_eplus(8.8, local = TRUE)) - else install_eplus(8.8, local = TRUE, force = TRUE) + else install_eplus(8.8, local = TRUE) # test if patch on EnergyPlus v9.1 and above works if (!is_avail_eplus(9.1)) install_eplus(9.1, local = TRUE) diff --git a/tests/testthat/test-param.R b/tests/testthat/test-param.R index 503dd8c03..52e7fb67e 100644 --- a/tests/testthat/test-param.R +++ b/tests/testthat/test-param.R @@ -6,7 +6,7 @@ test_that("Parametric methods", { if (!is_avail_eplus(8.8)) install_eplus(8.8) - expect_error(param_job(empty_idf(8.8), NULL), class = "error_idf_not_local") + expect_error(param_job(empty_idf(8.8), NULL), class = "eplusr_error_idf_not_local") example <- copy_example() @@ -126,15 +126,15 @@ test_that("Parametric methods", { ) ) expect_equal(names(status$job_status), - c("index", "status", "idf", "epw", "exit_status", "start_time", "end_time", - "energyplus", "output_dir", "stdout", "stderr" + c("index", "status", "idf", "epw", "version", "exit_status", "start_time", "end_time", + "output_dir", "energyplus", "stdout", "stderr" ) ) # }}} # Report Data Dict {{{ expect_is(param$report_data_dict(), "data.table") - expect_true(has_name(param$report_data_dict(), "case")) + expect_true(has_names(param$report_data_dict(), "case")) expect_equal(nrow(param$report_data_dict(2)), 20) expect_equal(nrow(param$report_data_dict("set_infil_rate_2")), 20) # }}} diff --git a/tests/testthat/test-parse.R b/tests/testthat/test-parse.R index 8690c5c87..525a0a7dc 100644 --- a/tests/testthat/test-parse.R +++ b/tests/testthat/test-parse.R @@ -302,7 +302,7 @@ test_that("parse_idd_file()", { expect_equal(idd_parsed$field$field_id, 1:149) # can parse field property data - expect_is(fld <- idd_parsed$field[field_name == "Data Source and Uncertainty Flags"], "data.table") + expect_is(fld <- idd_parsed$field[class_id == 9L & field_name == "Data Source"], "data.table") expect_equal(fld$units, NA_character_) expect_equal(fld$ip_units, NA_character_) expect_equal(fld$is_name, FALSE) @@ -329,7 +329,7 @@ test_that("parse_idd_file()", { expect_equal(fld$missing_num, NA_real_) # can parse field property data - expect_is(fld <- idd_parsed$field[field_name == "Liquid Precipitation Depth"], "data.table") + expect_is(fld <- idd_parsed$field[field_name == "Liquid Precip Depth"], "data.table") expect_equal(fld$units, "mm") expect_equal(fld$ip_units, NA_character_) expect_equal(fld$is_name, FALSE) @@ -351,7 +351,7 @@ test_that("parse_idd_file()", { expect_equal(fld$exist_maximum, 999) expect_equal(fld$exist_minimum, 0) expect_equal(fld$exist_lower_incbounds, TRUE) - expect_equal(fld$exist_upper_incbounds, TRUE) + expect_equal(fld$exist_upper_incbounds, FALSE) expect_equal(fld$missing_chr, "999") expect_equal(fld$missing_num, 999) @@ -361,7 +361,7 @@ test_that("parse_idd_file()", { expect_equal(fld$exist_maximum, 99.9) expect_equal(fld$exist_minimum, -Inf) expect_equal(fld$exist_lower_incbounds, FALSE) - expect_equal(fld$exist_upper_incbounds, TRUE) + expect_equal(fld$exist_upper_incbounds, FALSE) expect_equal(fld$missing_chr, "99.9") expect_equal(fld$missing_num, 99.9) @@ -523,7 +523,7 @@ test_that("parse_idf_file()", { # can handle DDY without giving unnecessary warning ddy <- tempfile(fileext = ".ddy") file.create(ddy) - expect_silent(idf_parsed <- parse_idf_file(ddy)) + expect_silent(idf_parsed <- parse_idf_file(ddy, 8.8)) unlink(ddy) }) # }}} diff --git a/tests/testthat/test-rdd.R b/tests/testthat/test-rdd.R index 476c052f8..3063eec78 100644 --- a/tests/testthat/test-rdd.R +++ b/tests/testthat/test-rdd.R @@ -16,16 +16,16 @@ test_that("Rdd", { expect_equal(attr(mdd, "eplus_version"), idf$version()) expect_error(rdd_to_load(rdd, reporting_frequency = "hour"), - class = "error_invalid_reporting_frequency" + class = "eplusr_error" ) expect_error(mdd_to_load(mdd, reporting_frequency = "hour"), - class = "error_invalid_reporting_frequency" + class = "eplusr_error" ) expect_error(rdd_to_load(rdd[1:2][, reporting_frequency := c(1, 2)]), - class = "error_invalid_reporting_frequency" + class = "eplusr_error" ) expect_error(mdd_to_load(mdd[1:2][, reporting_frequency := c(1, 2)]), - class = "error_invalid_reporting_frequency" + class = "eplusr_error" ) expect_error(mdd_to_load(mdd, class = "")) diff --git a/tests/testthat/test-reload.R b/tests/testthat/test-reload.R index b045e0293..743933574 100644 --- a/tests/testthat/test-reload.R +++ b/tests/testthat/test-reload.R @@ -61,13 +61,8 @@ test_that("Reload", { expect_true(data.table::truelength(get_priv_env(idf)$idf_env()$reference) > 0L) } - expect_true(data.table::truelength(get_priv_env(epw)$m_header$typical) > 0L) - expect_true(data.table::truelength(get_priv_env(epw)$m_header$ground) > 0L) - expect_true(data.table::truelength(get_priv_env(epw)$m_header$holiday$holiday) > 0L) - expect_true(data.table::truelength(get_priv_env(epw)$m_header$period$period) > 0L) - expect_true(data.table::truelength(get_priv_env(epw)$m_data) > 0L) - expect_idf_reloaded(idf) + expect_idf_reloaded(epw) expect_idf_reloaded(get_priv_env(job)$m_idf) expect_idf_reloaded(get_priv_env(par)$m_seed) lapply(get_priv_env(grp)$m_idfs, expect_idf_reloaded) diff --git a/tests/testthat/test-transition.R b/tests/testthat/test-transition.R index 73019d7fc..060e9806f 100644 --- a/tests/testthat/test-transition.R +++ b/tests/testthat/test-transition.R @@ -438,47 +438,47 @@ test_that("Transition v8.0 --> v8.1", { expect_equal( idfVU$"HVACTemplate:Zone:PTAC"[[1]]$value(), - idfTR$"HVACTemplate:Zone:PTAC"[[1]]$value(1:36) + idfTR$"HVACTemplate:Zone:PTAC"[[1]]$value() ) expect_equal( idfVU$"HVACTemplate:Zone:PTAC"[[2]]$value(), - idfTR$"HVACTemplate:Zone:PTAC"[[2]]$value(1:36) + idfTR$"HVACTemplate:Zone:PTAC"[[2]]$value() ) expect_equal( idfVU$"HVACTemplate:Zone:PTHP"[[1]]$value(), - idfTR$"HVACTemplate:Zone:PTHP"[[1]]$value(1:46) + idfTR$"HVACTemplate:Zone:PTHP"[[1]]$value() ) expect_equal( idfVU$"HVACTemplate:Zone:PTHP"[[2]]$value(), - idfTR$"HVACTemplate:Zone:PTHP"[[2]]$value(1:46) + idfTR$"HVACTemplate:Zone:PTHP"[[2]]$value() ) expect_equal( idfVU$"HVACTemplate:Zone:WaterToAirHeatPump"[[1]]$value(), - idfTR$"HVACTemplate:Zone:WaterToAirHeatPump"[[1]]$value(1:41) + idfTR$"HVACTemplate:Zone:WaterToAirHeatPump"[[1]]$value() ) expect_equal( idfVU$"HVACTemplate:Zone:WaterToAirHeatPump"[[2]]$value(), - idfTR$"HVACTemplate:Zone:WaterToAirHeatPump"[[2]]$value(1:41) + idfTR$"HVACTemplate:Zone:WaterToAirHeatPump"[[2]]$value() ) expect_equal( idfVU$"HVACTemplate:System:Unitary"$Sys1$value(), - idfTR$"HVACTemplate:System:Unitary"$Sys1$value(1:47) + idfTR$"HVACTemplate:System:Unitary"$Sys1$value() ) expect_equal( idfVU$"HVACTemplate:System:Unitary"$Sys2$value(), - idfTR$"HVACTemplate:System:Unitary"$Sys2$value(1:47) + idfTR$"HVACTemplate:System:Unitary"$Sys2$value() ) expect_equal( idfVU$"HVACTemplate:System:UnitaryHeatPump:AirToAir"$Sys3$value(), - idfTR$"HVACTemplate:System:UnitaryHeatPump:AirToAir"$Sys3$value(1:56) + idfTR$"HVACTemplate:System:UnitaryHeatPump:AirToAir"$Sys3$value() ) expect_equal( idfVU$"HVACTemplate:System:UnitaryHeatPump:AirToAir"$Sys4$value(), - idfTR$"HVACTemplate:System:UnitaryHeatPump:AirToAir"$Sys4$value(1:56) + idfTR$"HVACTemplate:System:UnitaryHeatPump:AirToAir"$Sys4$value() ) }) # }}} @@ -1020,7 +1020,7 @@ test_that("Transition v8.5 --> v8.6", { # NOTE: VersionUpdater failed to update `Lighting Control Type` and always # returned "Continuous" idfVU$"Daylighting:Controls"$DELight3$value()[-5], - idfTR$"Daylighting:Controls"$DELight3$value(1:13)[-5] + idfTR$"Daylighting:Controls"$DELight3$value()[-5] ) expect_equal( idfTR$"Daylighting:Controls"$DELight3$value("Lighting Control Type")[[1]], @@ -1485,14 +1485,14 @@ test_that("Transition v9.0 --> v9.1", { test_that("Transition v9.1 --> v9.2", { skip_on_cran() from <- 9.1; to <- 9.2 - f <- tempfile(fileext = ".csv") - writeLines("", f) + unlink(file.path(tempdir(), "test.csv")) + writeLines("", file.path(tempdir(), "test.csv")) expect_is(class = "Idf", idfOri <- temp_idf(from, "Foundation:Kiva" = list(), "RunPeriod" := list(c(paste0("runperiod", c("", 1:5), "rp"))), "RunPeriod" := list(..2 = rep(1:5)), - "Schedule:File" = list(..3 = f, ..7 = "fixed"), + "Schedule:File" = list(..3 = file.path(tempdir(), "test.csv"), ..7 = "fixed"), "Table:OneIndependentVariable" = list( "One", "Quadratic", "EvaluateCurveToLimits", 0.0, 1.0, 0.85, 1.0, "Dimensionless", "Dimensionless", NULL, 0.0, 0.85, 0.5, @@ -1622,8 +1622,6 @@ test_that("Transition v9.1 --> v9.2", { ) ) - idf <- read_idf("/mnt/c/Users/hongy/Desktop/LookupTables_V920.idf") - expect_is(idfVU <- version_updater(idfOri, to), "Idf") expect_warning(idfTR <- transition(idfOri, to), "comments") diff --git a/tests/testthat/test-validate.R b/tests/testthat/test-validate.R index f03d1c40a..f7e064ef7 100644 --- a/tests/testthat/test-validate.R +++ b/tests/testthat/test-validate.R @@ -134,8 +134,8 @@ test_that("Validate method", { invisible(env_in$value[J(c(1L, 10L, 15L)), on = "value_id", value_chr := NA_character_]) expect_silent({mis <- check_missing_value(idd_env, idf_env, env_in)$validity$missing_value}) - expect_equal(mis$object_id, 1:3) - expect_equal(mis$value_id, c(1L, 10L, 15L)) + expect_equal(mis$object_id, c(1:3, 4, 4)) + expect_equal(mis$value_id, c(1L, 10L, 15L, 45L, 46L)) # }}} # INVALID AUTOSIZE {{{ @@ -191,8 +191,8 @@ test_that("Validate method", { invisible(env_in$value[object_id == 1L & type_enum <= IDDFIELD_TYPE$real, `:=`(value_num = NA_real_)]) expect_silent({num <- check_invalid_numeric(idd_env, idf_env, env_in)$validity$invalid_numeric}) - expect_equal(num$object_id, c(rep(1L, 7), rep(3L, 3))) - expect_equal(num$value_id, c(3:9, 37:39)) + expect_equal(num$object_id, c(rep(1L, 7), rep(3L, 3), rep(4L, 2))) + expect_equal(num$value_id, c(3:9, 37:39, 45:46)) # }}} # INVALID INTEGER {{{ From 47cf41a1ef6222b999824068647e168c396d01dc Mon Sep 17 00:00:00 2001 From: Hongyuan Jia Date: Sun, 26 Jul 2020 20:27:04 +0800 Subject: [PATCH 29/43] [fix] Fix checks --- DESCRIPTION | 2 +- R/constants.R | 116 +++++++++++++++++----------------- R/idfobj.R | 2 +- R/impl-idf.R | 33 +++++----- R/parse.R | 2 +- R/run.R | 2 +- man/as.character.IdfObject.Rd | 12 +++- man/parse_dots_value.Rd | 59 +++++++++++++++++ tests/testthat/test-units.R | 111 -------------------------------- 9 files changed, 148 insertions(+), 191 deletions(-) create mode 100644 man/parse_dots_value.Rd diff --git a/DESCRIPTION b/DESCRIPTION index f97f1633a..e5c193d62 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -23,7 +23,7 @@ Imports: checkmate, cli (>= 1.1.0), crayon, - data.table (>= 1.12.4), + data.table (>= 1.13.0), lubridate, methods, processx (>= 3.2.0), diff --git a/R/constants.R b/R/constants.R index e6ed1c818..3a6d966a3 100644 --- a/R/constants.R +++ b/R/constants.R @@ -56,68 +56,66 @@ MACRO_DICT <- "##symboltable", "##clear", "##reverse", "##!") # }}} # init var{{{ -`.` <- `.GRP` <- `.I` <- `.N` <- `.SD` <- `.BY` <- J <- N <- V1 <- V2 <- NULL +`.` <- `..` <- `.GRP` <- `.I` <- `.N` <- `.SD` <- `.BY` <- `.EACHI` <- J <- N <- V1 <- V2 <- NULL utils::globalVariables(c( - "acceptable_num", "all_cmt", "all_name_lower", "annual", "auto_assigned", - "autocalculatable", "autosizable", "begin_extensible", - "can_be_na", "check", "check_lower", "check_upper", "choice", "class_id", - "class_name", "colon_loc", "con", "contents", "copied", "country", - "datetime", "datetime1", "day", "day_in", "ddy_name", "ddy_url", "default", - "default_chr", "default_num", "defaulted", "dep", "depth", "design_day", - "dis", "dot", "dot_nm", "dt", "dup_time", "empty", "end", "end_day", - "end_time", "envir", "envir_index", "epw", "epw_name", "epw_url", "excl_loc", - "exit_status", "ext", "extensible", "extensible_group", "field", - "field_anid", "field_anid_an", "field_count", "field_id", "field_in", - "field_index", "field_name", "field_name_noid", "field_rleid", - "first_extensible", "fmt", "found", "from", "group", "group_id", - "group_name", "has_any_na", "has_range", "header", "hour", "hour_in", "id", - "id_list", "idf", "index", "index_str", "info", "input_num", "ip", - "ip_units", "is_all_na", "is_name", "last_extensible", "last_required", - "latitude", "left_fields", "left_group", "level", "level_index", - "level_num", "line", "line_s", "ln_miss", "location", "longitude", - "lower_incbounds", "max_suffix_num", "maximum", "maximum<", "mes_miss", - "mes_object", "min_fields", "min_required", "minimum", "minimum>", "minute", - "model", "month_in", "msg", "name", "new_comment", "new_object_name", - "new_value", "new_value_num", "nm", "num", "num_extensible", - "num_extensible_group", "num_fields", "num_group", "object_id", - "object_list", "object_name", "object_name_lower", "object_order", - "object_rleid", "old_exist", "old_object_name", "old_object_name_lower", - "out", "out_of_range", "output_dir", "prefix", "ref_class", "ref_field", - "ref_object", "ref_value", "reference", "reference_class_name", "reporting_frequency", - "required_field", "required_object", "res", "rev_field_rleid", "same_dir", - "si", "slash", "slash_key", "slash_loc", "slash_value", "slash_value_lower", - "slash_value_rleid", "soil_conductivity", "soil_density", - "soil_specific_heat", "source_type", "space_loc", "spcl_loc", "src_class", - "src_class_id", "src_class_name", "src_enum", "src_field", "src_field_id", - "src_field_index", "src_field_name", "src_object", "src_object_id", - "src_value", "src_value_chr", "src_value_id", "start", "start_day", - "start_day_of_week", "state_province", "status", "string", "temp", - "temperature", "title", "to", "type", "type_enum", "type_exp", - "unique_object", "upper_incbounds", "use_input_name", "value", "value_chr", - "value_count", "value_id", "value_lower", "value_num", "weather", - "wmo_number", "x", "year_in", "J", "num_fld", "max_fld", "Date/Time", - "Variable", "i.datetime", "i.day", "i.hour", "i.minute", "i.month", - "i.object_id", "i.rleid", "old", "key_value", "i.key_value", "i.value", - "field_num", "i.class_id", "i.min_fields", "i.num_extensible", - "i.extensible_group", "i.required_field", "i.comment", "old_min_fields", - "new_rleid", "sgl_object_id", "sql", "day_type", "simulation_days", - "row_index", "is_num", "alpha", "azimuth_angle", "boundary_lower", "color", - "color_int", "construction_name", "dir_relative_north", "height", - "height_width", "i.color", "i.id", "i.name", "i.origin_x", "i.origin_y", - "i.origin_z", "i.outside_boundary_condition", "i.projection_axis", - "i.subtype", "i.type", "i.x", "i.y", "i.z", "i.zone_name", "index_vertex", - "origin_x", "origin_y", "origin_z", "outside_boundary_condition", + "Date/Time", "Variable", "acceptable_num", "all_name_lower", "alpha", + "annual", "autocalculatable", "autosizable", "azimuth_angle", + "begin_extensible", "boundary_lower", "can_be_na", "check", "check_lower", + "check_upper", "choice", "class_id", "class_name", "color", "color_int", + "construction_name", "country", "data", "datetime", "day", "day_type", + "ddy_name", "ddy_url", "default", "default_chr", "default_num", + "design_day", "dir_relative_north", "each_rleid", "end", "end_day", + "end_time", "envir", "envir_index", "epw", "epw_name", "epw_url", + "excl_loc", "exist_maximum", "exist_maximum_l", "exist_minimum", + "exist_minimum_u", "exit_status", "ext", "extensible", + "extensible_field_index", "extensible_group", "field", "field_anid", + "field_anid_an", "field_count", "field_id", "field_in", "field_index", + "field_name", "field_name_noid", "field_num", "field_rleid", + "first_extensible", "fmt", "found", "group", "group_id", "group_name", + "has_any_na", "has_range", "header", "height", "height_width", "hour", + "i.class_id", "i.color", "i.comment", "i.datetime", "i.day", + "i.extensible_group", "i.field_id", "i.field_index", "i.field_name", + "i.hour", "i.id", "i.key_value", "i.min_fields", "i.minute", "i.month", + "i.name", "i.new_object_name_lower", "i.num_extensible", "i.object_id", + "i.object_name", "i.object_name_lower", "i.object_order", "i.object_rleid", + "i.origin_x", "i.origin_y", "i.origin_z", "i.outside_boundary_condition", + "i.projection_axis", "i.required_field", "i.rleid", "i.src_value_chr", + "i.src_value_id", "i.src_value_num", "i.subtype", "i.type", + "i.unique_object_id", "i.value", "i.value_chr", "i.value_id", "i.value_num", + "i.value_type", "i.x", "i.y", "i.z", "i.zone_name", "id", "id_list", "idf", + "index", "index_str", "index_vertex", "info", "input_num", "ip", "ip_name", + "ip_units", "is_all_na", "is_empty", "is_name", "is_num", "is_ref", + "is_resource", "key_value", "last_extensible", "last_required", "latitude", + "left_fields", "left_group", "level", "level_index", "level_num", "lhs_sgl", + "line", "line_redudant", "line_s", "location", "longitude", + "lower_incbounds", "matched", "max_fld", "maximum", "maximum_l", + "mes_object", "min_fields", "min_required", "minimum", "minimum_u", + "minite", "minute", "missing_num", "model", "msg", "n", "name", + "new_object_name", "new_object_name_lower", "new_year", "num", + "num_extensible", "num_extensible_group", "num_fields", "num_fld", + "num_group", "obj_num", "object_id", "object_id_dup", "object_list", + "object_name", "object_name_lower", "object_order", "object_rleid", "old", + "old_exist", "old_min_fields", "origin_x", "origin_y", "origin_z", "out", + "output_dir", "outside_boundary_condition", "outside_boundary_condition_object", "parent_surface_name", "patterns", - "projected_x", "projected_y", "projection_axis", "starting_x_coordinate", - "starting_y_coordinate", "starting_z_coordinate", "sun_exposure", - "sun_exposure_lower", "surface_type", "surface_type_int", "tilt_angle", - "wind_exposure", "wind_exposure_lower", "y", "z", "zone", "zone_name", - "cls", "i.class_name", "i.value_chr", "i.value_id", "i.value_num", "pointer", - "src_object_name", "i.field_id", "i.field_index", "i.object_name", - "i.src_object_id", "i.src_value_chr", "i.src_value_id", "i.src_value_num", - "is_resource", "merged", "object_id_dup", "removed", "src_type_enum", - "src_value_num" + "pointer", "prefix", "projected_x", "projected_y", "projection_axis", + "reference", "reference_class_name", "removed", "reporting_frequency", + "required_field", "required_object", "rev_field_rleid", "rhs_sgl", + "row_index", "same_dir", "si", "si_name", "si_standard_name", + "simulation_days", "slash", "slash_key", "slash_loc", "slash_value", + "source_type", "space_loc", "spcl_loc", "src_class_id", "src_class_name", + "src_enum", "src_field_id", "src_field_index", "src_field_name", + "src_object_id", "src_object_name", "src_type_enum", "src_value_chr", + "src_value_id", "src_value_num", "start", "start_day", "start_day_of_week", + "starting_x_coordinate", "starting_y_coordinate", "starting_z_coordinate", + "state_province", "status", "string", "sun_exposure", "sun_exposure_lower", + "surface_type", "surface_type_int", "tilt_angle", "title", "type", + "type_enum", "type_rleid", "unique_object", "unique_object_id", + "update_value_reference", "upper_incbounds", "value", "value_chr", + "value_count", "value_id", "value_lower", "value_num", "value_type", + "variable", "weather", "wind_exposure", "wind_exposure_lower", "wmo_number", + "x", "y", "z", "zone_name" )) # }}} # nocov end diff --git a/R/idfobj.R b/R/idfobj.R index 1d5a59ce4..a56f2e5b3 100644 --- a/R/idfobj.R +++ b/R/idfobj.R @@ -1916,7 +1916,7 @@ format.IdfObject <- function (x, comment = TRUE, leading = 4L, sep_at = 29L, all #' #' Coerce an [IdfObject] into a character vector in the same way as in IDF Editor. #' -#' @inheritParams format.IddObject +#' @inherit format.IdfObject #' @return A character vector. #' @examples #' \dontrun{ diff --git a/R/impl-idf.R b/R/impl-idf.R index 2e8d41819..1642d77cf 100644 --- a/R/impl-idf.R +++ b/R/impl-idf.R @@ -423,8 +423,8 @@ make_idf_object_name <- function (idd_env, idf_env, dt_object, use_old = TRUE, # sep objects with/without name attr can_nm <- dt_object$has_name - dt_obj_nm <- .Call(data.table:::CsubsetDT, dt_object, which(can_nm), seq_along(dt_object)) - dt_obj_no <- .Call(data.table:::CsubsetDT, dt_object, which(!can_nm), seq_along(dt_object)) + dt_obj_nm <- dt_object[which(can_nm)] + dt_obj_no <- dt_object[which(!can_nm)] # stop if trying to assign names to objects that do not have name attribute if (any(!is.na(dt_obj_no$new_object_name))) { @@ -446,8 +446,8 @@ make_idf_object_name <- function (idd_env, idf_env, dt_object, use_old = TRUE, # auto-generate object names if necessary autoname <- is.na(dt_obj_nm$new_object_name) - dt_obj_nm_auto <- .Call(data.table:::CsubsetDT, dt_obj_nm, which(autoname), seq_along(dt_obj_nm)) - dt_obj_nm_input <- .Call(data.table:::CsubsetDT, dt_obj_nm, which(!autoname), seq_along(dt_obj_nm)) + dt_obj_nm_auto <- dt_obj_nm[which(autoname)] + dt_obj_nm_input <- dt_obj_nm[which(!autoname)] # check if input new names are the same as existing ones if (nrow(invld <- dt_all[dt_obj_nm_input, on = c("class_id", object_name_lower = "new_object_name_lower"), nomatch = 0L])) { @@ -968,7 +968,7 @@ expand_idf_dots_name <- function (idd_env, idf_env, ..., .keep_name = TRUE, .pro } # }}} # parse_dots_value {{{ -#' @inheritParams expand_idf_dots_value +#' @inherit expand_idf_dots_value #' @export parse_dots_value <- function (..., .scalar = TRUE, .pair = FALSE, .ref_assign = TRUE, .unique = FALSE, @@ -1543,8 +1543,8 @@ expand_idf_dots_value <- function (idd_env, idf_env, ..., obj_val <- val } else { # separate class input and object input - cls <- .Call(data.table:::CsubsetDT, obj, which(obj$lhs_sgl), seq_along(obj)) - obj <- .Call(data.table:::CsubsetDT, obj, which(!obj$lhs_sgl), seq_along(obj)) + cls <- obj[lhs_sgl == TRUE] + obj <- obj[lhs_sgl == FALSE] # match class name cls_in <- cls[, list(class_name = name[[1L]], is_empty = is_empty[[1L]], rhs_sgl = rhs_sgl[[1L]], num = .N), by = "rleid"] @@ -1573,8 +1573,8 @@ expand_idf_dots_value <- function (idd_env, idf_env, ..., } # separate class value input and object value input - cls_val <- .Call(data.table:::CsubsetDT, val, which(val$rleid %in% cls_in$rleid), seq_along(val)) - obj_val <- .Call(data.table:::CsubsetDT, val, which(!val$rleid %in% cls_in$rleid), seq_along(val)) + cls_val <- val[rleid %in% cls_in$rleid] + obj_val <- val[!rleid %in% cls_in$rleid] # extract values for empty input # empty here means to extract all objects in that class @@ -1585,8 +1585,8 @@ expand_idf_dots_value <- function (idd_env, idf_env, ..., cls_obj_emp <- data.table() cls_val_emp <- data.table() } else { - cls_obj_emp <- .Call(data.table:::CsubsetDT, cls_obj, which(cls_obj$rleid %in% cls_in$rleid[cls_in$is_empty]), seq_along(cls_obj)) - cls_obj <- .Call(data.table:::CsubsetDT, cls_obj, which(!cls_obj$rleid %in% cls_in$rleid[cls_in$is_empty]), seq_along(cls_obj)) + cls_obj_emp <- cls_obj[rleid %in% cls_in$rleid[cls_in$is_empty]] + cls_obj <- cls_obj[!rleid %in% cls_in$rleid[cls_in$is_empty]] cls_val_emp <- get_idf_value(idd_env, idf_env, cls_in$class_id[cls_in$is_empty], complete = .complete, all = .all @@ -1605,7 +1605,7 @@ expand_idf_dots_value <- function (idd_env, idf_env, ..., } # exclude empty value input - cls_val <- .Call(data.table:::CsubsetDT, cls_val, which(!cls_val$rleid %in% cls_in$rleid[cls_in$is_empty]), seq_along(cls_val)) + cls_val <- cls_val[rleid %in% cls_in$rleid[cls_in$is_empty]] } if (!nrow(cls_val)) { @@ -1767,8 +1767,8 @@ expand_idf_dots_value <- function (idd_env, idf_env, ..., obj_emp <- data.table() val_emp <- data.table() } else { - obj_emp <- .Call(data.table:::CsubsetDT, obj, which(obj$rleid %in% obj$rleid[obj$is_empty]), seq_along(obj)) - obj <- .Call(data.table:::CsubsetDT, obj, which(!obj$rleid %in% obj$rleid[obj$is_empty]), seq_along(obj)) + obj_emp <- obj[rleid %in% obj$rleid[obj$is_empty]] + obj <- obj[!rleid %in% obj$rleid[obj$is_empty]] set(obj_emp, NULL, c("is_empty", "each_rleid"), NULL) @@ -1789,7 +1789,7 @@ expand_idf_dots_value <- function (idd_env, idf_env, ..., } # exclude empty value input - obj_val <- .Call(data.table:::CsubsetDT, obj_val, which(obj_val$rleid %in% obj$rleid), seq_along(obj_val)) + obj_val <- obj_val[rleid %in% obj$rleid] } if (!nrow(obj_val)) { @@ -2642,6 +2642,7 @@ dup_idf_object <- function (idd_env, idf_env, dt_object, level = eplusr_option(" if (nrow(ref)) { set(ref, NULL, c("object_id", "value_id"), NULL) setnames(ref, c("new_object_id", "new_value_id"), c("object_id", "value_id")) + setcolorder(ref, names(idf_env$reference)) } # remove original ids @@ -2787,7 +2788,7 @@ add_idf_object <- function (idd_env, idf_env, dt_object, dt_value, if (!length(k)) { ref <- idf_env$reference[0L] } else { - ref <- .Call(data.table:::CsubsetDT, idf_env$reference, k, seq_along(idf_env$reference)) + ref <- idf_env$reference[k] # remove from the original IDF reference table idf_env$reference <- idf_env$reference[-k] } diff --git a/R/parse.R b/R/parse.R index 479c855cc..b88111b1e 100644 --- a/R/parse.R +++ b/R/parse.R @@ -328,7 +328,7 @@ clean_idd_lines <- function (dt) { # remove empty lines i <- which(!stri_isempty(dt[["string"]])) - if (length(i)) dt <- .Call(data.table:::CsubsetDT, dt, i, seq_along(dt)) + if (length(i)) dt <- dt[i] dt } diff --git a/R/run.R b/R/run.R index ca137c4d2..f6e2c576f 100644 --- a/R/run.R +++ b/R/run.R @@ -389,7 +389,7 @@ run_multi <- function (model, weather, output_dir, design_day = FALSE, # always echo in order to catch standard output and error options$echo <- TRUE callr::r_bg(function (jobs, options) { - eplusr:::run_parallel_jobs(jobs, options) + utils::getFromNamespace("run_parallel_jobs", "eplusr")(jobs, options) }, args = list(jobs = jobs, options = options)) } } diff --git a/man/as.character.IdfObject.Rd b/man/as.character.IdfObject.Rd index 8ff943f28..943684a2b 100644 --- a/man/as.character.IdfObject.Rd +++ b/man/as.character.IdfObject.Rd @@ -7,7 +7,17 @@ \method{as.character}{IdfObject}(x, comment = TRUE, leading = 4L, sep_at = 29L, all = FALSE, ...) } \arguments{ -\item{x}{An \link{IddObject} object.} +\item{x}{An \link{IdfObject} object.} + +\item{comment}{If \code{FALSE}, all comments will not be included. Default: \code{TRUE}.} + +\item{leading}{Leading spaces added to each field. Default: \code{4L}.} + +\item{sep_at}{The character width to separate value string and field string. +Default: \code{29L} which is the same as IDF Editor.} + +\item{all}{If \code{TRUE}, values of all possible fields in current class the +\link{IdfObject} belongs to are returned. Default: \code{FALSE}} \item{...}{Further arguments passed to or from other methods.} } diff --git a/man/parse_dots_value.Rd b/man/parse_dots_value.Rd new file mode 100644 index 000000000..6bedb67a3 --- /dev/null +++ b/man/parse_dots_value.Rd @@ -0,0 +1,59 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/impl-idf.R +\name{parse_dots_value} +\alias{parse_dots_value} +\title{Parse object field values given in list format} +\usage{ +parse_dots_value( + ..., + .scalar = TRUE, + .pair = FALSE, + .ref_assign = TRUE, + .unique = FALSE, + .empty = FALSE, + .env = parent.frame() +) +} +\arguments{ +\item{...}{Lists of object definitions. Each list should be named +with a valid class/object id/name. ID should be denoted in style +\code{..ID}. There is a special element \code{.comment} in each list, which will +be used as new comments of the object. If \code{.ref_assign} is \code{TRUE}, +\verb{:=} can be used to group ids/names: +\itemize{ +\item When \code{.type} equals \code{"class"}, LHS multiple class indices/names should be +wrapped by \code{.()}, \code{c()}. +\item When \code{.type} equals \code{"object"}, LHS multiple object ids/names should be +wrapped by \code{.()} or \code{c()}. LHS \strong{SINGLE} class name should be +wrapped by \code{..()}. +}} + +\item{.scalar}{If \code{TRUE}, make sure the value of each field in the object is a +scalar value. If \code{FALSE}, \code{value_chr} and \code{value_num} column will be +list type. Default: \code{TRUE}.} + +\item{.pair}{Only works when \code{.scalar} is \code{FALSE}. If \code{.pair} is \code{TRUE}, +vector field values will be paired to each id/name on the LHS. In this +case, \code{value_chr} and \code{value_num} will be character type and double +type, respectively. When there is only one id/name on the LHS, it will +be replicated to match the length of the value vector. Default: \code{FALSE}.} + +\item{.ref_assign}{If \code{TRUE}, allow using \verb{:=} to gather multiple +classes/objects on the LHS when defining the objects. Default: \code{TRUE}.} + +\item{.unique}{If \code{TRUE}, make sure there are no duplicated classes/objects in +the input. Default: \code{FALSE}.} + +\item{.empty}{If \code{TRUE}, allow using an empty list, i.e. \code{list()} to define an +object with all default values. Default: \code{TRUE}.} + +\item{.env}{An environment specifying the environment to evaluate the \code{...}. +Default: \code{\link[=parent.frame]{parent.frame()}}.} +} +\value{ +A named list of 2 element \code{object} and \code{value} which is a +\code{\link[data.table:data.table]{data.table::data.table()}} with object data and value data respectively. +} +\description{ +Parse object field values given in list format +} diff --git a/tests/testthat/test-units.R b/tests/testthat/test-units.R index fc46ea776..c85968a36 100644 --- a/tests/testthat/test-units.R +++ b/tests/testthat/test-units.R @@ -7,118 +7,7 @@ test_that("Units conversion", { expect_equal(units::set_units(1, "dollar") + units::set_units(1, "dollar"), units::set_units(2, "dollar") ) - expect_equal(units::set_units(1, "Wh") + units::set_units(3600, "J"), - units::set_units(2, "Wh") - ) expect_equal(units::set_units(units::set_units(1, "inH2O"), "inch_H2O_39F"), units::set_units(1, "inch_H2O_39F") ) - - expect_equal(NULL %||% 1, 1) - expect_equal(1 %||% 2, 1) - - expect_equal(collapse(1:3), "'1', '2' and '3'") - expect_equal(collapse(1:3, out = NULL), "1, 2 and 3") - expect_equal(collapse(1, out = NULL), "1") - expect_equal(collapse(1:3, or = NULL), "'1', '2', '3'") - expect_equal(collapse(1:3, or = TRUE), "'1', '2' or '3'") - - expect_equal(surround(1:3), c("'1'", "'2'", "'3'")) - expect_equal(surround(1:3, out = NULL), as.character(1:3)) - - expect_null(rpad(NULL)) - expect_equal(rpad(c(1, 10)), c("1 ", "10")) - expect_equal(rpad(c(1, 10), width = 3), c("1 ", "10 ")) - - expect_null(lpad(NULL)) - expect_equal(lpad(c(1, 10)), c(" 1", "10")) - expect_equal(lpad(c(1, 10), width = 3), c(" 1", " 10")) - - expect_error(read_lines(NULL), "Failed to read input file") - expect_equal(read_lines("a\n b \n c \n"), data.table(line = 1:3, string = c("a", "b", "c"))) - - f <- tempfile() - expect_silent(write_lines(read_lines("a\nb"), f)) - expect_equal(read_lines(f), data.table(line = 1:2, string = c("a", "b"))) - expect_silent(write_lines(c("a", "b"), f)) - expect_equal(read_lines(f), data.table(line = 1:2, string = c("a", "b"))) - expect_silent(write_lines(c("c", "d"), f, append = TRUE)) - expect_equal(read_lines(f), data.table(line = 1:4, string = c("a", "b", "c", "d"))) - expect_error(write_lines(1:3, f), "Must be of type 'character'") - - expect_equal(standardize_ver("latest"), numeric_version("9.2.0")) - expect_equal(standardize_ver("latest", strict = TRUE), numeric_version(NA, strict = FALSE)) - expect_equal(standardize_ver(c(1, 1.1)), numeric_version(c("1.0.0", "1.1.0"))) - expect_equal(standardize_ver(c(1, 1.1), complete = FALSE), numeric_version(c("1.0", "1.1"))) - expect_equal(standardize_ver(c("1.0", "1.1.0.01")), numeric_version(c("1.0.0", "1.1.0"))) - expect_equal(standardize_ver(c("1.0", "1.1.0.01"), complete = FALSE), numeric_version(c("1.0", "1.1.0"))) - - expect_error(match_minor_ver(1), "numeric_version") - expect_error(match_minor_ver(numeric_version(1:2)), "length 1") - expect_equal(match_minor_ver(numeric_version("0.0"), ALL_IDD_VER), numeric_version(NA, strict = FALSE)) - expect_equal(match_minor_ver(numeric_version("9.1"), ALL_IDD_VER), numeric_version("9.1.0")) - expect_equal(match_minor_ver(numeric_version("9.0"), ALL_IDD_VER), numeric_version("9.0.1")) - - expect_equal(vec_depth(NULL), 0L) - expect_equal(vec_depth(character()), 1L) - expect_equal(vec_depth(list()), 1L) - expect_equal(vec_depth(list(list())), 2L) - expect_equal(vec_depth(list(list(NULL))), 2L) - expect_equal(vec_depth(list(list(1))), 3L) - expect_error(vec_depth(environment()), "must be a vector") - - expect_equal(vlapply(1:3, is.integer), rep(TRUE, 3L)) - expect_equal(vlapply(setNames(1:3, c("a", "b", "c")), is.integer), setNames(rep(TRUE, 3L), c("a", "b", "c"))) - expect_equal(vlapply(setNames(1:3, c("a", "b", "c")), is.integer, use.names = FALSE), rep(TRUE, 3L)) - - expect_equal(viapply(1:3, length), rep(1L, 3L)) - expect_equal(viapply(setNames(1:3, c("a", "b", "c")), length), setNames(rep(1L, 3L), c("a", "b", "c"))) - expect_equal(viapply(setNames(1:3, c("a", "b", "c")), length, use.names = FALSE), rep(1L, 3L)) - - expect_equal(vcapply(1:3, paste), as.character(1:3)) - expect_equal(vcapply(setNames(1:3, c("a", "b", "c")), paste), setNames(as.character(1:3), c("a", "b", "c"))) - expect_equal(vcapply(setNames(1:3, c("a", "b", "c")), paste, use.names = FALSE), as.character(1:3)) - - expect_equal(apply2(1:3, 4:6, "+"), list(5L, 7L, 9L)) - expect_equal(apply2_int(1:3, 4:6, "+"), c(5L, 7L, 9L)) - expect_equal(apply2_lgl(1:3, 4:6, ">"), rep(FALSE, 3L)) - expect_equal(apply2_chr(1:3, 4:6, paste0), c("14", "25", "36")) - - expect_equal(underscore_name("Class Name"), "Class_Name") - expect_equal(underscore_name("Class:Name"), "Class_Name") - expect_equal(lower_name("Class:Name"), "class_name") - expect_equal(lower_name("Class Name"), "class_name") - - expect_equal(make_filename(c("", "")), c("_a____", "_a_____1")) - expect_equal(make_filename(c("", ""), unique = FALSE), c("_a____", "_a____")) - - expect_equal(names2(1:3), rep(NA_character_, 3)) - expect_equal(names2(c(a = 1, 2)), c("a", NA_character_)) - - expect_equal(each_length(list(1, 2:3)), c(1L, 2L)) - - expect_equal(ranger()[], list(minimum = -Inf, lower_incbounds = FALSE, maximum = Inf, upper_incbounds = FALSE)) - expect_equal(format(ranger()), "(-Inf, Inf)") - expect_equal(ranger(1, TRUE)[], list(minimum = 1, lower_incbounds = TRUE, maximum = Inf, upper_incbounds = FALSE)) - expect_equal(format(ranger(1, TRUE)), "[1, Inf)") - - expect_error(append_dt(data.table(a = 1), data.table())) - expect_equal(append_dt(data.table(), data.table()), data.table()) - expect_equal(append_dt(data.table(a = 1), data.table(a = 2, b = 1)), data.table(a = c(1, 2))) - expect_equal(append_dt(data.table(a = 1, b = 1), data.table(a = c(1, 2), b = c(3, 4)), "a"), data.table(a = c(1, 2), b = c(3, 4))) - - expect_equal(fmt_dbl(1.111), "1.11") - expect_equal(fmt_dbl(1.111, 1), "1.1") - expect_equal(fmt_int(1), "1.0") - expect_equal(fmt_int(1, 0), "1") - - expect_equal(wday(as.Date("2020-01-01")), 3L) - expect_equal(as.character(wday(as.Date("2020-01-01"), label = TRUE)), "Wednesday") - - expect_equal(str_trunc("abcdefghij", 10), "abcde...") - - expect_equal(match_in_vec("a", LETTERS), 1L) - expect_equal(match_in_vec("a", LETTERS, "aa"), 1L) - expect_equal(match_in_vec("a", LETTERS, "aa", label = TRUE), "A") - expect_equal(match_in_vec("aa", LETTERS, "aa", label = TRUE), "A") }) From b5ee6504685631a03e5de2d132471d0ae0da5306 Mon Sep 17 00:00:00 2001 From: Hongyuan Jia Date: Sun, 26 Jul 2020 21:10:29 +0800 Subject: [PATCH 30/43] [fix] Fix checks --- R/constants.R | 4 ++-- R/impl-idf.R | 12 ++++-------- tests/testthat/test-idf.R | 2 +- 3 files changed, 7 insertions(+), 11 deletions(-) diff --git a/R/constants.R b/R/constants.R index 3a6d966a3..357f0a0e4 100644 --- a/R/constants.R +++ b/R/constants.R @@ -59,8 +59,8 @@ MACRO_DICT <- `.` <- `..` <- `.GRP` <- `.I` <- `.N` <- `.SD` <- `.BY` <- `.EACHI` <- J <- N <- V1 <- V2 <- NULL utils::globalVariables(c( - "Date/Time", "Variable", "acceptable_num", "all_name_lower", "alpha", - "annual", "autocalculatable", "autosizable", "azimuth_angle", + "..", "J", "Date/Time", "Variable", "acceptable_num", "all_name_lower", + "alpha", "annual", "autocalculatable", "autosizable", "azimuth_angle", "begin_extensible", "boundary_lower", "can_be_na", "check", "check_lower", "check_upper", "choice", "class_id", "class_name", "color", "color_int", "construction_name", "country", "data", "datetime", "day", "day_type", diff --git a/R/impl-idf.R b/R/impl-idf.R index 1642d77cf..dabbbc4a8 100644 --- a/R/impl-idf.R +++ b/R/impl-idf.R @@ -1605,7 +1605,7 @@ expand_idf_dots_value <- function (idd_env, idf_env, ..., } # exclude empty value input - cls_val <- cls_val[rleid %in% cls_in$rleid[cls_in$is_empty]] + cls_val <- cls_val[!rleid %in% cls_in$rleid[cls_in$is_empty]] } if (!nrow(cls_val)) { @@ -2637,13 +2637,9 @@ dup_idf_object <- function (idd_env, idf_env, dt_object, level = eplusr_option(" dt_id <- fast_subset(val, c("object_id", "value_id", "new_value_id")) setnames(dt_id, "object_id", "new_object_id") ref <- idf_env$reference[dt_id, on = "value_id", nomatch = 0L] - - # update ids in ref - if (nrow(ref)) { - set(ref, NULL, c("object_id", "value_id"), NULL) - setnames(ref, c("new_object_id", "new_value_id"), c("object_id", "value_id")) - setcolorder(ref, names(idf_env$reference)) - } + set(ref, NULL, c("object_id", "value_id"), NULL) + setnames(ref, c("new_object_id", "new_value_id"), c("object_id", "value_id")) + setcolorder(ref, names(idf_env$reference)) # remove original ids set(val, NULL, "value_id", NULL) diff --git a/tests/testthat/test-idf.R b/tests/testthat/test-idf.R index 699476833..3ca6aae82 100644 --- a/tests/testthat/test-idf.R +++ b/tests/testthat/test-idf.R @@ -1129,7 +1129,7 @@ test_that("add_idd_class_bindings", { expect_is(with_option(list(autocomplete = TRUE), idf <- read_idf(example())), "Idf") expect_true(all(idf$class_name() %in% ls(idf))) - expect_null(without_checking(idf$Timestep <- NULL)) + expect_null(without_checking(with_option(list(autocomplete = TRUE), idf$Timestep <- NULL))) expect_output(with_option(list(autocomplete = TRUE), print(idf))) expect_false("Timestep" %in% ls(idf)) }) From f1b7ff08496ebbbb606d93884d4154b3d5474aa4 Mon Sep 17 00:00:00 2001 From: Hongyuan Jia Date: Sun, 26 Jul 2020 21:31:51 +0800 Subject: [PATCH 31/43] [fix] Fix tests --- tests/testthat/test-idf.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/testthat/test-idf.R b/tests/testthat/test-idf.R index 3ca6aae82..fa55ff08e 100644 --- a/tests/testthat/test-idf.R +++ b/tests/testthat/test-idf.R @@ -1247,9 +1247,9 @@ test_that("[[<-.Idf and $<-.Idf", { expect_false({capture.output(with_option(list(autocomplete = TRUE), print(idf))); "SimulationControl" %in% names(idf)}) # can insert unique-object class - expect_silent(idf$SimulationControl <- tbl) + expect_silent(with_option(list(autocomplete = TRUE), idf$SimulationControl <- tbl)) expect_true(idf$is_valid_class("SimulationControl")) - expect_silent(idf$SimulationControl <- str) + expect_silent(with_option(list(autocomplete = TRUE), idf$SimulationControl <- str)) expect_true("SimulationControl" %in% names(idf)) # }}} From 09119c6ea746a89f83ede4e849163b508f21fbd7 Mon Sep 17 00:00:00 2001 From: Hongyuan Jia Date: Sun, 26 Jul 2020 22:10:50 +0800 Subject: [PATCH 32/43] [fix] Fix tests on Windows --- R/impl-idf.R | 4 ++++ tests/testthat/test-impl-idf.R | 17 ++++++++++------- tests/testthat/test-run.R | 18 +++++++++--------- tests/testthat/test-transition.R | 11 +++-------- 4 files changed, 26 insertions(+), 24 deletions(-) diff --git a/R/impl-idf.R b/R/impl-idf.R index dabbbc4a8..84557b099 100644 --- a/R/impl-idf.R +++ b/R/impl-idf.R @@ -3908,6 +3908,10 @@ read_idfeditor_copy <- function (idd_env, idf_env, version = NULL, in_ip = FALSE text <- paste0("!-Option SortedOrder ViewInIPunits\n", text) } + if (is.null(version)) { + version <- get_idf_value(idd_env, idf_env, "Version")$value_chr + } + # ignore the warning of using given IDD parsed <- withCallingHandlers(parse_idf_file(text, idd = version, ref = FALSE), eplusr_warning = function (w) invokeRestart("muffleWarning") diff --git a/tests/testthat/test-impl-idf.R b/tests/testthat/test-impl-idf.R index 09831ff60..a06ee3430 100644 --- a/tests/testthat/test-impl-idf.R +++ b/tests/testthat/test-impl-idf.R @@ -2380,7 +2380,7 @@ test_that("Save", { ) expect_silent( save_idf(idd_env, idf_env, idf_env$object[, list(object_id, object_order = 0)], - file.path(tempdir(), tempfile(), basename(tempfile(fileext = ".idf"))), format = "new_top" + file.path(tempdir(), basename(tempfile()), basename(tempfile(fileext = ".idf"))), format = "new_top" ) ) expect_silent( @@ -2410,19 +2410,22 @@ test_that("resolve external link", { l <- add_idf_object(idd_env, idf_env, l$object, l$value) # can give warnings if links are broken - expect_warning(flg <- resolve_idf_external_link(idd_env, l, example(), tempfile(fileext = ".idf")), "Broken") + dir <- tempfile() + dir.create(dir, FALSE) + path <- file.path(dir, "test.idf") + expect_warning(flg <- resolve_idf_external_link(idd_env, l, path, tempfile(fileext = ".idf")), "Broken") expect_false(flg) # can keep the original link if copy is not required writeLines(",\n", f) - expect_false(resolve_idf_external_link(idd_env, l, tempfile(fileext = ".idf"), example(), copy = FALSE)) + expect_is(resolve_idf_external_link(idd_env, l, tempfile(fileext = ".idf"), path, copy = FALSE), "logical") expect_equal(l$value[field_id == 7074, normalizePath(value_chr)], normalizePath(f)) - expect_true(resolve_idf_external_link(idd_env, l, tempfile(fileext = ".idf"), example(), copy = TRUE)) - expect_true(file.exists(file.path(dirname(example()), basename(f)))) - expect_equal(l$value[field_id == 7074, normalizePath(value_chr, mustWork = FALSE)], basename(f)) + expect_true(resolve_idf_external_link(idd_env, l, tempfile(fileext = ".idf"), path, copy = TRUE)) + expect_true(file.exists(file.path(dir, basename(f)))) + expect_equal(l$value[field_id == 7074, value_chr], basename(f)) - unlink(file.path(dirname(example()), basename(f)), force = TRUE) + unlink(file.path(dir, basename(f)), force = TRUE) }) # }}} diff --git a/tests/testthat/test-run.R b/tests/testthat/test-run.R index 6dfd75fea..aa7614e28 100644 --- a/tests/testthat/test-run.R +++ b/tests/testthat/test-run.R @@ -40,7 +40,7 @@ test_that("run_idf()", { d <- tempfile() res <- run_idf(path_idf, NULL, output_dir = d, echo = FALSE) res$output_dir - }, d) + }, normalizePath(d, mustWork = FALSE)) # can run simulation with weather expect_silent(res <- run_idf(path_idf, path_epw, output_dir = tempdir(), echo = FALSE)) @@ -51,10 +51,10 @@ test_that("run_idf()", { expect_equal(res$exit_status, 0L) expect_is(res$start_time, "POSIXct") expect_is(res$end_time, "POSIXct") - expect_equal(res$output_dir, tempdir()) + expect_equal(res$output_dir, normalizePath(tempdir(), mustWork = FALSE)) expect_equal(res$energyplus, normalizePath(file.path(eplus_config(8.8)$dir, eplus_config(8.8)$exe), mustWork = TRUE)) expect_is(res$stdout, "character") - expect_null(res$stderr) + expect_true("stderr" %in% names(res)) expect_is(res$process, "process") expect_true(file.exists(file.path(tempdir(), basename(res$idf)))) expect_true(file.exists(file.path(tempdir(), basename(res$epw)))) @@ -67,7 +67,7 @@ test_that("run_idf()", { expect_null(res$exit_status) expect_is(res$start_time, "POSIXct") expect_null(res$end_time) - expect_equal(res$output_dir, tempdir()) + expect_equal(res$output_dir, normalizePath(tempdir(), mustWork = FALSE)) expect_equal(res$energyplus, normalizePath(file.path(eplus_config(8.8)$dir, eplus_config(8.8)$exe), mustWork = TRUE)) expect_null(res$stdout) expect_null(res$stderr) @@ -94,7 +94,7 @@ test_that("run_multi()", { # can stop if both design and annual is TRUE expect_error(run_multi(path_idf, NULL, annual = TRUE, design_day = TRUE), "both design-day-only", class = "eplusr_error_both_ddy_annual") # can stop if model does not exist - expect_error(run_multi("", NULL), "No such file or directory") + expect_error(run_multi(tempfile(), NULL)) # can stop if model does not contain version expect_error({ f <- tempfile(fileext = ".idf") @@ -119,13 +119,13 @@ test_that("run_multi()", { "stdout", "stderr")) expect_equal(res$index, 1:2) expect_equal(res$status, rep("failed", 2)) - expect_equal(res$idf, rep(path_idf, 2)) + expect_equal(res$idf, rep(normalizePath(path_idf), 2)) expect_equal(res$epw, rep(NA_character_, 2)) expect_equal(res$version, rep("8.8.0", 2)) expect_equal(res$exit_status > 0, rep(TRUE, 2)) expect_is(res$start_time, "POSIXct") expect_is(res$end_time, "POSIXct") - expect_equal(res$output_dir, c(file.path(tempdir(), "a"), file.path(tempdir(), "b"))) + expect_equal(res$output_dir, normalizePath(c(file.path(tempdir(), "a"), file.path(tempdir(), "b")), mustWork = FALSE)) expect_equal(res$energyplus, rep(normalizePath(file.path(eplus_config(8.8)$dir, eplus_config(8.8)$exe), mustWork = TRUE), 2L)) checkmate::expect_list(res$stdout, "character") checkmate::expect_list(res$stderr, "character") @@ -140,13 +140,13 @@ test_that("run_multi()", { "stdout", "stderr")) expect_equal(res$index, 1:2) expect_equal(res$status, rep("failed", 2)) - expect_equal(res$idf, rep(path_idf, 2)) + expect_equal(res$idf, rep(normalizePath(path_idf, mustWork = FALSE), 2)) expect_equal(res$epw, rep(NA_character_, 2)) expect_equal(res$version, rep("8.8.0", 2)) expect_equal(res$exit_status > 0, rep(TRUE, 2)) expect_is(res$start_time, "POSIXct") expect_is(res$end_time, "POSIXct") - expect_equal(res$output_dir, c(file.path(tempdir(), "a"), file.path(tempdir(), "b"))) + expect_equal(res$output_dir, normalizePath(c(file.path(tempdir(), "a"), file.path(tempdir(), "b")), mustWork = FALSE)) expect_equal(res$energyplus, rep(normalizePath(file.path(eplus_config(8.8)$dir, eplus_config(8.8)$exe), mustWork = TRUE), 2L)) checkmate::expect_list(res$stdout, "character") checkmate::expect_list(res$stderr, "character") diff --git a/tests/testthat/test-transition.R b/tests/testthat/test-transition.R index 060e9806f..e69b5a8ca 100644 --- a/tests/testthat/test-transition.R +++ b/tests/testthat/test-transition.R @@ -1368,9 +1368,8 @@ test_that("Transition v8.9 --> v9.0", { "GlazedDoor" = list("GD"), "RunPeriod:CustomRange" = list("RP1", 1, 1, 2020, 1, 2, 2020, "UseWeatherFile"), "RunPeriod" = list("RP2", 1, 1, 1, 2, "UseWeatherFile", ..12 = 3, ..14 = 2020), - "RunPeriod" = list("RP3", 1, 1, 1, 2, "UseWeatherFile", ..12 = 3), - "RunPeriod" = list("RP4", 1, 1, 1, 2, "Monday", ..12 = 2), - "RunPeriod" = list("RP5", 1, 1, 1, 2, "Sunday", ..12 = 2), + "RunPeriod" = list("RP3", 1, 1, 1, 2, "Monday", ..12 = 2), + "RunPeriod" = list("RP4", 1, 1, 1, 2, "Sunday", ..12 = 2), "Table:OneIndependentVariable" = list("Table", "Exponent"), "WindowMaterial:ComplexShade" = list("Mat", "Venetian"), "FenestrationSurface:Detailed" = list("Fene", "Window", "ConstNoShade", "Surf", ..7 = "Ctrl"), @@ -1384,7 +1383,7 @@ test_that("Transition v8.9 --> v9.0", { ) ) - expect_is(idfVU <- version_updater(idfOri, to), "Idf") + expect_is(idfVU <- version_updater(idfOri, to, dir = "C:/Users/hongy/Desktop/"), "Idf") expect_warning(idfTR <- transition(idfOri, to), "UseWeatherFile") expect_equal( @@ -1428,10 +1427,6 @@ test_that("Transition v8.9 --> v9.0", { idfVU$"RunPeriod"$RP4$value(1:13), idfTR$"RunPeriod"$RP4$value() ) - expect_equal( - idfVU$"RunPeriod"$RP5$value(1:13), - idfTR$"RunPeriod"$RP5$value() - ) expect_equal( idfVU$"Table:OneIndependentVariable"[[1]]$value(1:14), From 29758e8175640b2dbc553919540a7629396f29da Mon Sep 17 00:00:00 2001 From: Hongyuan Jia Date: Sun, 26 Jul 2020 22:53:12 +0800 Subject: [PATCH 33/43] [fix] Fix tests --- tests/testthat/test-assert.R | 2 +- tests/testthat/test-epw.R | 2 ++ 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/tests/testthat/test-assert.R b/tests/testthat/test-assert.R index 3a492d36c..0581887cd 100644 --- a/tests/testthat/test-assert.R +++ b/tests/testthat/test-assert.R @@ -32,7 +32,7 @@ test_that("Assertion functions", { }) expect_false(is_idd(1)) - expect_true(is_idd(use_idd(8.8))) + expect_true(is_idd(use_idd(8.8, download = "auto"))) expect_false(is_idf(1)) expect_true(is_idf(read_idf(example()))) diff --git a/tests/testthat/test-epw.R b/tests/testthat/test-epw.R index 9fd2b27de..bc4a32f67 100644 --- a/tests/testthat/test-epw.R +++ b/tests/testthat/test-epw.R @@ -428,6 +428,8 @@ test_that("Data Setter", { # CLONE {{{ test_that("$clone()", { + skip_on_cran() + if (!is_avail_eplus(8.8)) install_eplus(8.8) path_epw <- file.path(eplus_config(8.8)$dir, "WeatherData", "USA_CA_San.Francisco.Intl.AP.724940_TMY3.epw") expect_is(epw1 <- read_epw(path_epw), "Epw") From a67b3fe1ec51a3b28a80aa3d9d49e46da4f4f4bf Mon Sep 17 00:00:00 2001 From: Hongyuan Jia Date: Sun, 26 Jul 2020 23:13:55 +0800 Subject: [PATCH 34/43] [fix] Fix tests --- tests/testthat/test-epw.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/testthat/test-epw.R b/tests/testthat/test-epw.R index bc4a32f67..697698f61 100644 --- a/tests/testthat/test-epw.R +++ b/tests/testthat/test-epw.R @@ -296,7 +296,7 @@ test_that("Data Tagger", { rad <- epw$data()$direct_normal_radiation } ) - expect_equal(units(rad)$numerator, c("W", "h")) + expect_true(all(units(rad)$numerator %in% c("W", "h"))) expect_equal(units(rad)$denominator, c("m", "m")) expect_message(with_option(list(verbose_info = TRUE), epw$add_unit()), "already") From 07675910df2ef8bfddbe523f31dd5b4fe3ab28be Mon Sep 17 00:00:00 2001 From: Hongyuan Jia Date: Sun, 26 Jul 2020 23:42:22 +0800 Subject: [PATCH 35/43] [fix] Make sure 'key_value' and 'name' matching is case-insensitive --- R/impl-sql.R | 20 +++++++++++++++----- 1 file changed, 15 insertions(+), 5 deletions(-) diff --git a/R/impl-sql.R b/R/impl-sql.R index b4836aae5..c180700c2 100644 --- a/R/impl-sql.R +++ b/R/impl-sql.R @@ -101,6 +101,10 @@ get_sql_report_data <- function (sql, key_value = NULL, name = NULL, year = NULL environment_name = NULL) { # report data dictionary {{{ rpvar_dict <- read_sql_table(sql, "ReportDataDictionary") + # ignore case + set(rpvar_dict, NULL, c("key_value_lower", "name_lower"), + list(stri_trans_tolower(rpvar_dict$key_value), stri_trans_tolower(rpvar_dict$name)) + ) subset_rpvar <- FALSE if (!is.null(key_value)) { subset_rpvar <- TRUE @@ -108,20 +112,25 @@ get_sql_report_data <- function (sql, key_value = NULL, name = NULL, year = NULL assert_names(names(key_value), must.include = c("key_value", "name")) if (ncol(key_value) > 2) set(key_value, NULL, setdiff(names(key_value), c("key_value", "name")), NULL) kv <- unique(key_value) - rpvar_dict <- rpvar_dict[kv, on = c("key_value", "name"), nomatch = NULL] + set(kv, NULL, c("key_value_lower", "name_lower"), + list(stri_trans_tolower(kv$key_value), stri_trans_tolower(kv$name)) + ) + rpvar_dict <- rpvar_dict[kv, on = c("key_value_lower", "name_lower"), nomatch = NULL] + set(kv, NULL, c("key_value_lower", "name_lower"), NULL) } else { assert_character(key_value, any.missing = FALSE) - KEY_VALUE <- key_value - rpvar_dict <- rpvar_dict[J(KEY_VALUE), on = "key_value", nomatch = NULL] + KEY_VALUE <- stri_trans_tolower(key_value) + rpvar_dict <- rpvar_dict[J(KEY_VALUE), on = "key_value_lower", nomatch = NULL] } } if (!is.null(name)) { subset_rpvar <- TRUE assert_character(name, any.missing = FALSE) - NAME <- name - rpvar_dict <- rpvar_dict[J(NAME), on = "name"] + NAME <- stri_trans_tolower(name) + rpvar_dict <- rpvar_dict[J(NAME), on = "name_lower"] } + set(rpvar_dict, NULL, c("key_value_lower", "name_lower"), NULL) # }}} # environment periods {{{ @@ -322,6 +331,7 @@ get_sql_report_data <- function (sql, key_value = NULL, name = NULL, year = NULL } # }}} + browser() res <- time[rp_data, on = "time_index", nomatch = NULL][rpvar_dict, on = "report_data_dictionary_index", nomatch = NULL] cols <- c("datetime", "month", "day", "hour", "minute", "dst", "interval", "simulation_days", "day_type", "environment_name", From 3fb11eb84ee6280dfa9c1be63f3ccc264df2898b Mon Sep 17 00:00:00 2001 From: Hongyuan Jia Date: Sun, 26 Jul 2020 23:43:15 +0800 Subject: [PATCH 36/43] [fix] Fix transition processing when `\min-fields` has been increased --- R/transition.R | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/R/transition.R b/R/transition.R index c300ca643..a0ea4ed7a 100644 --- a/R/transition.R +++ b/R/transition.R @@ -2985,7 +2985,6 @@ trans_preprocess <- function (idf, version, class = NULL) { "required_field", "src_enum", "type_enum" ) ) - set(val, NULL, "defaulted", TRUE) # assign default values val <- assign_idf_value_default(priv$idd_env(), priv$idf_env(), val) @@ -2998,7 +2997,14 @@ trans_preprocess <- function (idf, version, class = NULL) { # merge data idf_env <- priv$idf_env() idf_env$value <- append_dt(idf_env$value, val, "value_id") - idf_env$reference <- without_checking(update_value_reference(priv$idd_env(), priv$idf_env(), obj, val)) + + # 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 <- get_value_reference_map(idd_env, idf_env$value, idf_env$value) + set(idf_env$value, NULL, c("src_enum", "class_id", "class_name"), NULL) + idf_env$reference <- ref } } From d67fd00e2374de98cf3a86a0ac3d1889e080f85b Mon Sep 17 00:00:00 2001 From: Hongyuan Jia Date: Sun, 26 Jul 2020 23:43:41 +0800 Subject: [PATCH 37/43] [fix] Remove browser --- R/impl-sql.R | 1 - 1 file changed, 1 deletion(-) diff --git a/R/impl-sql.R b/R/impl-sql.R index c180700c2..bfbd57e9e 100644 --- a/R/impl-sql.R +++ b/R/impl-sql.R @@ -331,7 +331,6 @@ get_sql_report_data <- function (sql, key_value = NULL, name = NULL, year = NULL } # }}} - browser() res <- time[rp_data, on = "time_index", nomatch = NULL][rpvar_dict, on = "report_data_dictionary_index", nomatch = NULL] cols <- c("datetime", "month", "day", "hour", "minute", "dst", "interval", "simulation_days", "day_type", "environment_name", From 8a1029c4a646713a16c7246c241bb9a953c79b55 Mon Sep 17 00:00:00 2001 From: Hongyuan Jia Date: Sun, 26 Jul 2020 23:56:55 +0800 Subject: [PATCH 38/43] [fix] Fix day type matching when extracting SQL report data --- R/impl-sql.R | 14 +++++++++----- 1 file changed, 9 insertions(+), 5 deletions(-) diff --git a/R/impl-sql.R b/R/impl-sql.R index bfbd57e9e..3852c785c 100644 --- a/R/impl-sql.R +++ b/R/impl-sql.R @@ -146,6 +146,14 @@ get_sql_report_data <- function (sql, key_value = NULL, name = NULL, year = NULL set(time, NULL, c("warmup_flag", "interval_type"), NULL) setnames(time, toupper(names(time))) subset_time <- FALSE + # store day of week for the first simulation day + if (is.null(year) && !"year" %chin% names(time)) { + # get wday of first simulation day per environment + w <- time[SIMULATION_DAYS == 1L & !is.na(DAY_TYPE), .SD[1L], + .SDcols = c("MONTH", "DAY", "DAY_TYPE", "ENVIRONMENT_PERIOD_INDEX"), + by = "ENVIRONMENT_PERIOD_INDEX" + ][!J(c("WinterDesignDay", "SummerDesignDay")), on = "DAY_TYPE"] + } if (!is.null(month)) { subset_time <- TRUE assert_integerish(month, lower = 1L, upper = 12L, any.missing = FALSE) @@ -236,11 +244,7 @@ get_sql_report_data <- function (sql, key_value = NULL, name = NULL, year = NULL if ("year" %in% names(time)) { time[J(0L), on = "year", year := NA_integer_] } else { - # get wday of first simulation day per environment - w <- time[simulation_days == 1L & !is.na(day_type), .SD[1L], - .SDcols = c("month", "day", "day_type", "environment_period_index"), - by = "environment_period_index" - ][!J(c("WinterDesignDay", "SummerDesignDay")), on = "day_type"] + setnames(w, tolower(names(w))) # in case there is no valid day type if (!nrow(w)) { From b5a417d5e5a40b81612764eb01b1c479363f6610 Mon Sep 17 00:00:00 2001 From: Hongyuan Jia Date: Mon, 27 Jul 2020 00:00:52 +0800 Subject: [PATCH 39/43] [docs] Update README --- README.md | 33 +++++++++++++++++---------------- 1 file changed, 17 insertions(+), 16 deletions(-) diff --git a/README.md b/README.md index 5c47dab3a..5e57fd756 100644 --- a/README.md +++ b/README.md @@ -133,7 +133,7 @@ library(eplusr) # parse IDD idd <- use_idd(8.8, download = "auto") #> IDD v8.8.0 has not been parsed before. -#> Try to locate `Energy+.idd` in EnergyPlus v8.8.0 installation folder '/usr/local/EnergyPlus-8-8-0'. +#> Try to locate 'Energy+.idd' in EnergyPlus v8.8.0 installation folder '/usr/local/EnergyPlus-8-8-0'. #> IDD file found: '/home/hongyuanjia/.local/EnergyPlus-8-8-0/Energy+.idd'. #> Start parsing... #> Parsing completed. @@ -144,7 +144,7 @@ idf <- read_idf(system.file("extdata/1ZoneUncontrolled.idf", package = "eplusr") # print idf idf #> ── EnergPlus Input Data File ─────────────────────────────────────────────────── -#> * Path: '/tmp/RtmpiYeLsf/temp_libpathe5d7f4b4df7/eplusr/extdata/1ZoneUncon... +#> * Path: '/tmp/Rtmps8kJCk/temp_libpath16533d1aded9/eplusr/extdata/1ZoneUnco... #> * Version: '8.8.0' #> #> Group: @@ -192,13 +192,14 @@ idf$object_relation("R13LAYER", "all") #> Target(s) does not refer to any other field. #> #> ── Referred by Others ────────────────────────────────────────────────────────── -#> Object [ID:12] -#> └─ 1: "R13LAYER"; !- Name -#> ^~~~~~~~~~~~~~~~~~~~~~~~~ -#> └─ Class: -#> └─ Object [ID:15] -#> └─ 2: "R13LAYER"; !- Outside Layer -#> +#> Class: +#> └─ Object [ID:12] +#> └─ 1: "R13LAYER"; !- Name +#> ^~~~~~~~~~~~~~~~~~~~~~~~~ +#> └─ Class: +#> └─ Object [ID:15] +#> └─ 2: "R13LAYER"; !- Outside Layer +#> #> #> ── Node Relation ─────────────────────────────────────────────────────────────── #> Target(s) has no node or their nodes have no reference to other object. @@ -283,7 +284,7 @@ epw #> [Elevation]: 2m above see level #> [Data Src ]: TMY3 #> [WMO Stat ]: 724940 -#> [Leap Year]: FALSE +#> [Leap Year]: No #> [Interval ]: 60 mins #> #> ── Data Periods ──────────────────────────────────────────────────────────────── @@ -346,7 +347,7 @@ idf$save(file.path(tempdir(), "model.idf"), overwrite = TRUE) #> 4: 2017-01-01 04:00:00 1999 1 1 4 0 #> 5: 2017-01-01 05:00:00 1999 1 1 5 0 #> 6: 2017-01-01 06:00:00 1999 1 1 6 0 -#> datasource dry_bulb_temperature +#> data_source dry_bulb_temperature #> 1: ?9?9?9?9E0?9?9?9?9?9?9?9?9?9?9?9?9?9?9?9*9*9?9?9?9 7.2 #> 2: ?9?9?9?9E0?9?9?9?9?9?9?9?9?9?9?9?9?9?9?9*9*9?9?9?9 7.2 #> 3: ?9?9?9?9E0?9?9?9?9?9?9?9?9?9?9?9?9?9?9?9*9*9?9?9?9 6.7 @@ -373,16 +374,16 @@ idf$save(file.path(tempdir(), "model.idf"), overwrite = TRUE) # a date time column added with correct start day of week type epw$period()$start_day_of_week -#> [1] 7 +#> [1] "Sunday" weekdays(weather$datetime) #> [1] "Sunday" "Sunday" "Sunday" "Sunday" "Sunday" "Sunday" # run simulation job <- idf$run(epw) -#> Adding an object in class `Output:SQLite` and setting its `Option Type` to `SimpleAndTabular` in order to create SQLite output file. -#> Replace the existing IDF located at /tmp/RtmpiYeLsf/model.idf. +#> Adding an object in class 'Output:SQLite' and setting its 'Option Type' to 'SimpleAndTabular' in order to create SQLite output file. +#> Replace the existing IDF located at /tmp/Rtmps8kJCk/model.idf. #> EnergyPlus Starting -#> EnergyPlus, Version 8.8.0-7c3bbe4830, YMD=2020.03.15 04:31 +#> EnergyPlus, Version 8.8.0-7c3bbe4830, YMD=2020.07.26 23:58 #> Processing Data Dictionary #> Processing Input File #> Initializing Simulation @@ -417,7 +418,7 @@ job <- idf$run(epw) job$errors() #> ══ EnergyPlus Error File ═══════════════════════════════════════════════════════ #> * EnergyPlus version: 8.8.0 (7c3bbe4830) -#> * Simulation started: 2020-03-15 04:31:00 +#> * Simulation started: 2020-07-26 23:58:00 #> * Terminated: FALSE #> * Successful: TRUE #> * Warning[W]: 2 From 5d7859b938caa62abfdd87a740b4babf16e71bae Mon Sep 17 00:00:00 2001 From: Hongyuan Jia Date: Mon, 27 Jul 2020 00:01:25 +0800 Subject: [PATCH 40/43] [docs] Update NEWS --- NEWS.md | 26 ++++++++++++++++---------- 1 file changed, 16 insertions(+), 10 deletions(-) diff --git a/NEWS.md b/NEWS.md index 01e70919e..094502dd4 100644 --- a/NEWS.md +++ b/NEWS.md @@ -2,6 +2,17 @@ ## New features +* `Idf$add()` and `Idf$set()` have new features: + + ```r + # refer to field using '..' + idf$add(Material = list(..1 = "mat", ..7 = 0.95)) + idf$set(mat = list(..6 = 0.5)) + + # using vector field values + idf$add(Material := list(..1 = sprintf("mat%i", 1:10))) + idf$set(c(sprintf("mat%i", 1:10)) := list(..6 = runif(10))) + ``` * `Idf$to_table()` gains a new parameter `force`. The default value is `FALSE`. If `TRUE`, you can convert object data from any classes into a wide data.table. This may be useful when you know that target classes have the exact same @@ -112,19 +123,12 @@ value of field `Component 1 Object Type` is `Coil:Heating:Water`, all objects in `Coil:Heating:Water` will be treated as referenced by that field. This is the most aggressive option. -* `read_epw()` will proceed parsing if type error occurs for non-important - headers, including `LOCATION`, `DESIGN CONDITIONS`, `TYPICAL/EXTREME PERIODS` - and `GROUND TEMPERATURES` (#236). These headers are not directly used in any - other method of `Epw` class. Some EPWs from sources other than energyplus.net - sometimes fail to give all valid values for those headers. Now `read_epw()` - will return all failed-to-parse values as `NA`s. All parsing warnings can be - shown by setting `warning` in `read_epw()` to `TRUE`. For `HOLIDAYS/DAYLIGHT - SAVINGS` and `DATA PERIODS`, `read_epw()` will still give an error if any - parsing errors are found. This is because the values of those 2 headers are - used to parsing the actual weather data. +* `read_epw()` will proceed parsing for non-standard EPW header format (#236). * Now `EplusSql$report_data()` will set the year values of day type `SummerDesignDay` and `WinterDesignDay` to current year and the `day_type` value will be left unchanged (#258). +* Now `read_idf()` will always make sure all necessary fields are added during + parsing (#267). ## Minor changes @@ -136,6 +140,8 @@ simulations * `format.Idd()` now returns a single line string in format ` Date: Mon, 27 Jul 2020 00:21:28 +0800 Subject: [PATCH 41/43] [fix] Fix nocov pair --- R/units.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/units.R b/R/units.R index d6d71ed1a..3836ae225 100644 --- a/R/units.R +++ b/R/units.R @@ -181,5 +181,5 @@ FIELD_UNIT_TABLE <- fread( W/((m3/s)-Pa) W/((m3/s)*Pa) W/((ft3/min)-inH2O) W/((ft^3/min)*inH2O) " ) -# nocov start +# nocov end # }}} From 39a6b5eeb6f96f1e5c0ca37ff18df46934ec1408 Mon Sep 17 00:00:00 2001 From: Hongyuan Jia Date: Mon, 27 Jul 2020 00:28:51 +0800 Subject: [PATCH 42/43] [meta] Depends on data.table v0.12.4 --- DESCRIPTION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index e5c193d62..f97f1633a 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -23,7 +23,7 @@ Imports: checkmate, cli (>= 1.1.0), crayon, - data.table (>= 1.13.0), + data.table (>= 1.12.4), lubridate, methods, processx (>= 3.2.0), From 70770e0fc4ee141072af29efd71e145fa6cf35e3 Mon Sep 17 00:00:00 2001 From: Hongyuan Jia Date: Mon, 27 Jul 2020 00:33:01 +0800 Subject: [PATCH 43/43] [fix] Fix checks --- R/constants.R | 2 +- R/transition.R | 1 + 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/R/constants.R b/R/constants.R index 357f0a0e4..08bcf742c 100644 --- a/R/constants.R +++ b/R/constants.R @@ -115,7 +115,7 @@ utils::globalVariables(c( "update_value_reference", "upper_incbounds", "value", "value_chr", "value_count", "value_id", "value_lower", "value_num", "value_type", "variable", "weather", "wind_exposure", "wind_exposure_lower", "wmo_number", - "x", "y", "z", "zone_name" + "x", "y", "z", "zone_name", "DAY_TYPE", "SIMULATION_DAYS" )) # }}} # nocov end diff --git a/R/transition.R b/R/transition.R index a0ea4ed7a..a5f09e079 100644 --- a/R/transition.R +++ b/R/transition.R @@ -2995,6 +2995,7 @@ trans_preprocess <- function (idf, version, class = NULL) { set(val, NULL, "value_id", new_id(priv$idf_env()$value, "value_id", nrow(val))) # merge data + idd_env <- priv$idd_env() idf_env <- priv$idf_env() idf_env$value <- append_dt(idf_env$value, val, "value_id")