diff --git a/DESCRIPTION b/DESCRIPTION index 81dfb58eb..f97f1633a 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -20,9 +20,10 @@ Depends: R (>= 3.2.0) Imports: callr (>= 2.0.4), + checkmate, cli (>= 1.1.0), crayon, - data.table (>= 1.9.8), + data.table (>= 1.12.4), lubridate, methods, processx (>= 3.2.0), @@ -38,41 +39,42 @@ Suggests: pkgdown, rgl, rmarkdown, - testthat -VignetteBuilder: + testthat (>= 2.1.0) +VignetteBuilder: knitr 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: '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' - 'idd_object.R' - 'impl-idf.R' - 'idf.R' + 'iddobj.R' 'impl-idfobj.R' - 'idf_object.R' + 'idfobj.R' 'impl-iddobj.R' 'impl-sql.R' 'install.R' 'job.R' + 'options.R' 'param.R' 'rdd.R' 'reload.R' diff --git a/NAMESPACE b/NAMESPACE index 6345058de..66c7ac766 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) @@ -49,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) @@ -89,22 +89,45 @@ 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_table) +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) @@ -117,20 +140,31 @@ 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(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) @@ -144,11 +178,54 @@ 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_int) +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) importFrom(cli,cat_line) importFrom(cli,cat_rule) +importFrom(cli,console_width) importFrom(cli,rule) importFrom(cli,symbol) importFrom(crayon,bold) @@ -174,9 +251,11 @@ 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) +importFrom(data.table,transpose) importFrom(grDevices,rgb) importFrom(lubridate,"year<-") importFrom(lubridate,as_datetime) @@ -213,6 +292,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/NEWS.md b/NEWS.md index 73fb75a3f..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 @@ -60,6 +71,8 @@ - `"CustomDay"`: CustomDay1 and CustomDay2 - `"SpecialDay"`: Equivalent to `"DesignDay"` plus `"CustomDay"` - `"NormalDay"`: Equivalent to `"Weekday"` and `"Weekend"` plus `"Holiday"` +* Some internal functions have been exported. They are mainly useful for + developers to handle internal IDD and IDF data more efficiently. ## Major changes @@ -110,25 +123,25 @@ 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 * `EplusJob`, `EplusGroupJob` and `ParametricJob` will not parse input EPW files, but only validate their existences and store the paths (#215) * `period` parameter in `EplusSql$report_data()` now works as expected (#259). +* `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 + `= range$minimum & x < range$maximum + } else { + x > range$minimum & x <= range$maximum + } + } +} +# }}} + +# 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 +# }}} + +# is_epwdate {{{ +is_epwdate <- function (x) { + length(x) == 1L && !is.na(epw_date(x)) +} +# }}} + +# 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/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/constants.R b/R/constants.R index e6ed1c818..08bcf742c 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", + "..", "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", + "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", "DAY_TYPE", "SIMULATION_DAYS" )) # }}} # nocov end 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/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/epw.R b/R/epw.R index 2f2820e3c..dbeadf474 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.", "epw_not_local") } 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/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..3b7df41af 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,35 @@ 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))) + choices <- c("group", "class", "object", "field", "value") + assert_subset(component, choices, FALSE) + component <- choices[choices %in% component] # 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 +796,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 +860,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 +887,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 +895,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 +915,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 +947,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 +986,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 +1065,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 +1084,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 +1102,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..2e57bdd35 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,15 +789,15 @@ 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( + 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) @@ -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(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" ) @@ -1167,16 +1165,15 @@ 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("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,19 +1260,19 @@ 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) { - 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("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") - )) + ), "job_error") } } @@ -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/idd.R b/R/idd.R index 91053868f..c156abd10 100644 --- a/R/idd.R +++ b/R/idd.R @@ -1,4 +1,5 @@ #' @importFrom R6 R6Class +#' @importFrom checkmate assert_vector assert_string assert_scalar #' @include impl-idd.R NULL @@ -88,6 +89,7 @@ Idd <- R6::R6Class(classname = "Idd", cloneable = FALSE, lock_objects = FALSE, #' 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) @@ -684,8 +686,16 @@ Idd <- R6::R6Class(classname = "Idd", cloneable = FALSE, lock_objects = FALSE, m_version = NULL, m_build = NULL, m_idd_env = NULL, - m_log = NULL + m_log = NULL, # }}} + + idd_env = function () { + private$m_idd_env + }, + + log_env = function () { + private$m_log + } ) ) # }}} @@ -806,7 +816,7 @@ idd_objects <- function (self, private, class) { # idd_object_relation {{{ idd_object_relation <- function (self, private, which, direction = c("all", "ref_to", "ref_by"), class = NULL, group = NULL, depth = 0L) { - assert(is_scalar(which)) + assert_scalar(which) direction <- match.arg(direction) cls <- get_idd_class(private$m_idd_env, which) @@ -820,7 +830,7 @@ idd_object_relation <- function (self, private, which, direction = c("all", "ref # idd_objects_in_relation {{{ idd_objects_in_relation <- function (self, private, which, direction = c("ref_to", "ref_by"), class = NULL, group = NULL, depth = 0L) { - assert(is_scalar(which)) + assert_scalar(which) direction <- match.arg(direction) rel <- get_idd_relation(private$m_idd_env, which, depth = depth, direction = direction, class = class, group = group, keep_all = TRUE) @@ -854,7 +864,7 @@ idd_objects_in_relation <- function (self, private, which, direction = c("ref_to # }}} # idd_objects_in_group {{{ idd_objects_in_group <- function (self, private, group) { - assert(is_string(group)) + assert_string(group) grp_id <- idd_group_index(self, private, group) @@ -886,28 +896,12 @@ idd_print <- function (self, private) { } # }}} -#' @export -# [.Idd {{{ -'[.Idd' <- function(x, i) { - if (!is.character(x)) return(NextMethod()) - - self <- ._get_self(x) - private <- ._get_private(x) - - if (any(i %chin% private$m_idd_env$class$class_name)) { - .subset2(x, "objects")(i) - } else { - NextMethod() - } -} -# }}} - #' @export # [[.Idd {{{ `[[.Idd` <- function (x, i) { if (i %chin% ls(x)) return(NextMethod()) - private <- ._get_private(x) + private <- get_priv_env(x) cls_id <- chmatch(i, private$m_idd_env$class$class_name) @@ -924,9 +918,9 @@ idd_print <- function (self, private) { `$.Idd` <- function (x, i) { if (i %chin% ls(x)) return(NextMethod()) - private <- ._get_private(x) + 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()) @@ -943,17 +937,33 @@ 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, ...) { - paste0( - c(cli::rule("EnergyPlus Input Data Dictionary"), - paste0("Version", ": ", x$version()), - paste0("Build", ": ", x$build()), - paste0("Total Class", ": ", length(x$class_index())) - ), - collapse = "\n" - ) + n <- length(x$class_index()) + + if (is.na(x$build())) { + sprintf("", x$version(), n, + if (n <= 1L) "class" else "classes" + ) + } else { + sprintf("", x$version(), x$build(), + n, if (n <= 1L) "class" else "classes" + ) + } } # }}} @@ -961,7 +971,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 +1077,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 +1106,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 +1126,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 +1140,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 +1156,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 +1178,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 +1201,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 +1233,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 +1267,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 +1279,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) @@ -1297,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), "." ) @@ -1326,25 +1321,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 +1345,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/R/idd_object.R b/R/iddobj.R similarity index 96% rename from R/idd_object.R rename to R/iddobj.R index a71207331..5dc2635f6 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 } # }}} @@ -1599,7 +1594,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) @@ -1616,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] @@ -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/R/idf.R b/R/idf.R index 762de25f6..5e4e0e2ab 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{ @@ -2133,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. @@ -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.", "idf_not_local") } 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() } @@ -3424,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 { - invisible(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.") + 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 } added @@ -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 e237b491f..a56f2e5b3 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.") + 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.") ) } 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(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()$object[obj, on = "object_id", `:=`(comment = i.comment)] self } @@ -1648,15 +1613,13 @@ 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 + # 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 ) - 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 +1673,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 +1717,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()) @@ -1795,8 +1758,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], @@ -1955,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{ @@ -2002,10 +1963,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] @@ -2017,7 +1978,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() @@ -2030,17 +1991,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() @@ -2051,13 +2012,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] @@ -2065,8 +2026,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) @@ -2083,22 +2046,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) @@ -2115,10 +2081,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-epw.R b/R/impl-epw.R index 23f87ff6e..9cb01e5ac 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,590 @@ 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 <- 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.") } - # 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(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 <- !(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( + "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(num)) + set(dt_value, i, "value_chr", as.character(num)) + + # 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 +769,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 +792,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,27 +849,19 @@ 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 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) 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 +1084,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 +1186,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 +1213,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 +1223,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") + } - # 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) + fld <- get_idd_field(get_epw_idd_env(), EPW_CLASS$data, field, prop, underscore = TRUE) + + 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(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(get_epw_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(get_epw_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) - - if (missing(period)) { - period <- seq_len(n) - } else { - period <- get_epw_data_period(epw_header, 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(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" - ) - set(epw_header$period$period, period, "name", name) - } + mes <- invld[, paste0("Original: ", datetime, " --> New year: ", new_year)] - 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" - ) - ) - } - } + if (length(j) > 10L) mes <- c(mes, "...[truncated. First 10 are shown.]") - set(epw_header$period$period, period, "start_day_of_week", sdow) + abort(paste0("Invalid date introduced with input new start year (", start_year, ") and time zone (", tz, "):\n", + paste0(mes, collapse = "\n")), + "epw_data" + ) } - epw_header -} -# }}} + set(d, NULL, "datetime", datetime) -# 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 +1951,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 +2135,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 +2194,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 +2325,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 +2370,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 || (length(design) == 1L && is.null(unlist(design)))) 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 || (length(typical) == 1L && is.null(unlist(typical)))) 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 || (length(ground) == 1L && is.null(unlist(ground)))) 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 +2421,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 ec34c6d20..270bd68dd 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<-" @@ -11,10 +13,10 @@ NULL get_idd_group_index <- function (idd_env, group = NULL) { if (is.null(group)) return(idd_env$group$group_id) - assert(are_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("error_group_name", "group name", group) + if (anyNA(res)) abort_bad_key("group name", group) res } # }}} @@ -22,61 +24,63 @@ get_idd_group_index <- function (idd_env, group = NULL) { get_idd_group_name <- function (idd_env, group = NULL) { if (is.null(group)) return(idd_env$group$group_name) - assert(are_count(group)) + 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("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(fast_subset(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 <- fast_subset(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 + fast_subset(res, c("rleid", unique(c(cols, property)))) } # }}} # get_idd_class_field_num {{{ @@ -98,14 +102,15 @@ get_idd_class <- function (idd_env, class = NULL, property = NULL, underscore = # - The acceptable field number will be the field index of the last # field in the last extensible group. 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 +119,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 +149,44 @@ 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 +# 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 {{{ +#' 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. +#' @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 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,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_name(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 } # }}} @@ -185,32 +222,9 @@ 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. 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", @@ -239,9 +253,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 +269,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 +280,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 +362,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 +397,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." @@ -396,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 { @@ -420,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 {{{ @@ -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,55 @@ 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 +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 +673,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 +689,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 +729,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 +769,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,15 +810,35 @@ add_field_property <- function (idd_env, dt, property) { } # }}} +# UNIT CONVERSION # 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_names(dt_field, "value_id")) { + value_id <- dt_field$value_id + } 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 + 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")) - 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")) + + 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 } # }}} @@ -764,11 +850,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] @@ -883,13 +967,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) @@ -909,7 +992,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 @@ -934,16 +1017,16 @@ del_idd_extensible_group <- function (idd_env, class, num = NULL, strict = FALSE 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 { @@ -955,9 +1038,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) } } # }}} @@ -965,7 +1048,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") ] @@ -979,8 +1062,8 @@ 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(is_count(sep_each, TRUE)) + 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-iddobj.R b/R/impl-iddobj.R index 27f427432..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 @@ -54,7 +59,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) { @@ -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/R/impl-idf.R b/R/impl-idf.R index daa2d9b09..84557b099 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,17 +135,13 @@ 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") } # }}} } + setcolorder(obj, c("rleid", "class_id", "class_name", "object_id", "object_name", "object_name_lower", "comment")) obj } # }}} @@ -1072,9 +196,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) @@ -1084,10 +206,32 @@ 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) { - assert(component %in% c("id", "name", "class")) + assert_subset(component, c("id", "name", "class")) if (is.null(prefix)) { key_obj <- "Object" @@ -1107,7 +251,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 @@ -1135,60 +279,368 @@ get_object_info <- function (dt_object, component = c("id", "name", "class"), mes_nm[!stri_isempty(mes_nm)] <- paste0(" (", mes_nm[!stri_isempty(mes_nm)], ")") mes <- paste0(mes, mes_nm) } - # if name comes before ID + # if name comes before ID + } else { + # surround ID with parenthesis + mes <- paste0(mes_nm, "(", mes, ")") + } + } + + # If class is required + if (order_cls != 0L) { + # If none of ID or name is required + if (is.null(mes)) { + mes <- dt_object[, paste(key_cls, surround(class_name))] + } else { + set(dt_object, NULL, "mes_object", mes) + if (by_class) { + mes <- dt_object[, { + 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)) + }] + } + set(dt_object, NULL, "mes_object", NULL) + } + } else { + if (!is.null(mes)) { + mes <- paste0(key_obj, " ", mes) + } + } + + mes <- paste0(prefix, mes) + + if (numbered) { + if (has_names(dt_object, "rleid")) { + if (by_class) { + num <- paste0(" #", lpad(dt_object[, unique(rleid), by = class_name]$V1, "0"), "| ") + } else { + num <- paste0(" #", lpad(dt_object$rleid, "0"), "| ") + } + } else { + num <- paste0(" #", lpad(seq_along(mes), "0"), "| ") + } + mes <- paste0(num, mes) + } + + 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 <- 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))) { + 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 <- 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])) { + 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 { - # surround ID with parenthesis - mes <- paste0(mes_nm, "(", mes, ")") + 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")] + } + } } - } - # If class is required - 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))] - } 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])) - }, by = class_name]$V1 + 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 { - mes <- dt_object[, { - paste0(key_obj, mes_object, " in class ", surround(class_name)) + 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))) }] } - set(dt_object, NULL, "mes_object", NULL) - } - } else { - if (!is.null(mes)) { - mes <- paste0(key_obj, " ", mes) } + + 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) } - mes <- paste0(prefix, mes) + 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"))) +} +# }}} +# 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 (numbered) { - if (has_name(dt_object, "rleid")) { - if (by_class) { - num <- paste0(" #", lpad(dt_object[, unique(rleid), by = class_name]$V1, "0"), "| ") - } else { - num <- paste0(" #", lpad(dt_object$rleid, "0"), "| ") - } - } else { - num <- paste0(" #", lpad(seq_along(mes), "0"), "| ") - } - mes <- paste0(num, mes) + 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") + )) } - paste0(mes, collapse = collapse) + 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 {{{ -# 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) { @@ -1202,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) } @@ -1229,16 +684,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 +704,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 +732,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) { @@ -1291,1858 +752,2650 @@ 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 } # }}} +# 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) + + set(val, NULL, c("object_id", "object_name"), list(NA_integer_, NA_character_)) -# 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)] + setcolorder(val, c("rleid", "class_id", "class_name", + "object_id", "object_name", + "field_id", "field_index", "field_name", + "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) -# 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") + prop <- "type_enum" + if ("choice" %chin% type) prop <- c(prop, "choice") - is_valid_input <- function (x) is.null(x) || is_normal_list(x) + val <- get_idf_value(idd_env, idf_env, class, object, field, property = prop) - 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) + 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 (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) - } - } 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) - } + 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) } # }}} -# 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 - ) - } - # }}} - 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)]) +# 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(...) - m <- paste0(dot_string(invld, NULL), " --> Class: ", invld$class_name, collapse = "\n") - act <- switch(action, add = "added", insert = "inserted") + # 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", min.len = 1L) + 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)) - abort("error_add_multi_unique", - paste0("Unique object can only be ",act," once. Invalid input\n", m), - dot = dot, object = object - ) - } - # }}} - # try do del unique object {{{ - if (action == "del" && any(get_idf_object_num(idd_env, idf_env, uni$class_id) == 0L)) { + if (.keep_name) { + l_nm <- unlist(l_nm, FALSE, TRUE) + nm_nm <- names2(l_nm) + } else { + l_nm <- unlist(l_nm, FALSE, FALSE) + } - invld <- find_dot(dot, uni[get_idf_object_num(idd_env, idf_env, class_id) == 0L]) + obj_nm <- get_idf_object(idd_env, idf_env, object = l_nm, ignore_case = TRUE, property = .property) + setnames(obj_nm, "rleid", "object_rleid") - info <- get_object_info(invld, collapse = NULL) + if (.keep_name) set(obj_nm, NULL, "new_object_name", stri_trim_both(nm_nm)) + } - m <- paste0(dot_string(invld, NULL), " --> ", info, collapse = "\n") + if (!length(l_id)) { + obj_id <- data.table() + } else { + # in order to keep input order + rleid_id <- rep(rleid_id, each_length(l_id)) - abort("error_del_exist_unique", - paste0("Existing unique object can not be deleted. Invalid input\n", m), - dot = dot, object = object - ) - } - # }}} + 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)) } - # 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]]) + # 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") + if (!is.null(.property)) setcolorder(obj, setdiff(names(obj), .property)) + obj +} +# }}} +# parse_dots_value {{{ +#' @inherit 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", min.len = 1L) + + 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 + } - info <- get_object_info(invld, numbered = FALSE, collapse = NULL) + val <- eval(l[[i]], .env) - m <- paste0(dot_string(invld, NULL), " --> ", info, collapse = "\n") + # 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_del_required", - paste0("Deleting a required object is prohibited. 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") + } - # 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") + 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(paste0("error_", action, "_multi_time"), - paste0("Cannot modify same object multiple times. 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 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" - ) + 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 + ) - mes <- paste0("Please give new object names. Invalid input:\n", m) - abort(paste0("error_", action, "_no_new_name"), mes, data = invld) - } - # }}} + 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 + + # 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 + # '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") + } - # 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" - ) + # 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]]) %chin% c("c", ".")) { + li[[2L]][[1L]] <- as.name("c") + name <- eval(li[[2L]], .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)))) + } + # for '..(Cls) := list()' + } else if (as.character(li[[2L]][[1L]]) == "..") { + li[[2L]][[1L]] <- as.name("c") + 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 + set(dt_in, i, "lhs_sgl", TRUE) + } else { + abort("Assertion on 'Input' failed: LHS of ':=' must start with '.()', 'c()', or '..()'", "dots_ref_lhs") + } - 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) - } - # }}} + li <- li[[3L]] + set(dt_in, i, "is_ref", TRUE) + } + } - 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 + if (!evaluated) val <- eval(li, .env) + assert_list(val, c("character", "integer", "double", "null"), .var.name = "Input", + all.missing = .empty ) - } 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 empty list: 'list()' + if (identical(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." - ) + fld_nm <- names(val) + if (is.null(fld_nm)) { + fld_nm <- character(length(val)) } else { - t <- paste0("Failed to ",action," object(s).") + assert_character(fld_nm[!stri_isempty(fld_nm)], unique = TRUE, .var.name = "Field Name") } - abort("error_validity", paste0(t, "\n\n", m)) - } - TRUE -} -# }}} + # handle '.comment' + iscmt <- which(fld_nm == ".comment") + if (length(iscmt)) { + set(dt_in, i, "comment", list(val[iscmt])) -# 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) + val <- val[-iscmt] + fld_nm <- fld_nm[-iscmt] - # stop if cannot add objects in specified classes - assert_can_do(idd_env, idf_env, l$dot, obj, "dup") + # check if .comment only + if (identical(unname(val), list())) { + set(dt_in, i, "is_empty", TRUE) + next + } + } - # make sure rleid column as the unique id - set(obj, NULL, "rleid", rleid(obj$rleid, obj$object_rleid)) - set(obj, NULL, "object_rleid", NULL) + fld_idx <- rep(NA_integer_, length(fld_nm)) - # 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))) + # 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_ - # 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])] + set(dt_in, i, "field_name", list(fld_nm)) + set(dt_in, i, "field_index", list(fld_idx)) - assert_valid(idd_env, idf_env, obj, val, "dup") - # }}} + # check if NULL + isnull <- vlapply(val, is.null) - # 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) - ] + # make sure no NA and scalar if necessary + qassertr(val[!isnull], rules, .var.name = "Field Value") + + # separate character and numeric value + if (.scalar) { + val[isnull] <- list(NA_character_) + isnum <- vlapply(val, is.numeric) + + 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) + + set(dt_in, i, "value_chr", val_chr) + set(dt_in, i, "value_num", val_num) + + } else if (!.pair) { + val[isnull] <- list(NA_character_) + isnum <- vlapply(val, is.numeric) + + len <- each_length(val) + + # indicate if vector value input + if (any(len > 1L)) set(dt_in, i, "rhs_sgl", FALSE) - # 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)) + 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) + )] - 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) - ) + 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 = 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 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"`, +#' 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 <- 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"] + 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(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 <- 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 + 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 <- cls_obj[rleid %in% cls_in$rleid[cls_in$is_empty]] + cls_obj <- cls_obj[!rleid %in% cls_in$rleid[cls_in$is_empty]] - 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 <- cls_val[!rleid %in% cls_in$rleid[cls_in$is_empty]] + } - 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(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", "field_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 <- obj[rleid %in% obj$rleid[obj$is_empty]] + obj <- obj[!rleid %in% obj$rleid[obj$is_empty]] - 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 <- obj_val[rleid %in% obj$rleid] + } - # 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(...) - 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", min.len = 1L) - # 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 + ver <- standardize_ver(get_idf_value(idd_env, idf_env, "Version")$value_chr) + 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 = "")) + 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"] + 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")) + # 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] + } + # }}} + + # 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 + ) + ] + 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_] - 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(val) - - # 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") - - # remove empty fields - add_class_property(idd_env, val, c("min_fields", "num_extensible")) - if (!.empty) val <- remove_empty_fields(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 - } + obj <- rbindlist(list(obj_chr, obj_dt), use.names = TRUE) + val <- rbindlist(list(val_chr, val_dt), use.names = TRUE) - # 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") + # reset rleid + set(obj, NULL, "rleid", rleid(obj$rleid)) + set(val, NULL, "rleid", rleid(val$rleid)) - # if all inputs are duplications - if (!nrow(obj)) { - return(list(object = idf_env$object[0L], value = idf_env$value[0L], reference = idf_env$reference)) - } + # assign default value if necessary + if (.default) val <- assign_idf_value_default(idd_env, idf_env, val) - # validate - assert_valid(idd_env, idf_env, obj, val, action = "insert") + # 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[, .SD, .SDcols = names(idf_env$object)], - value = val[, .SD, .SDcols = names(idf_env$value)], - reference = update_value_reference(idd_env, idf_env, obj, val) - ) + 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")) +# 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 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. +#' +#' @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) - # 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"] + if (!is.null(class) && anyDuplicated(class)) { + abort("Class should not contain any duplication.") + } - # 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) + val <- get_idf_value(idd_env, idf_env, class)[ + grepl(pattern, value_chr, ignore.case = ignore.case, perl = perl, + fixed = fixed, useBytes = useBytes) + ] - # add rleid for validation and message printing - add_rleid(parsed$object) + # add object rleid + set(val, NULL, "rleid", rleid(val$object_id)) - # remove duplicated objects - if (unique) { - parsed <- remove_duplicated_objects(idd_env, idf_env, parsed$object, parsed$value) + # 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 = unique(val[, by = "rleid", object_id]$object_id)) } - # 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)) - } + if (!is.null(replacement)) { + assert_string(replacement) - # 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(parsed$value) + 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))) } - # 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) + # 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 = parsed$object[, .SD, .SDcols = names(idf_env$object)], - value = parsed$value[, .SD, .SDcols = names(idf_env$value)], - reference = parsed$reference - ) + list(object = obj, value = val) } # }}} -# load_idf_object {{{ -load_idf_object <- function (idd_env, idf_env, version, ..., .unique = TRUE, .default = TRUE, .empty = FALSE) { - l <- sep_definition_dots(..., .version = version) - 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")) +# 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. +#' @param level Validate level. Default: `eplusr_option("validate_level")`. +#' +#' @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 +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)) + + # stop if try to dup version + 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")), + "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") + } - # 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"]) - ) - ) - } - ) + 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) + + # 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")) + + # get new object ID + id_obj <- new_id(idf_env$object, "object_id", nrow(obj)) - set(l$value, NULL, c("class_id", "class_name", "has_name"), - list(cls$class_id, cls$class_name, cls$has_name) + # logging + 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) + verbose_info( + "New names of duplicated objects not given are automatically generated:\n", + paste0(id, name, collapse = "\n") ) + } - 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 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 + obj <- assign_new_id(idf_env, obj, "object") + add_joined_cols(obj, val, "rleid", "object_id") + + # assign new 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] + + # 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 + 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] + 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)) - # 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) + # remove original ids + 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 + # 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"] + set(idf_env$value, NULL, "type_enum", NULL) + ref <- rbindlist(list(ref, src)) + } + + 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 +#' +#' @inherit dup_idf_object +#' @param dt_value A [data.table::data.table()] that contains value data. +#' @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")`. +#' +#' @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_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") + } + # 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" ) } - # 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) - } - ) - - # reset rleid in fld_out - set(fld_out, NULL, c("rleid", "object_id"), obj_dt[fld_out$rleid, list(rleid, object_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" + ) - # remove unuseful column - set(fld_out, NULL, "field_in", NULL) + } + } - # 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")] + # assign object id + dt_object <- assign_new_id(idf_env, dt_object, "object") + add_joined_cols(dt_object, dt_value, "rleid", "object_id") - # 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) + # assign value id + dt_value <- assign_new_id(idf_env, dt_value, "value") - if (.default) val_dt[is.na(defaulted), defaulted := TRUE] + # 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] - # order - setorderv(val_dt, c("rleid", "field_index")) + # assign default values + if (default) dt_value <- assign_idf_value_default(idd_env, idf_env, dt_value) - # remove unuseful columns - set(obj_dt, NULL, "num", NULL) + # delete empty fields + if (!empty) dt_value <- remove_empty_fields(idd_env, idf_env, dt_value) - # add comment column - set(obj_dt, NULL, "comment", list(list(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)) { + 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())) } - # }}} - # 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 + # validate {{{ + # skip unique object checking + chk$unique_object <- FALSE - # 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) + # 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) - # add field defaults if possible - set(val_chr, NULL, "defaulted", FALSE) - if (.default) val_chr[is.na(value_chr), defaulted := TRUE] + # validate + validity <- validate_on_level(idd_env, idf_env, dt_object, dt_value, level = chk) + assert_valid(validity, "add") - # always tag rleid of character input as negative - set(val_chr, NULL, "rleid", -val_chr$rleid) - } + set(dt_object, NULL, "object_id", id_obj) + set(dt_value, NULL, "object_id", id_val) # }}} - 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")) - - # 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) + # 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]) + } - # assign default - if (.default) val <- assign_default_value(val) + 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]) + } - # remove duplicated objects - if (.unique) { - parsed <- remove_duplicated_objects(idd_env, idf_env, obj, val) + # extract new reference + k <- unique(c(i, j)) + if (!length(k)) { + ref <- idf_env$reference[0L] + } else { + ref <- idf_env$reference[k] + # remove from the original IDF reference table + idf_env$reference <- idf_env$reference[-k] + } + # 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) - # 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) - - # validate - assert_valid(idd_env, idf_env, parsed$object, parsed$value, action = "add") + 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) + } - # 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 = 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() ) } # }}} -# update_idf_object {{{ -update_idf_object <- function (idd_env, idf_env, version, ..., .default = TRUE, .empty = FALSE) { - l <- sep_definition_dots(..., .version = version, .update = TRUE) +# set_idf_object {{{ +#' Modifying existing objects +#' +#' @inherit add_idf_object +#' +#' @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_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") + } + # 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" + ) + } - 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")) + # 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)] - # get object and value from data.frame input {{{ - if (!nrow(l$value)) { - obj_dt <- data.table() - val_dt <- data.table() + # 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] + + # delete empty fields + 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) + 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 { - 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"]) - ) - ) - } + # add necessary columns used for getting references + add_field_property(idd_env, dt_value, "src_enum") - # 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"]) - ) - ) - } - ) + 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) - # 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) - } - ) + ref <- get_value_reference_map(idd_env, append_dt(idf_env$value, dt_value), dt_value) - # 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") - ] - ) + set(idf_env$value, NULL, c("src_enum", "class_id", "class_name"), NULL) + 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))) + # }}} - # 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) + # 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") + } - # reset rleid - set(val_dt, NULL, "rleid", - obj_dt[J(val_dt$rleid, val_dt$object_id), on = c("rleid", "object_id"), rleid] + 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 +#' +#' @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 +#' 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. +#' +#' @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_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")), + "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") + } + } + # 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" ) + } - # add new value id - val_dt <- assign_new_id(idf_env, val_dt, "value", keep = TRUE) + # get objects to be deleted + id_del <- dt_object$object_id - # delete unuseful columns - set(obj_dt, NULL, "num", NULL) + # always check if target objects are referred by others + dir <- if (ref_to) "all" else "ref_by" - # order - setorderv(val_dt, c("rleid", "field_index")) + 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 = ", "), "]") } - # }}} - # 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 + id_ref_by <- c() - # 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"]) - ) - ) - } + # ref by {{{ + # exclude invalid reference + if (nrow(rel$ref_by)) { + rel$ref_by <- rel$ref_by[!J(NA_integer_), on = "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"]) - ) - ) + # 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"] + + 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") } + # }}} - # 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"]) + 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.") ) - ) + } } - ) + } + } + # }}} - # 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) - ) + # 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"] - # 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) + id_ref_to <- setdiff(unique(rel$ref_to$src_object_id), id_del) - assert_can_do(idd_env, idf_env, l$dot, obj_chr, "set") + # 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.") + ) + } + } + } + # }}} - # 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 - ) - ) + 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 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) - } - ) + id_del <- if (NROW(rel$ref_to)) c(id_del, id_ref_by, id_ref_to) else c(id_del, id_ref_by) - # 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)) - ] + 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 +#' +#' @inherit add_idf_object +#' +#' @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] - # correct rleid - val_chr <- val_ori - add_joined_cols(obj_chr, val_chr, "object_id", "rleid") + 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")) + } + } - # clean - set(obj_chr, NULL, "num", NULL) + 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())) } - # }}} - 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] + ) - # make sure rleid is unique - set(obj, NULL, "rleid", seq.int(nrow(obj))) - set(val, NULL, "rleid", rleid(val$rleid, val$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] + ) - # assign default values if needed - if (.default) { - val <- assign_default_value(val) - set(val, NULL, c("default_chr", "default_num"), NULL) + id <- unique(c(id_del, id_rec)) + + if (!length(id)) { + verbose_info("None of specified object(s) can be purged. Skip.") + obj <- idf_env$object + val <- idf_env$value + ref <- idf_env$reference } 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"] } - # 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, changed = id, updated = integer()) +} +# }}} +# duplicated_idf_object {{{ +#' Determine duplicate objects +#' +#' @inherit add_idf_object +#' +#' @return A same [data.table::data.table()] as input `dt_object` (updated by +#' reference) with appended integer column `unique_object_id` indicating the +#' object is a duplicated one of that object. +#' +#' @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") + + # change to lower case for comparison + set(dt_value, NULL, "value_chr_lower", tolower(dt_value$value_chr)) - # assign new value id - val[value_id < 0L, value_id := new_id(idf_env$value, "value_id", .N)] + # 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] - # 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)) + # 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") - # delete fields - add_joined_cols(idd_env$class, val, "class_id", c("min_fields", "num_extensible")) - if (!.empty) val <- remove_empty_fields(val) + 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")] - # validate - assert_valid(idd_env, idf_env, obj, val, action = "set") + dt_object[dup, on = c("object_id" = "object_id_dup"), unique_object_id := i.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) - ) + 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 - ) - } +# unique_idf_object {{{ +#' Remove duplicate objects +#' +#' @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) - val <- get_idf_value(idd_env, idf_env, class) + if (checkmate::allMissing(dup$unique_object_id)) { + verbose_info("None duplicated objects found. Skip.") + return(list( + object = idf_env$object, value = idf_env$value, reference = idf_env$reference, + changed = integer(), updated = integer())) + } - val <- val[grepl(pattern, value_chr, ignore.case = ignore.case, perl = perl, - fixed = fixed, useBytes = useBytes) - ] + obj <- dup[!J(NA_integer_), on = "unique_object_id"] - if (!nrow(val)) { - verbose_info("No matched result found.") - return(invisible()) - } + # remove reference rows of duplicated objects + ref <- idf_env$reference[!J(obj$object_id), on = "object_id"] - 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 - ) - } + # get referenced field index of object to be deleted + src <- ref[J(obj$object_id), on = "src_object_id", nomatch = NULL] - prop <- c("units", "ip_units", "is_name", "required_field", "src_enum", "type_enum", "extensible_group") + 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 = "")) - val <- get_idf_value(idd_env, idf_env, class, property = prop) + setnames(obj, + c("removed_object_id", "removed_object_name", "object_id", "object_name"), + c("object_id", "object_name", "unique_object_id", "unique_object_name") + ) - val <- val[grepl(pattern, value_chr, ignore.case = ignore.case, perl = perl, - fixed = fixed, useBytes = useBytes) - ] + 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) + ] - if (!nrow(val)) { - verbose_info("No matched result found.") - return(invisible()) + msg <- obj[, by = c("class_id", "unique_object_id"), list(list( + sprintf("Duplications for %s have been removed:\n %s", + unique[[1L]], paste0(removed, collapse = "\n ") + ) + ))]$V1 + verbose_info(paste0(unlist(msg), collapse = "\n\n")) } - 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) + src[idf_env$value, on = c("src_object_id" = "object_id", "src_value_id" = "value_id"), + `:=`(src_field_id = i.field_id)] - obj <- get_idf_object(idd_env, idf_env, object = unique(val$object_id)) - # update object name - obj <- update_object_name(obj, val) + # 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)] - assert_valid(idd_env, idf_env, obj, val, action = "set") + # 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 = obj, value = val, - reference = update_value_reference(idd_env, idf_env, obj, val) + 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) ) } # }}} -# 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 +#' +#' @inherit add_idf_object +#' +#' @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")[ + J(TRUE), on = "is_name", nomatch = NULL] - 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, 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") } - 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, 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") - - # reset rleid - add_rleid(obj) -} -# }}} -# 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] + 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) ) - 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 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") + 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))])) { @@ -3175,13 +3428,27 @@ 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 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 # from IDF Editor to negative also note that dcast will automatically @@ -3189,18 +3456,20 @@ 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)) - # 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) + 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 @@ -3217,62 +3486,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) @@ -3297,7 +3574,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 @@ -3378,6 +3655,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) @@ -3417,114 +3696,25 @@ 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 -} -# }}} # 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, 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 # extract all node data @@ -3539,8 +3729,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 @@ -3555,7 +3745,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 @@ -3602,10 +3792,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() @@ -3677,35 +3870,153 @@ 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) } + if (is.null(version)) { + version <- get_idf_value(idd_env, idf_env, "Version")$value_chr + } + # 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 # 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"), - force = FALSE) { + force = FALSE, init = FALSE) { group_ext <- match.arg(group_ext) cols <- c("object_id", "object_name", "class_name", @@ -3713,10 +4024,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) { @@ -3724,11 +4046,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, @@ -3829,14 +4149,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: #' @@ -3847,7 +4168,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 @@ -3859,15 +4179,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)) { @@ -3893,28 +4215,47 @@ 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 + 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 (!flat) return(fmt) + if (format == "sorted") { combine_fmt <- function (lst) { head <- if (is.null(lst[[1L]])) "" else c("", lst[[1L]], "") @@ -3945,17 +4286,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'", "idf_save_ext") 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.", "idf_save_exist") } else { verbose_info("Replace the existing IDF located at ", normalizePath(path), ".") } @@ -3963,9 +4300,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 @@ -3985,7 +4320,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) @@ -4019,8 +4354,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" ) } @@ -4049,11 +4384,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" + )) } } @@ -4069,52 +4402,56 @@ 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))] } } # }}} -# 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 (dt_value) { +# 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) { + 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(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 -} -# }}} -# 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"))) - - idf_env$object <- append_dt(idf_env$object, dt$object, "object_id") - if (nrow(dt$value)) { - if (by_object) { - idf_env$value <- append_dt(idf_env$value, dt$value, "object_id") - } else { - idf_env$value <- append_dt(idf_env$value, dt$value, "value_id") - } + 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)] } - idf_env$reference <- dt$reference - setorderv(idf_env$object, c("object_id")) - setorderv(idf_env$value, c("object_id", "field_id")) + if (!is.null(cols_add)) set(dt_value, NULL, cols_add, NULL) - idf_env + dt_value +} +# }}} +# order_idf_data {{{ +order_idf_data <- function (lst) { + setorderv(lst$object, "object_id") + setorderv(lst$value, c("object_id", "field_id")) + + lst } # }}} # add_idf_format_cols {{{ diff --git a/R/impl-idfobj.R b/R/impl-idfobj.R index 427ce40bb..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" ) } @@ -91,7 +57,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) { @@ -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") @@ -177,7 +95,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) { @@ -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-sql.R b/R/impl-sql.R index 4b4173eb4..3852c785c 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, @@ -94,27 +101,36 @@ 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 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] + 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(is.character(key_value), no_na(key_value)) - KEY_VALUE <- key_value - rpvar_dict <- rpvar_dict[J(KEY_VALUE), on = "key_value", nomatch = NULL] + assert_character(key_value, any.missing = FALSE) + 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(is.character(name), no_na(name)) - NAME <- name - rpvar_dict <- rpvar_dict[J(NAME), on = "name"] + assert_character(name, any.missing = FALSE) + 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 {{{ @@ -130,41 +146,48 @@ 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(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( @@ -195,7 +218,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")} @@ -221,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)) { @@ -334,8 +353,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 +368,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 +395,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 +422,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 +472,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 +525,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 +539,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/impl.R b/R/impl.R index 1855391d9..6ca6ea2dc 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<-" @@ -10,13 +12,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 +35,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 +63,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 +78,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 +99,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,26 +151,32 @@ 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(...) } # }}} +# 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 (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 +184,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), data = dt) } # }}} # 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)))] } # }}} @@ -192,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") } @@ -214,7 +230,7 @@ errormsg_field_name <- function (dt) { # new_id {{{ 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) } # }}} @@ -226,26 +242,55 @@ add_rleid <- function (dt, prefix = NULL) { # }}} # append_dt {{{ 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 (!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)))) } } # }}} # 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) +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) + + 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" } + 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/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..5fad875d7 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 } @@ -1042,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("error_sql_not_exist", paste0("Simulation SQL output does not exist.")) - } + checkmate::assert_file_exists(path_sql, "r", .var.name = "Simulation SQL output") path_sql } # }}} @@ -1056,9 +1046,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.")) - } + + checkmate::assert_file_exists(path, "r", .var.name = name) path } @@ -1176,7 +1165,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 +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("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.", "idf_not_local") } 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." + ), "idf_path_not_exist") } 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.", "idf_not_saved") } # add Output:SQLite if necessary @@ -1229,45 +1206,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 (!file.exists(epw)) { - abort("error_epw_path_not_exist", - paste0( - "Input EPW file does not exist. ", - "Path: ", surround(normalizePath(epw, mustWork = FALSE)) - ) - ) + if (checkmate::test_string(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("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.", "epw_not_local") } 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." + ), "epw_path_not_exist") } 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.", "epw_not_saved") } path <- epw$path() diff --git a/R/options.R b/R/options.R new file mode 100644 index 000000000..c2bcf6c20 --- /dev/null +++ b/R/options.R @@ -0,0 +1,216 @@ +#' @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()) + +# for storing internal data +.globals$eplus <- list() +.globals$idd <- list() +.globals$epw <- 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) +#' @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" %chin% 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/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/parse.R b/R/parse.R index c0e7bbe72..b88111b1e 100644 --- a/R/parse.R +++ b/R/parse.R @@ -1,19 +1,21 @@ #' @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 -#' @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", @@ -25,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") ), @@ -34,27 +39,36 @@ 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") ) ) +# 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 +77,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"), @@ -74,16 +90,20 @@ 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) + idd_version <- get_idd_ver(idd_dt) idd_build <- get_idd_build(idd_dt) @@ -93,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) @@ -122,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 @@ -144,26 +165,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 @@ -182,16 +183,15 @@ 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") + eplusr_warning = function (w) invokeRestart("muffleWarning") ) } else { idd <- get_idd_from_ver(idf_ver, idd) } # 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) @@ -213,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 @@ -229,11 +229,11 @@ 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) { - 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), @@ -247,28 +247,9 @@ 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")) + # 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 @@ -278,53 +259,34 @@ parse_idf_file <- function (path, idd = NULL, ref = TRUE) { # get_idd_ver {{{ get_idd_ver <- function (idd_dt) { - assert(inherits(idd_dt, "data.table"), has_name(idd_dt, c("line", "string"))) - - ver_line <- idd_dt[stri_startswith_fixed(string, "!IDD_Version")] + ver_line <- idd_dt$string[[1L]] - 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")) { + parse_error("idd", "No IDD version on 1st line", idd_dt[1L]) } 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 on 1st line", idd_dt[1L]) + + ver } } # }}} # get_idd_build {{{ 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")) { 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) ) @@ -345,26 +307,29 @@ get_idf_ver <- function (idf_dt, empty_removed = TRUE) { 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_issue("error_multiple_version", "idf", "Multiple versions found", ver_line) + parse_error("idf", "Multiple IDF versions found", ver_line, subtype = "ver") } } # }}} # 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 <- dt[i] - set(dt, NULL, "excl_loc", NULL) dt } # }}} @@ -384,17 +349,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)) @@ -407,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 @@ -419,7 +376,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 +384,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 +395,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 +404,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 +412,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 +456,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 +474,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 +485,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 +520,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 +529,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 +553,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 @@ -721,9 +673,7 @@ get_field_table <- function (dt, type_enum) { # dcast_slash {{{ 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 +683,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)) { @@ -766,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) @@ -795,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]])) { @@ -806,12 +747,12 @@ 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, class = parse_class_property(dt, ref), - field = parse_field_property(dt, ref) + field = parse_field_property(dt, ref, epw = epw) ) dt @@ -868,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) @@ -903,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))) @@ -924,7 +873,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) } @@ -978,7 +927,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)] @@ -1003,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 } # }}} @@ -1141,8 +1126,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 +1150,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], subtype = "line") } dt @@ -1227,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] @@ -1235,7 +1219,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, subtype = "object") } # extract class names @@ -1267,16 +1251,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 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_issue("error_invalid_class", "idf", "Invalid class name", invld_obj) + parse_error("idf", "Invalid class name", invld_obj, subtype = "class") } # fill class id and class name @@ -1315,9 +1297,14 @@ 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_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) && !escape) { + parse_error("idf", "Invalid line found", dt[stri_count_fixed(body, ";") > 1L], subtype = "line") + } setindexv(dt, "value_count") @@ -1359,20 +1346,19 @@ get_value_table <- function (dt, idd) { 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 ), - error_bad_field_index = function (e) e + eplusr_error_invalid_field_index = function (e) e ) # 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 @@ -1380,13 +1366,16 @@ 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, subtype = "field") } # 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 <- unique(fld, by = "field_id")[dt, 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)))] @@ -1395,6 +1384,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", @@ -1415,29 +1405,37 @@ 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) } } - 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 } # }}} # 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_names(dt_value, "units")) { + add_field_property(idd_env, dt_value, "units") + on.exit(set(dt_value, NULL, "units", NULL), add = TRUE) + } + 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) + } val <- dt_value[!is.na(value_num) & !is.na(units), list(value_id, value_num, units, ip_units)] 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")) @@ -1450,20 +1448,50 @@ convert_value_unit <- function (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 } # }}} -# 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, @@ -1474,7 +1502,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, @@ -1486,7 +1514,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), @@ -1500,42 +1528,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"), @@ -1548,9 +1542,19 @@ get_value_reference_map <- function (map, src, value, all = TRUE) { # }}} # parse_issue {{{ -parse_issue <- function (error_type, type = c("idf", "idd", "err", "epw"), - title, data = NULL, num = NULL, prefix = NULL, post = NULL, - stop = TRUE) { +parse_warn <- 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") { + 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, 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, suffix = NULL, post = NULL, + stop = TRUE, subtype = NULL, loc_name = "Line") { start_rule <- cli::rule(line = 2L) @@ -1559,11 +1563,10 @@ 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"))) - mes <- paste0(data$msg_each, "Line ", lpad(data$line), ": ", data$string) - if (!is.null(prefix)) { - mes <- paste0(prefix, mes) - } + assert_names(names(data), must.include = c("line", "string")) + 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) { @@ -1604,10 +1607,14 @@ 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) + + type <- paste0("parse_", type) + subtype <- if (!is.null(subtype)) paste0(type, "_", subtype) + if (stop) { - abort(c(error_type, paste0("error_parse_", type)), all_mes, NULL, data = data) + abort(all_mes, c(subtype, type), data = data) } else { - warn(c(error_type, paste0("warning_parse_", type)), all_mes, NULL, data = data) + warn(all_mes, c(subtype, type), data = data) } } # }}} @@ -1616,13 +1623,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") && 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 { x } diff --git a/R/rdd.R b/R/rdd.R index f53dd1434..056f53918 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(mdd)) abort("'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" - ) + 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 7b3b222a6..e7baa9d71 100644 --- a/R/reload.R +++ b/R/reload.R @@ -54,44 +54,43 @@ 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)$m_log) 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$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) + priv <- get_priv_env(x) + 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 } #' @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 +99,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/run.R b/R/run.R index 08f66ea76..f6e2c576f 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 @@ -44,7 +46,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 +84,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 +227,21 @@ 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)) { - stop("Missing version field in input IDF file. Failed to determine the ", - "version of EnergyPlus to use.", call. = FALSE) + if (!length(eplus)) { + 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) + # 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) abort(paste0("Failed to create output directory: ", surround(output_dir)), "create_output_dir") ) } @@ -249,7 +265,7 @@ 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")] } # }}} @@ -259,28 +275,30 @@ run_idf <- function (model, weather, output_dir, design_day = FALSE, # 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.") + abort("Cannot force both design-day-only simulation and annual simulation at the same time", + "both_ddy_annual" + ) } model <- normalizePath(model, mustWork = TRUE) @@ -298,34 +316,31 @@ 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 - )) + abort(paste0("Missing version field in input IDF file. Failed to determine the ", + "version of EnergyPlus to use:\n", msg), "miss_idf_ver") } - eplus <- unlist(ver_list) + 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)) } - energyplus_exe <- vapply(eplus, eplus_exe, FUN.VALUE = character(1)) - if (anyDuplicated(model) & is.null(output_dir)) { - abort("error_run_duplicated_model", - "`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)) { 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,27 +348,27 @@ 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(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") )) } 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 +378,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 +386,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) { + utils::getFromNamespace("run_parallel_jobs", "eplusr")(jobs, options) + }, args = list(jobs = jobs, options = options)) } - } # }}} @@ -426,15 +427,19 @@ 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) + + # 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) # 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 +455,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 +464,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) inherits(x, "process") && 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 +509,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 +520,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) + + jobs[ready, c("status", "process", "start_time") := { + clean_wd(model) - if (any(jobs$status == "newly_started")) { - completed <- jobs[status == "newly_started", - sim_status("run", index_str, model, weather) - ] + 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 +550,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 ", @@ -626,23 +613,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) + abort("Cannot force both design-day and annual simulations", "both_ddy_annual") } # argument docs {{{ @@ -771,6 +756,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()) } } @@ -867,15 +853,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) { - 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." - )) + 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."), + "eplus_ver_not_supported" + ) } normalizePath(file.path(config$dir, config$exe), mustWork = TRUE) @@ -889,16 +875,16 @@ 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) ) 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") - return(loc) + loc } # }}} # get_run_time {{{ @@ -906,7 +892,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/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 7f0f1e634..a5f09e079 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.", "idf_not_local") } 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 (!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." + )) + } # 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 (!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 (", + 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_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) { + 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") @@ -2909,9 +2985,8 @@ trans_preprocess <- function (idf, version, class = NULL) { "required_field", "src_enum", "type_enum" ) ) - set(val, NULL, "defaulted", TRUE) # assign default values - val <- assign_default_value(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] @@ -2920,9 +2995,17 @@ 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") - 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 } } @@ -2952,10 +3035,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 +3052,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 +3072,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 +3153,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 +3175,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 +3271,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 +3291,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 +3343,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 +3424,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 +3438,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 +3448,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 +3479,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 +3544,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." + ), "idf_not_local") } # 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 +3566,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 +3580,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 +3593,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 +3638,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 +3652,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 +3663,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/R/units.R b/R/units.R index ac03500e5..3836ae225 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 @@ -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 @@ -17,8 +18,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 @@ -114,7 +116,9 @@ UNIT_CONV_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 @@ -177,445 +181,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 end # }}} diff --git a/R/utils.R b/R/utils.R index e0f770241..7c7bfef06 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 # `%||%` {{{ @@ -14,10 +16,10 @@ 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)) { + if (length(out) == 1L) { out <- c(out, out) } s <- paste0(out[1L], x, out[2L]) @@ -26,7 +28,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,23 +40,43 @@ 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)) { + if (length(out) == 1L) { out <- c(out, out) } paste0(out[1L], x, out[2L]) } # }}} -# `._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") } # }}} @@ -73,40 +97,12 @@ 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)) - ) - } + 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"]])) @@ -139,10 +135,10 @@ read_lines <- function(input, trim = TRUE, ...) { # Windows. 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 { - assert(is.character(x)) + assert_character(x) fwrite(data.table(x), file = file, col.names = FALSE, quote = FALSE, append = append) } } @@ -173,33 +169,25 @@ standardize_ver <- function (ver, strict = FALSE, complete = TRUE) { if (any(int)) ver[int] <- paste0(ver[int], ".0") } - 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])) 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)) +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)) all_ver <- unique(all_ver) ori_ver <- ver @@ -213,29 +201,26 @@ 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 } # }}} -# 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 +231,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") } } # }}} @@ -334,35 +319,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)) + } } # }}} @@ -380,16 +361,16 @@ names2 <- function (x, default = NA_character_) { # each_length {{{ each_length <- function (x) { - vapply(x, length, integer(1L)) + viapply(x, length) } # }}} # ranger {{{ 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, na.ok = TRUE) + assert_number(maximum, na.ok = TRUE) + assert_flag(lower_incbounds) + assert_flag(upper_incbounds) setattr( list( minimum = minimum, lower_incbounds = lower_incbounds, @@ -398,38 +379,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 {{{ -append_dt <- function (dt, new_dt, base_col = NULL) { - assert(has_name(new_dt, 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 {{{ -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 -} # }}} # fmt_* {{{ @@ -443,50 +392,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/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/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/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 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/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/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 85fb5e621..f453bb476 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()}} @@ -462,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}{ @@ -483,7 +495,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}{ @@ -518,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}{ @@ -545,9 +558,57 @@ 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}{ +\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{}} +\if{latex}{\out{\hypertarget{method-location}{}}} \subsection{Method \code{location()}}{ Get and modify LOCATION header \subsection{Usage}{ @@ -624,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}{ @@ -637,7 +699,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. @@ -660,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}{ @@ -698,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}{ @@ -706,20 +770,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{
}} @@ -735,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}{ @@ -826,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}{ @@ -864,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}{ @@ -902,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}{ @@ -930,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}{ @@ -958,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}{ @@ -991,7 +1061,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. } @@ -1014,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}{ @@ -1042,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}{ @@ -1071,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}{ @@ -1100,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}{ @@ -1129,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}{ @@ -1174,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}{ @@ -1182,7 +1258,8 @@ Get weather data start_year = NULL, align_wday = TRUE, tz = "UTC", - update = FALSE + update = FALSE, + line = FALSE )}\if{html}{\out{
}} } @@ -1212,6 +1289,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{}} } @@ -1272,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}{ @@ -1293,8 +1375,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 @@ -1354,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}{ @@ -1388,21 +1471,16 @@ 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}{ -\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}.} @@ -1452,26 +1530,16 @@ 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}{ -\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}.} @@ -1532,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}{ @@ -1585,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}{ @@ -1629,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}{ @@ -1657,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}{ @@ -1719,7 +1791,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. @@ -1745,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}{ @@ -1829,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}{ @@ -1854,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}{ @@ -1883,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}{ @@ -1928,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}{ @@ -1957,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 0ea7332af..aad2dd6fb 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} @@ -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 5e9854b62..ed5bf7dff 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) } @@ -909,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}{ @@ -982,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}{ @@ -1013,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}{ @@ -1046,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}{ @@ -1095,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}{ @@ -1156,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}{ @@ -1204,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}{ @@ -1253,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}{ @@ -1293,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}{ @@ -1354,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}{ @@ -1418,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}{ @@ -1460,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}{ @@ -1496,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}{ @@ -1539,10 +1555,11 @@ 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}{ -\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 +1567,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{
}} } @@ -1592,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}{ @@ -1645,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}{ @@ -1707,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}{ @@ -1765,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}{ @@ -1802,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}{ @@ -1925,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}{ @@ -2041,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. @@ -2092,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}{ @@ -2151,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}{ @@ -2253,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}{ @@ -2382,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}{ @@ -2491,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}{ @@ -2549,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}{ @@ -2588,7 +2622,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}{ @@ -2613,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}{ @@ -2673,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}{ @@ -2718,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}{ @@ -2783,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}{ @@ -2941,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}{ @@ -3068,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}{ @@ -3120,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}{ @@ -3177,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}{ @@ -3240,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}{ @@ -3422,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}{ @@ -3469,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}{ @@ -3553,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}{ @@ -3565,7 +3612,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,13 +3672,18 @@ 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{}} } \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. @@ -3708,6 +3761,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) } } @@ -3718,6 +3774,7 @@ idf$to_table(class = "BuildingSurface:Detailed", group_ext = "index", } \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}{ @@ -3747,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}{ @@ -3825,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}{ @@ -3949,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}{ @@ -3979,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}{ @@ -4124,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}{ @@ -4182,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}{ @@ -4248,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 28144bd8c..6cb077636 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} @@ -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/man/add_idf_object.Rd b/man/add_idf_object.Rd new file mode 100644 index 000000000..7a10a0ead --- /dev/null +++ b/man/add_idf_object.Rd @@ -0,0 +1,51 @@ +% 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.} + +\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. +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 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 +} +\keyword{internal} 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/as.character.IdfObject.Rd b/man/as.character.IdfObject.Rd index 88bb97384..943684a2b 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} @@ -7,18 +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}{A character vector to be used as comments of returned string -format object. If \code{NULL}, no comments are inserted. Default: \code{NULL}.} +\item{comment}{If \code{FALSE}, all comments will not be included. Default: \code{TRUE}.} -\item{leading}{Leading spaces added to each field. Default: \code{4}.} +\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{29} which is the same as IDF Editor.} +Default: \code{29L} 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{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/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/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 new file mode 100644 index 000000000..b09932b89 --- /dev/null +++ b/man/del_idf_object.Rd @@ -0,0 +1,55 @@ +% 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.} + +\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 \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 +} +\keyword{internal} 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 new file mode 100644 index 000000000..25fdab8eb --- /dev/null +++ b/man/dup_idf_object.Rd @@ -0,0 +1,36 @@ +% 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.} + +\item{level}{Validate level. Default: \code{eplusr_option("validate_level")}.} +} +\value{ +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 +} +\keyword{internal} diff --git a/man/duplicated_idf_object.Rd b/man/duplicated_idf_object.Rd new file mode 100644 index 000000000..91b735c2d --- /dev/null +++ b/man/duplicated_idf_object.Rd @@ -0,0 +1,26 @@ +% 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.} +} +\value{ +A same \code{\link[data.table:data.table]{data.table::data.table()}} as input \code{dt_object} (updated by +reference) with appended integer column \code{unique_object_id} indicating the +object is a duplicated one of that object. +} +\description{ +Determine duplicate objects +} +\keyword{internal} 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/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..cbd78cd11 --- /dev/null +++ b/man/expand_idf_dots_value.Rd @@ -0,0 +1,85 @@ +% 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 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"}, +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..8c3e620af --- /dev/null +++ b/man/expand_idf_regex.Rd @@ -0,0 +1,41 @@ +% 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{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.} +} +\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/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..f1279d621 100644 --- a/man/format.IddObject.Rd +++ b/man/format.IddObject.Rd @@ -1,24 +1,15 @@ % 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, ver = TRUE, ...) } \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{ver}{If \code{TRUE}, a suffix of version string is added. Default: \code{TRUE}.} \item{...}{Further arguments passed to or from other methods.} } @@ -26,12 +17,12 @@ only minimum fields are returned.} 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/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_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/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..3f70e2648 --- /dev/null +++ b/man/get_idd_field.Rd @@ -0,0 +1,49 @@ +% 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.} + +\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 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/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_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_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/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/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/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/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/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..ab288b5cb --- /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, + include_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{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{ +A \code{\link[data.table:data.table]{data.table::data.table()}} +} +\description{ +Initialize object data +} +\keyword{internal} 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/man/purge_idf_object.Rd b/man/purge_idf_object.Rd new file mode 100644 index 000000000..ea6f49440 --- /dev/null +++ b/man/purge_idf_object.Rd @@ -0,0 +1,29 @@ +% 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.} +} +\value{ +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 +} +\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/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 new file mode 100644 index 000000000..29b43a7b0 --- /dev/null +++ b/man/rename_idf_object.Rd @@ -0,0 +1,36 @@ +% 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.} + +\item{level}{Validate level. Default: \code{eplusr_option("validate_level")}.} +} +\value{ +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 +} +\keyword{internal} 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/man/set_idf_object.Rd b/man/set_idf_object.Rd new file mode 100644 index 000000000..7cb9c2944 --- /dev/null +++ b/man/set_idf_object.Rd @@ -0,0 +1,42 @@ +% 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.} + +\item{dt_value}{A \code{\link[data.table:data.table]{data.table::data.table()}} that contains value data.} + +\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 \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 +} +\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/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/unique_idf_object.Rd b/man/unique_idf_object.Rd new file mode 100644 index 000000000..1cc183c57 --- /dev/null +++ b/man/unique_idf_object.Rd @@ -0,0 +1,29 @@ +% 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.} +} +\value{ +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 +} +\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/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/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/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-assert.R b/tests/testthat/test-assert.R new file mode 100644 index 000000000..0581887cd --- /dev/null +++ b/tests/testthat/test-assert.R @@ -0,0 +1,72 @@ +context("Assertions") + +test_that("Assertion functions", { + expect_equal(convert_to_eplus_ver(8), numeric_version("8.0.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, 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)) + 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, download = "auto"))) + + 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_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(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(is_epwdate(epw_date(1))) + expect_false(is_epwdate(epw_date(-1))) + + expect_is(is_windows(), "logical") + expect_is(is_linux(), 'logical') + expect_is(is_macos(), 'logical') +}) diff --git a/tests/testthat/test-epw.R b/tests/testthat/test-epw.R new file mode 100644 index 000000000..697698f61 --- /dev/null +++ b/tests/testthat/test-epw.R @@ -0,0 +1,494 @@ +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_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") + + 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_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") + ) + ) + + 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_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, + 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()", { + 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") + + 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 similarity index 93% rename from tests/testthat/test_format.R rename to tests/testthat/test-format.R index 58619b3d5..d134bcabb 100644 --- a/tests/testthat/test_format.R +++ b/tests/testthat/test-format.R @@ -190,7 +190,7 @@ test_that("Idd formatting", { ) # }}} # IDF {{{ - idd_parsed <- ._get_private(use_idd(8.8, "auto"))$m_idd_env + 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 @@ -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 similarity index 92% rename from tests/testthat/test_group.R rename to 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-idd.R b/tests/testthat/test-idd.R new file mode 100644 index 000000000..a37599312 --- /dev/null +++ b/tests/testthat/test-idd.R @@ -0,0 +1,293 @@ +context("Idd") + +eplusr_option(verbose_info = FALSE) + +# download_idd() {{{ +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() + # 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() + # remove all parsed IDD + .globals$idd <- list() + + expect_error(is_avail_idd("latest")) + + 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_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 <- FALSE + # can create an Idd object from string + expect_silent(idd <- use_idd(text("idd", "9.9.9"))) + + # can get Idd version + expect_equal(idd$version(), as.numeric_version("9.9.9")) + + # can get Idd build + expect_equal(idd$build(), "7c3bbe4830") + + # can get all group names + expect_equal(idd$group_name(), c("TestGroup1", "TestGroup2")) + + # can get group name of one class + expect_equal(idd$from_group("TestSimple"), "TestGroup1") + + # can return when multiple class names are given + expect_equal(idd$from_group(c("TestSlash", "TestSimple")), + c("TestGroup2", "TestGroup1")) + + # can stop when invalid class name is given + 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) + + # can return multiple group indexes + expect_equal(idd$group_index(c("TestGroup2", "TestGroup1", "TestGroup2")), + c(2L, 1L, 2L)) + + # can stop when invalid group names are given + 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) + + # can return multiple class indexes + 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 = "eplusr_error_invalid_class_name") + + expect_is(idd$object_relation("TestSimple"), "IddRelation") + expect_is(idd$object_relation("TestSimple", "ref_to"), "IddRelation") + expect_is(idd$object_relation("TestSimple", "ref_by"), "IddRelation") + + # can return names of all required classes + expect_equal(idd$required_class_name(), "TestSlash") + + # can return names of all unique-object classes + expect_equal(idd$unique_class_name(), "TestSlash") + + # can return names of all extensible classes + expect_equal(idd$extensible_class_name(), "TestSlash") + + # can return a single IddObject using class name + expect_is(idd$object("TestSimple"), "IddObject") + + # 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")), + list(TestSimple = idd$object("TestSimple"), + TestSlash = idd$object("TestSlash"))) + + # can return all IddObjects in a group + expect_is(idd$objects_in_group("TestGroup1"), "list") + 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 = "eplusr_error_invalid_group_name") + + # can stop when multiple group names are given + 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") + expect_is(idd$objects_in_relation("TestSimple", "ref_by"), "list") + expect_equal(names(idd$objects_in_relation("TestSimple", "ref_by")), c("TestSimple", "TestSlash")) + + # can check if input is a valid group + expect_false(idd$is_valid_group("WrongGroup")) + expect_true(idd$is_valid_group("TestGroup1")) + + # can check if input is a valid 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()) + + # 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") + + .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") + expect_true(idd == idd) + expect_true(idd != "a") + expect_false(idd != idd) +}) +# }}} diff --git a/tests/testthat/test_iddobj.R b/tests/testthat/test-iddobj.R similarity index 88% rename from tests/testthat/test_iddobj.R rename to 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_idf.R b/tests/testthat/test-idf.R similarity index 54% rename from tests/testthat/test_idf.R rename to tests/testthat/test-idf.R index 56bea3035..fa55ff08e 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,221 @@ 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)) +}) +# }}} - # RENAME {{{ +# 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)))) + + 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") - # SEARCH AND REPLACE {{{ + 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)) + + 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}", + " 0.5,", + " 800,", + " 300;", + "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, 2;\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), 2) + 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 +797,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 +1020,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 +1094,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(with_option(list(autocomplete = TRUE), idf$Timestep <- NULL))) + expect_output(with_option(list(autocomplete = TRUE), 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,22 +1233,23 @@ 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)}) + 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 <- NULL) - expect_silent(idf$SimulationControl <- str) + expect_silent(with_option(list(autocomplete = TRUE), idf$SimulationControl <- str)) expect_true("SimulationControl" %in% names(idf)) # }}} @@ -750,7 +1269,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 +1285,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 +1293,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..17df9780b 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) +}) +# }}} - # Basic {{{ - # get parent Idf - expect_is(ver$parent(), "Idf") +# 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")) +}) +# }}} - # get group name - expect_equal(con$group_name(), "Surface Construction Elements") +# 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") +}) +# }}} - # get class name - expect_equal(con$class_name(), "Construction") +# 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) +}) +# }}} - # get object ID - expect_equal(mat$id(), 1L) - # }}} +# 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") +}) +# }}} + +# 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") +}) +# }}} + +# 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") +}) +# }}} + +# 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,55 @@ 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) ) ) - # }}} - # Relation {{{ + 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) +}) +# }}} + +# 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") + expect_equivalent(con$value_relation(1), list( ref_to = data.table( @@ -262,10 +369,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 +402,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 +444,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 +454,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 +464,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 +483,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 +495,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 +568,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(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)) + + 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-epw.R b/tests/testthat/test-impl-epw.R new file mode 100644 index 000000000..fcf86e040 --- /dev/null +++ b/tests/testthat/test-impl-epw.R @@ -0,0 +1,509 @@ +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 + expect_warning( + { + 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) + 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( + suppressWarnings(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-idd.R b/tests/testthat/test-impl-idd.R similarity index 57% rename from tests/testthat/test_impl-idd.R rename to tests/testthat/test-impl-idd.R index ff75d9a23..52184976e 100644 --- a/tests/testthat/test_impl-idd.R +++ b/tests/testthat/test-impl-idd.R @@ -1,24 +1,26 @@ -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 +53,23 @@ 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))[]) + ) + + 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 {{{ # 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 +101,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 +140,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 +151,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 +193,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 +209,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 +235,7 @@ test_that("table manipulation", { ) ) ) + expect_equal(nrow(get_idd_field(idd_parsed, 2L, "test_numeric_field_3", all = TRUE)), 8L) # }}} # }}} @@ -215,35 +260,85 @@ test_that("table manipulation", { src_enum = 2L, dep = 0L ) ) + + idd <- use_idd(8.8, "auto") + 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) + + 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" - ) - ) # }}} - }) -# }}} 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" + ) + + ) + # }}} +}) +# }}} diff --git a/tests/testthat/test-impl-idf.R b/tests/testthat/test-impl-idf.R new file mode 100644 index 000000000..a06ee3430 --- /dev/null +++ b/tests/testthat/test-impl-idf.R @@ -0,0 +1,2454 @@ +context("IDF Implementation") + +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_priv_env(use_idd(8.8))$idd_env() + + # OBJECT {{{ + expect_equal(get_idf_object(idd_env, idf_env, 1), + 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(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(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(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), 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"), + 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)) + 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 = "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_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])) + 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) + ) + expect_equal(get_idf_object_id(idd_env, idf_env, simplify = TRUE), 1L:5L) + expect_equal(get_idf_object_id(idd_env, idf_env, "Material"), list(Material = c(1L, 4L))) + expect_equal(get_idf_object_id(idd_env, idf_env, 55), list(Material = c(1L, 4L))) + expect_equal(get_idf_object_id(idd_env, idf_env, 55, simplify = TRUE), c(1L, 4L)) + expect_equal(get_idf_object_id(idd_env, idf_env, "Material", simplify = TRUE), c(1L, 4L)) + + expect_equal(get_idf_object_name(idd_env, idf_env), + list(Version = NA_character_, Material = c("WD01", "WD02"), + Construction = "WALL-1", `BuildingSurface:Detailed` = "WALL-1PF") + ) + 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_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 = "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_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 {{{ + # get all value from current idf {{{ + 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" + ) + ) + # }}} + # 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, 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", "Density", + "Specific Heat" + ) + ) + ) + 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, 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)) + expect_equivalent(val$field_index, rep(1:9, 2)) + expect_equivalent(val$field_name, + rep( + c("Name", "Roughness", "Thickness", "Conductivity", "Density", + "Specific Heat", "Thermal Absorptance", "Solar Absorptance", + "Visible Absorptance"), + 2 + ) + ) + expect_equivalent(val$rleid, rep(1L, 18)) + expect_equivalent(val$class_name, rep("Material", 18)) + expect_equivalent(val$object_name, rep(c("WD01", "WD02"), each = 9)) + # }}} + # 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, 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", "Density", "Specific Heat") + ) + ) + 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 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, 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)) + expect_equivalent(val$field_index, rep(1:9, 2)) + expect_equivalent(val$field_name, + rep( + c("Name", "Roughness", "Thickness", "Conductivity", "Density", + "Specific Heat", "Thermal Absorptance", "Solar Absorptance", + "Visible Absorptance"), + 2 + ) + ) + expect_equivalent(val$rleid, rep(1L, 18)) + expect_equivalent(val$class_name, rep("Material", 18)) + expect_equivalent(val$object_name, rep(c("WD01", "WD02"), each = 9)) + # }}} + # 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, 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)) + expect_equivalent(val$field_index, rep(1:9, 2)) + expect_equivalent(val$field_name, + rep( + c("Name", "Roughness", "Thickness", "Conductivity", "Density", + "Specific Heat", "Thermal Absorptance", "Solar Absorptance", + "Visible Absorptance"), + 2 + ) + ) + expect_equivalent(val$rleid, rep(1L, 18)) + expect_equivalent(val$class_name, rep("Material", 18)) + expect_equivalent(val$object_name, rep(c("WD01", "WD02"), each = 9)) + expect_equivalent( + get_idf_value(idd_env, idf_env, "Material", all = TRUE), + get_idf_value(idd_env, idf_env, "Material", all = TRUE, align = TRUE) + ) + # }}} + # }}} + # 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, 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", "Density", + "Specific Heat") + ) + ) + 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, 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)) + expect_equivalent(val$field_index, rep(1:9, 2)) + expect_equivalent(val$field_name, + rep( + c("Name", "Roughness", "Thickness", "Conductivity", "Density", + "Specific Heat", "Thermal Absorptance", "Solar Absorptance", + "Visible Absorptance"), + 2 + ) + ) + expect_equivalent(val$rleid, rep(c(1L, 2L), each = 9)) + expect_equivalent(val$class_name, rep("Material", 18)) + expect_equivalent(val$object_name, rep(c("WD01", "WD02"), each = 9)) + # }}} + # 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, 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", "Density", "Specific Heat") + ) + ) + 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 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, 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)) + expect_equivalent(val$field_index, rep(1:9, 2)) + expect_equivalent(val$field_name, + rep( + c("Name", "Roughness", "Thickness", "Conductivity", "Density", + "Specific Heat", "Thermal Absorptance", "Solar Absorptance", + "Visible Absorptance"), + 2 + ) + ) + expect_equivalent(val$rleid, rep(c(1L, 2L), each = 9)) + expect_equivalent(val$class_name, rep("Material", 18)) + expect_equivalent(val$object_name, rep(c("WD01", "WD02"), each = 9)) + # }}} + # 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, 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)) + expect_equivalent(val$field_index, rep(1:9, 2)) + expect_equivalent(val$field_name, + rep( + c("Name", "Roughness", "Thickness", "Conductivity", "Density", + "Specific Heat", "Thermal Absorptance", "Solar Absorptance", + "Visible Absorptance"), + 2 + ) + ) + expect_equivalent(val$rleid, rep(c(1L, 2L), each = 9)) + expect_equivalent(val$class_name, rep("Material", 18)) + expect_equivalent(val$object_name, rep(c("WD01", "WD02"), each = 9)) + expect_equivalent( + get_idf_value(idd_env, idf_env, object = c("WD01", "WD02"), all = TRUE), + get_idf_value(idd_env, idf_env, object = c("WD01", "WD02"), all = TRUE, align = TRUE) + ) + # }}} + # }}} + # get value from field {{{ + # one class, multiple fields {{{ + expect_silent({val <- get_idf_value(idd_env, idf_env, "BuildingSurface:Detailed", field = 1:24)}) + expect_equivalent(val$value_id, c(15:38)) + expect_equivalent(val$object_id, rep(3L, 24)) + expect_equivalent(val$field_id, 11622:11645) + expect_equivalent(val$class_id, rep(103L, 24)) + expect_equivalent(val$field_index, 1:24) + expect_equivalent(val$rleid, rep(1L, 24)) + expect_equivalent(val$class_name, rep("BuildingSurface:Detailed", 24)) + expect_equivalent(val$object_name, rep("WALL-1PF", 24)) + expect_equal(nrow(get_idf_value(idd_env, idf_env, "Material", field = c(8, 9), align = TRUE)), 4L) + # }}} + # one field for each class {{{ + expect_silent({val <- get_idf_value(idd_env, idf_env, c("Material", "BuildingSurface:Detailed"), field = c(4, 9))}) + expect_equivalent(val$value_id, c(4L, 43L, 23L)) + expect_equivalent(val$object_id, c(1L, 4L, 3L)) + expect_equivalent(val$field_id, c(rep(7084L, 2), 11630)) + expect_equivalent(val$class_id, c(rep(55L, 2), 103L)) + expect_equivalent(val$field_index, c(rep(4L, 2), 9L)) + expect_equivalent(val$field_name, c(rep("Conductivity", 2), "View Factor to Ground")) + expect_equivalent(val$rleid, c(1L, 1L, 2L)) + expect_equivalent(val$class_name, c(rep("Material", 2), "BuildingSurface:Detailed")) + expect_equivalent(val$object_name, c("WD01", "WD02", "WALL-1PF")) + expect_equal(nrow(get_idf_value(idd_env, idf_env, c("Material", "BuildingSurface:Detailed"), field = c(9, 24), align = TRUE)), 3) + # }}} + expect_equal(nrow(get_idf_value(idd_env, idf_env, object = c("WD01", "WD02"), field = c(4, 9), complete = TRUE)), 15) + expect_equal(nrow(get_idf_value(idd_env, idf_env, c("Material", "BuildingSurface:Detailed"), field = c(4, 9), complete = TRUE)), 31) + expect_equal(nrow(get_idf_value(idd_env, idf_env, object = c("WD01", "WD02"), field = c(4, 9), align = TRUE)), 2) + expect_equal(nrow(get_idf_value(idd_env, idf_env, object = c("WD02"), field = c(4, 9), align = TRUE)), 2) + expect_equal(nrow(get_idf_value(idd_env, idf_env, c("BuildingSurface:Detailed"), field = c(4, 9), align = TRUE)), 2) + # }}} + + # misc + 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) + 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, 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, 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)) + expect_equal(get_idf_value(idd_env, idf_env, c("Construction", "Material"), + field = c(4L, 9L), align = TRUE)$value_id, c(13L, 9L, -1L) + ) + expect_equal(get_idf_value(idd_env, idf_env, c("Construction", "Material"), + field = fld_nm, align = TRUE)$value_id, c(13L, 9L, -1L) + ) + + # 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) + + 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 = 47:52, value_chr = NA_character_, value_num = NA_real_ + ) + ) + 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 = 47:52, 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 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") + + # 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() + + 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") + # }}} +}) +# }}} + +# NAME DOTS {{{ +test_that("NAME 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() + + # 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, + 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)"), + 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, + 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)") + ) + ) + + # 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, + 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"), + 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, + 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") + ) + ) + + # 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, + 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"), + new_object_name = c(NA_character_, "Floor") + ) + ) +}) +# }}} + +# VALUE DOTS {{{ +test_that("VALUE DOTS", { + # parse_dots_value {{{ + # can stop if empty input + expect_error(parse_dots_value(), "Must have length >= 1") + expect_error(parse_dots_value(NULL), "missing value") + + # 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") + + 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", + 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 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_) + ) + ) + ) + + # 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_ + ) + ) + ) + + # 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_ + ) + ) + ) + + # 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_ + ) + ) + ) + + # 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), + 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_ + ) + ) + ) + a <- "cls1" + 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_ + ) + ) + ) + + # 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" + ) + + # 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) + ) + ) + ) + + # 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 + ) + ) + ) + ) + + # 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_ + ) + ) + ) + + # 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_ + ) + ) + ) + + # 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(), ..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, NA), value_num = c(1, NA, NA) + ) + ) + ) + + # 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_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_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 + ) + ) + ) + # }}} + + # 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" + ) + + # 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_ + ) + ) + + ## 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_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, + 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)) + + ## 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)) + + ## 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)) + + ## 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_equal(res$object$object_id, rep(27:28, 2)) + expect_equal(res$value$field_index, rep(1:2, 2 * 2)) + + ## 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_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")) + # }}} + # }}} +}) +# }}} + +# OBJECT DOTS {{{ +test_that("OBJECT 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() + + # 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_silent(expand_idf_dots_value(idd_env, idf_env, ..53 = list("sch"), .type = "object", .empty = FALSE)) +}) +# }}} + +# 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, 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", + 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_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, 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))) +}) +# }}} + +# REGEX {{{ +test_that("regex", { + # read idf + idf_env <- parse_idf_file(example(), 8.8) + idd_env <- get_priv_env(use_idd(8.8))$idd_env() + + # 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)) +}) +# }}} + +# 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() + + # can stop if trying to assign names to objects that do not have name attribute + expect_error( + 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( + 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( + make_idf_object_name(idd_env, idf_env, expand_idf_dots_name(idd_env, idf_env, "floor" = "floor")), + class = "eplusr_error_conflict_name" + ) + + # 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")) + ) + ) + + # 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", "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(), + class_id = c(22L, 22L, 56L, 56L) + ) + ) + expect_equal(nrow(dup$value), 382) + expect_equal(dup$value[349:382], + data.table( + 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), + 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()) +}) +# }}} + +# ADD {{{ +test_that("Add", { + # read idf + idf <- read_idf(example(), 8.8) + idf_env <- get_priv_env(idf)$m_idf_env + idd_env <- get_priv_env(idf)$idd_env() + + # 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") + + # 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") + + # 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") + + # 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") + + # can remove input objects that are the same as existing ones + expect_is(class = "list", + { + l <- expand_idf_dots_value(idd_env, idf_env, floor = list(), .type = "object") + 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( + { + 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[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_is(class = "list", + { + 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 + ) + 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()) +}) +# }}} + +# 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), 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", + { + 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), 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", + { + 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), 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", + { + 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), 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_is(class = "list", + { + l <- expand_idf_dots_value(idd_env, idf_env, .type = "object", + ROOF31 = list(outside_layer = "R13LAYER"), + FLOOR = list(outside_layer = "NoSuchMaterial") + ) + 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), + 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) +}) +# }}} + +# DEL {{{ +test_that("Del", { + # read idf + 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 = 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_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()) +}) +# }}} + +# 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, 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, 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(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()) +}) +# }}} + +# 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() + + 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)) +}) +# }}} + +# 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() + + 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)) +}) +# }}} + +# 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() + + # 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" + ) + + # 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" + ) + + # 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" + ) + + # 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_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_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) +}) +# }}} + +# IDF EDITOR {{{ +test_that("Parsing IDF EDITOR Copy Contents", { + skip_if_not(is_windows()) + + # 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_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", { + # read idf + 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", + index = 1:9, + field = c( + "Name", "Roughness", "Thickness", "Conductivity", "Density", + "Specific Heat", "Thermal Absorptance", "Solar Absorptance", + "Visible Absorptance" + ), + value = c( + "C5 - 4 IN HW CONCRETE", "MediumRough", "0.1014984", "1.729577", + "2242.585", "836.8", "0.9", "0.65", "0.65" + ) + ) + ) + expect_equivalent(get_idf_table(idd_env, idf_env, "Material", string_value = FALSE), + data.table(id = 14L, name = "C5 - 4 IN HW CONCRETE", class = "Material", + index = 1:9, + field = c( + "Name", "Roughness", "Thickness", "Conductivity", "Density", + "Specific Heat", "Thermal Absorptance", "Solar Absorptance", + "Visible Absorptance" + ), + value = list( + "C5 - 4 IN HW CONCRETE", "MediumRough", 0.1014984, 1.729577, + 2242.585, 836.8, 0.9, 0.65, 0.65 + ) + ), tolerance = 1e-5 + ) + expect_equivalent(get_idf_table(idd_env, idf_env, "Material", string_value = FALSE, unit = TRUE), + data.table(id = 14L, name = "C5 - 4 IN HW CONCRETE", class = "Material", + index = 1:9, + field = c( + "Name", "Roughness", "Thickness", "Conductivity", "Density", + "Specific Heat", "Thermal Absorptance", "Solar Absorptance", + "Visible Absorptance" + ), + value = list( + "C5 - 4 IN HW CONCRETE", "MediumRough", + units::set_units(0.1014984, "m"), + units::set_units(1.729577, "W/K/m"), + units::set_units(2242.585, "kg/m^3"), + units::set_units(836.8, "J/K/kg"), + 0.9, 0.65, 0.65 + ) + ), tolerance = 1e-5 + ) + expect_equivalent(get_idf_table(idd_env, idf_env, "Material", string_value = FALSE, unit = TRUE, wide = TRUE), + data.table(id = 14L, name = "C5 - 4 IN HW CONCRETE", class = "Material", + "Name" = "C5 - 4 IN HW CONCRETE", + "Roughness" = "MediumRough", + "Thickness" = units::set_units(0.1014984, "m"), + "Conductivity" = units::set_units(1.729577, "W/K/m"), + "Density" = units::set_units(2242.585, "kg/m^3"), + "Specific Heat" = units::set_units(836.8, "J/K/kg"), + "Thermal Absorptance" = 0.9, + "Solar Absorptance" = 0.65, + "Visible Absorptance" = 0.65 + ), tolerance = 1e-5 + ) + expect_equivalent(get_idf_table(idd_env, idf_env, "Material", string_value = FALSE, unit = TRUE, wide = TRUE, group_ext = "group"), + data.table(id = 14L, name = "C5 - 4 IN HW CONCRETE", class = "Material", + "Name" = "C5 - 4 IN HW CONCRETE", + "Roughness" = "MediumRough", + "Thickness" = units::set_units(0.1014984, "m"), + "Conductivity" = units::set_units(1.729577, "W/K/m"), + "Density" = units::set_units(2242.585, "kg/m^3"), + "Specific Heat" = units::set_units(836.8, "J/K/kg"), + "Thermal Absorptance" = 0.9, + "Solar Absorptance" = 0.65, + "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")) +}) +# }}} + +# 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) + 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) +}) +# }}} + +# 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_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)], + 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(), basename(tempfile()), basename(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_top" + ) + ) + expect_silent( + save_idf(idd_env, idf_env, idf_env$object[, list(object_id, object_order = 0)], + tempfile(fileext = ".idf"), format = "new_bot" + ) + ) +}) +# }}} + +# 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 + 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_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"), 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(dir, 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 new file mode 100644 index 000000000..20c5f3461 --- /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 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) + 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))) +}) +# }}} diff --git a/tests/testthat/test_install.R b/tests/testthat/test-install.R similarity index 76% rename from tests/testthat/test_install.R rename to tests/testthat/test-install.R index 4574aa514..1a184ffde 100644 --- a/tests/testthat/test_install.R +++ b/tests/testthat/test-install.R @@ -1,9 +1,8 @@ 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) + 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_job.R b/tests/testthat/test-job.R similarity index 100% rename from tests/testthat/test_job.R rename to tests/testthat/test-job.R diff --git a/tests/testthat/test_options.R b/tests/testthat/test-options.R similarity index 83% rename from tests/testthat/test_options.R rename to 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))) diff --git a/tests/testthat/test_param.R b/tests/testthat/test-param.R similarity index 97% rename from tests/testthat/test_param.R rename to tests/testthat/test-param.R index 2d08085ae..52e7fb67e 100644 --- a/tests/testthat/test_param.R +++ b/tests/testthat/test-param.R @@ -6,13 +6,13 @@ 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() param <- param_job(example$idf, example$epw) - priv <- ._get_private(param) + priv <- get_priv_env(param) # Seed and Weather {{{ expect_is(param$seed(), "Idf") @@ -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 similarity index 60% rename from tests/testthat/test_parse.R rename to tests/testthat/test-parse.R index 7c67bf3d9..525a0a7dc 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,20 +79,19 @@ 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 IDD version", "eplusr_error_parse_idd") - # 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", "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 @@ -102,20 +99,7 @@ test_that("parse_idd_file()", { Test, A1 ; \\note something" ) - expect_warning(idd_parsed <- parse_idd_file(idd_wrong), class = "warning_miss_idd_build") - 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") + expect_equal(parse_idd_file(idd_wrong)$build, NA_character_) # can detect error of invalid line idd_wrong <- c( @@ -128,7 +112,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", "eplusr_error_parse_idd") # can detect missing group lines idd_wrong <- c( @@ -144,7 +128,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 +146,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", class = "eplusr_error_parse_idd") # can detect incomplete class idd_wrong <- c( @@ -179,7 +163,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", class = "eplusr_error_parse_idd") # can detect missing class names idd_wrong <- c( @@ -195,7 +179,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", class = "eplusr_error_parse_idd") # can manually insert class slash idd_cls <- c( @@ -222,7 +206,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", class = "eplusr_error_parse_idd") # can detect error of invaid type key idd_wrong <- c( @@ -233,7 +217,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", class = "eplusr_error_parse_idd") # can detect error of invaid external list key idd_wrong <- c( @@ -244,7 +228,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", class = "eplusr_error_parse_idd") # can detect error of invalid format key idd_wrong <- c( @@ -255,7 +239,134 @@ 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", class = "eplusr_error_parse_idd") + + # 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", class = "eplusr_error_parse_idd") + + # 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]) +}) +# }}} + +# 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[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) + 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 Precip 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, FALSE) + 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, FALSE) + 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) }) # }}} @@ -263,24 +374,22 @@ 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) ) # }}} - 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), @@ -329,11 +438,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 +468,8 @@ 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), 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 +485,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), class = "eplusr_error_parse_idf_object") # can detect error of invalid class name idf_wrong <- c( @@ -387,16 +497,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), class = "eplusr_error_parse_idf_class") 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), 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), class = "error_multiple_version") + 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,6 +515,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), 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) + + # can handle DDY without giving unnecessary warning + ddy <- tempfile(fileext = ".ddy") + file.create(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 similarity index 90% rename from tests/testthat/test_rdd.R rename to 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 new file mode 100644 index 000000000..743933574 --- /dev/null +++ b/tests/testthat/test-reload.R @@ -0,0 +1,78 @@ +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_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) + 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-run.R b/tests/testthat/test-run.R new file mode 100644 index 000000000..aa7614e28 --- /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", class = "eplusr_error_miss_idf_ver") + # 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 + }, normalizePath(d, mustWork = FALSE)) + + # 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, 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_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)))) + + # 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, 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) + expect_is(res$process, "process") + expect_silent({res$process$wait(); 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", class = "eplusr_error_both_ddy_annual") + # can stop if model does not exist + expect_error(run_multi(tempfile(), NULL)) + # 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", 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", class = "eplusr_error_locate_eplus") + # can stop if input idf contain duplications + 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 + 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(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, 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") + + 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$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", + "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(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, 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_sql.R b/tests/testthat/test-sql.R similarity index 100% rename from tests/testthat/test_sql.R rename to tests/testthat/test-sql.R diff --git a/tests/testthat/test-transition.R b/tests/testthat/test-transition.R new file mode 100644 index 000000000..e69b5a8ca --- /dev/null +++ b/tests/testthat/test-transition.R @@ -0,0 +1,1738 @@ +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() + ) + expect_equal( + idfVU$"HVACTemplate:Zone:PTAC"[[2]]$value(), + idfTR$"HVACTemplate:Zone:PTAC"[[2]]$value() + ) + + expect_equal( + idfVU$"HVACTemplate:Zone:PTHP"[[1]]$value(), + idfTR$"HVACTemplate:Zone:PTHP"[[1]]$value() + ) + expect_equal( + idfVU$"HVACTemplate:Zone:PTHP"[[2]]$value(), + idfTR$"HVACTemplate:Zone:PTHP"[[2]]$value() + ) + + expect_equal( + idfVU$"HVACTemplate:Zone:WaterToAirHeatPump"[[1]]$value(), + idfTR$"HVACTemplate:Zone:WaterToAirHeatPump"[[1]]$value() + ) + expect_equal( + idfVU$"HVACTemplate:Zone:WaterToAirHeatPump"[[2]]$value(), + idfTR$"HVACTemplate:Zone:WaterToAirHeatPump"[[2]]$value() + ) + + expect_equal( + idfVU$"HVACTemplate:System:Unitary"$Sys1$value(), + idfTR$"HVACTemplate:System:Unitary"$Sys1$value() + ) + expect_equal( + idfVU$"HVACTemplate:System:Unitary"$Sys2$value(), + idfTR$"HVACTemplate:System:Unitary"$Sys2$value() + ) + + expect_equal( + idfVU$"HVACTemplate:System:UnitaryHeatPump:AirToAir"$Sys3$value(), + idfTR$"HVACTemplate:System:UnitaryHeatPump:AirToAir"$Sys3$value() + ) + expect_equal( + idfVU$"HVACTemplate:System:UnitaryHeatPump:AirToAir"$Sys4$value(), + idfTR$"HVACTemplate:System:UnitaryHeatPump:AirToAir"$Sys4$value() + ) +}) +# }}} +# 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()[-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, "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"), + "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, dir = "C:/Users/hongy/Desktop/"), "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$"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 + 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 = 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, + 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 + ) + ) + + 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-units.R b/tests/testthat/test-units.R new file mode 100644 index 000000000..c85968a36 --- /dev/null +++ b/tests/testthat/test-units.R @@ -0,0 +1,13 @@ +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(units::set_units(1, "inH2O"), "inch_H2O_39F"), + units::set_units(1, "inch_H2O_39F") + ) +}) diff --git a/tests/testthat/test-utils.R b/tests/testthat/test-utils.R new file mode 100644 index 000000000..6c1b2b59c --- /dev/null +++ b/tests/testthat/test-utils.R @@ -0,0 +1,108 @@ +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", "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() + 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"), 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) + 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_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 similarity index 97% rename from tests/testthat/test_validate.R rename to tests/testthat/test-validate.R index 71ff0c9a8..f7e064ef7 100644 --- a/tests/testthat/test_validate.R +++ b/tests/testthat/test-validate.R @@ -3,8 +3,8 @@ 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() + 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()), @@ -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 {{{ 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_epw.R b/tests/testthat/test_epw.R deleted file mode 100644 index c5fda5487..000000000 --- a/tests/testthat/test_epw.R +++ /dev/null @@ -1,230 +0,0 @@ -test_that("Epw class", { - # clean temp dir - clean_tempdir() - eplusr_option(verbose_info = FALSE) - - expect_equal(format_epw_header_design(NULL), "0") - expect_equal(format_epw_header_design(list(NULL)), "0") - expect_equal(format_epw_header_design(list(list(NULL))), "0") - expect_equal(format_epw_header_typical(NULL), "0") - expect_equal(format_epw_header_typical(list(NULL)), "0") - expect_equal(format_epw_header_typical(list(list(NULL))), "0") - expect_equal(format_epw_header_ground(NULL), "0") - expect_equal(format_epw_header_ground(list(NULL)), "0") - expect_equal(format_epw_header_ground(list(list(NULL))), "0") - - 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())} - ) -}) diff --git a/tests/testthat/test_idd.R b/tests/testthat/test_idd.R deleted file mode 100644 index 94ab0bf1e..000000000 --- a/tests/testthat/test_idd.R +++ /dev/null @@ -1,163 +0,0 @@ -context("Idd and IddObject") - -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"))) - - expect_silent(download_idd("latest", tempdir())) - expect_true(file.exists(file.path(tempdir(), "V9-2-0-Energy+.idd"))) -}) -# }}} - -# 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")) - 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_silent(use_idd(text("idd", "9.9.9"))) - expect_true(is_avail_idd("9.9.9")) - - # 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")) -}) -# }}} - -# Idd class {{{ -test_that("Idd class", { - .options$autocomplete <- TRUE - # can create an Idd object from string - expect_silent(idd <- use_idd(text("idd", "9.9.9"))) - - # can get Idd version - expect_equal(idd$version(), as.numeric_version("9.9.9")) - - # can get Idd build - expect_equal(idd$build(), "7c3bbe4830") - - # can get all group names - expect_equal(idd$group_name(), c("TestGroup1", "TestGroup2")) - - # can get group name of one class - expect_equal(idd$from_group("TestSimple"), "TestGroup1") - - # can return when multiple class names are given - expect_equal(idd$from_group(c("TestSlash", "TestSimple")), - c("TestGroup2", "TestGroup1")) - - # can stop when invalid class name is given - expect_error(idd$from_group("WrongClass"), class = "error_class_name") - - # can return all class names - expect_equal(idd$class_name(), c("TestSimple", "TestSlash")) - - # can return an index of a single group - expect_equal(idd$group_index("TestGroup1"), 1) - - # can return multiple group indexes - expect_equal(idd$group_index(c("TestGroup2", "TestGroup1", "TestGroup2")), - c(2L, 1L, 2L)) - - # can stop when invalid group names are given - expect_error(idd$group_index("WrongGroup"), class = "error_group_name") - - # can return an index of a single class - expect_equal(idd$class_index("TestSlash"), 2L) - - # can return multiple class indexes - expect_equal(idd$class_index(c("TestSlash", "TestSimple", "TestSimple")), - c(2L, 1L, 1L)) - - # can stop when invalid class names are given - expect_error(idd$class_index("WrongClass"), error = "error_class_name") - - expect_is(idd$object_relation("TestSimple"), "IddRelation") - expect_is(idd$object_relation("TestSimple", "ref_to"), "IddRelation") - expect_is(idd$object_relation("TestSimple", "ref_by"), "IddRelation") - - # can return names of all required classes - expect_equal(idd$required_class_name(), "TestSlash") - - # can return names of all unique-object classes - expect_equal(idd$unique_class_name(), "TestSlash") - - # can return names of all extensible classes - expect_equal(idd$extensible_class_name(), "TestSlash") - - # can return a single IddObject using class name - expect_is(idd$object("TestSimple"), "IddObject") - - # can stop when invalid class names are given - expect_error(idd$object("WrongClass"), error = "error_class_name_us") - - # can return when multiple class names are given - expect_equal(idd$objects(c("TestSimple", "TestSlash")), - list(TestSimple = idd$object("TestSimple"), - TestSlash = idd$object("TestSlash"))) - - # can return all IddObjects in a group - expect_is(idd$objects_in_group("TestGroup1"), "list") - 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") - - # can stop when multiple group names are given - expect_error(idd$objects_in_group(c("TestGroup1", "TestGroup2")), class = "error_not_string") - - expect_is(idd$objects_in_relation("TestSimple", "ref_to"), "list") - expect_equal(names(idd$objects_in_relation("TestSimple", "ref_to")), "TestSimple") - expect_is(idd$objects_in_relation("TestSimple", "ref_by"), "list") - expect_equal(names(idd$objects_in_relation("TestSimple", "ref_by")), c("TestSimple", "TestSlash")) - - # can check if input is a valid group - expect_false(idd$is_valid_group("WrongGroup")) - expect_true(idd$is_valid_group("TestGroup1")) - - # can check if input is a valid class - expect_false(idd$is_valid_class("WrongClass")) - expect_true(idd$is_valid_class("TestSlash")) - - # can print without error - expect_output(idd$print()) - - # can get single object using S3 method - expect_equal(idd$TestSlash, idd$object("TestSlash")) - expect_equal(idd[["TestSlash"]], idd$object("TestSlash")) - - expect_is(idd$object("TestSlash"), "IddObject") - expect_is(idd$objects_in_group("TestGroup1")[[1L]], "IddObject") - - # can check equality - expect_false(idd == "a") - expect_true(idd == idd) - expect_true(idd != "a") - expect_false(idd != idd) -}) -# }}} diff --git a/tests/testthat/test_impl-idf.R b/tests/testthat/test_impl-idf.R deleted file mode 100644 index fa1667627..000000000 --- a/tests/testthat/test_impl-idf.R +++ /dev/null @@ -1,1105 +0,0 @@ -context("IDF Implementation") - -eplusr_option(validate_level = "final") -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 - - # 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" - ) - ) - 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" - ) - ) - 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 - ) - ) - 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 - ) - ) - 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, 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_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") - expect_equal(get_idf_object_id(idd_env, idf_env), - list(Version = 5L, Material = c(1L, 4L), Construction = 2L, `BuildingSurface:Detailed` = 3L) - ) - expect_equal(get_idf_object_id(idd_env, idf_env, simplify = TRUE), 1L:5L) - expect_equal(get_idf_object_id(idd_env, idf_env, "Material"), list(Material = c(1L, 4L))) - expect_equal(get_idf_object_id(idd_env, idf_env, 55), list(Material = c(1L, 4L))) - expect_equal(get_idf_object_id(idd_env, idf_env, 55, simplify = TRUE), c(1L, 4L)) - expect_equal(get_idf_object_id(idd_env, idf_env, "Material", simplify = TRUE), c(1L, 4L)) - - expect_equal(get_idf_object_name(idd_env, idf_env), - list(Version = NA_character_, Material = c("WD01", "WD02"), - Construction = "WALL-1", `BuildingSurface:Detailed` = "WALL-1PF") - ) - 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_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_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(idf_env$object[1], c("id", "name")), " #1| Object ID [1] (name 'WD01')") - expect_equal(get_object_info(idf_env$object[1], c("name")), " #1| Object name 'WD01'") - # }}} - - # VALUE {{{ - # 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" - ) - ) - # }}} - # 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$field_name, - c( - c("Name", "Roughness", "Thickness", "Conductivity", "Density", - "Specific Heat", "Thermal Absorptance", "Solar Absorptance", - "Visible Absorptance"), - c("Name", "Roughness", "Thickness", "Conductivity") - ) - ) - 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))) - # }}} - # 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$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)) - expect_equivalent(val$field_index, rep(1:9, 2)) - expect_equivalent(val$field_name, - rep( - c("Name", "Roughness", "Thickness", "Conductivity", "Density", - "Specific Heat", "Thermal Absorptance", "Solar Absorptance", - "Visible Absorptance"), - 2 - ) - ) - expect_equivalent(val$rleid, rep(1L, 18)) - expect_equivalent(val$class_name, rep("Material", 18)) - expect_equivalent(val$object_name, rep(c("WD01", "WD02"), each = 9)) - # }}} - # 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$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", "Density", "Specific Heat") - ) - ) - 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 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$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)) - expect_equivalent(val$field_index, rep(1:9, 2)) - expect_equivalent(val$field_name, - rep( - c("Name", "Roughness", "Thickness", "Conductivity", "Density", - "Specific Heat", "Thermal Absorptance", "Solar Absorptance", - "Visible Absorptance"), - 2 - ) - ) - expect_equivalent(val$rleid, rep(1L, 18)) - expect_equivalent(val$class_name, rep("Material", 18)) - expect_equivalent(val$object_name, rep(c("WD01", "WD02"), each = 9)) - # }}} - # 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$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)) - expect_equivalent(val$field_index, rep(1:9, 2)) - expect_equivalent(val$field_name, - rep( - c("Name", "Roughness", "Thickness", "Conductivity", "Density", - "Specific Heat", "Thermal Absorptance", "Solar Absorptance", - "Visible Absorptance"), - 2 - ) - ) - expect_equivalent(val$rleid, rep(1L, 18)) - expect_equivalent(val$class_name, rep("Material", 18)) - expect_equivalent(val$object_name, rep(c("WD01", "WD02"), each = 9)) - expect_equivalent( - get_idf_value(idd_env, idf_env, "Material", all = TRUE), - get_idf_value(idd_env, idf_env, "Material", all = TRUE, align = TRUE) - ) - # }}} - # }}} - # 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$field_name, - c( - c("Name", "Roughness", "Thickness", "Conductivity", "Density", - "Specific Heat", "Thermal Absorptance", "Solar Absorptance", - "Visible Absorptance"), - c("Name", "Roughness", "Thickness", "Conductivity") - ) - ) - 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))) - # }}} - # 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$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)) - expect_equivalent(val$field_index, rep(1:9, 2)) - expect_equivalent(val$field_name, - rep( - c("Name", "Roughness", "Thickness", "Conductivity", "Density", - "Specific Heat", "Thermal Absorptance", "Solar Absorptance", - "Visible Absorptance"), - 2 - ) - ) - expect_equivalent(val$rleid, rep(c(1L, 2L), each = 9)) - expect_equivalent(val$class_name, rep("Material", 18)) - expect_equivalent(val$object_name, rep(c("WD01", "WD02"), each = 9)) - # }}} - # 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$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", "Density", "Specific Heat") - ) - ) - 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 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$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)) - expect_equivalent(val$field_index, rep(1:9, 2)) - expect_equivalent(val$field_name, - rep( - c("Name", "Roughness", "Thickness", "Conductivity", "Density", - "Specific Heat", "Thermal Absorptance", "Solar Absorptance", - "Visible Absorptance"), - 2 - ) - ) - expect_equivalent(val$rleid, rep(c(1L, 2L), each = 9)) - expect_equivalent(val$class_name, rep("Material", 18)) - expect_equivalent(val$object_name, rep(c("WD01", "WD02"), each = 9)) - # }}} - # 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$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)) - expect_equivalent(val$field_index, rep(1:9, 2)) - expect_equivalent(val$field_name, - rep( - c("Name", "Roughness", "Thickness", "Conductivity", "Density", - "Specific Heat", "Thermal Absorptance", "Solar Absorptance", - "Visible Absorptance"), - 2 - ) - ) - expect_equivalent(val$rleid, rep(c(1L, 2L), each = 9)) - expect_equivalent(val$class_name, rep("Material", 18)) - expect_equivalent(val$object_name, rep(c("WD01", "WD02"), each = 9)) - expect_equivalent( - get_idf_value(idd_env, idf_env, object = c("WD01", "WD02"), all = TRUE), - get_idf_value(idd_env, idf_env, object = c("WD01", "WD02"), all = TRUE, align = TRUE) - ) - # }}} - # }}} - # get value from field {{{ - # one class, multiple fields {{{ - expect_silent({val <- get_idf_value(idd_env, idf_env, "BuildingSurface:Detailed", field = 1:24)}) - expect_equivalent(val$value_id, c(15:38)) - expect_equivalent(val$object_id, rep(3L, 24)) - expect_equivalent(val$field_id, 11622:11645) - expect_equivalent(val$class_id, rep(103L, 24)) - expect_equivalent(val$field_index, 1:24) - expect_equivalent(val$rleid, rep(1L, 24)) - expect_equivalent(val$class_name, rep("BuildingSurface:Detailed", 24)) - expect_equivalent(val$object_name, rep("WALL-1PF", 24)) - expect_equal(nrow(get_idf_value(idd_env, idf_env, "Material", field = c(8, 9), align = TRUE)), 4L) - # }}} - # one field for each class {{{ - expect_silent({val <- get_idf_value(idd_env, idf_env, c("Material", "BuildingSurface:Detailed"), field = c(4, 9))}) - expect_equivalent(val$value_id, c(4L, 43L, 23L)) - expect_equivalent(val$object_id, c(1L, 4L, 3L)) - expect_equivalent(val$field_id, c(rep(7084L, 2), 11630)) - expect_equivalent(val$class_id, c(rep(55L, 2), 103L)) - expect_equivalent(val$field_index, c(rep(4L, 2), 9L)) - expect_equivalent(val$field_name, c(rep("Conductivity", 2), "View Factor to Ground")) - expect_equivalent(val$rleid, c(1L, 1L, 2L)) - expect_equivalent(val$class_name, c(rep("Material", 2), "BuildingSurface:Detailed")) - expect_equivalent(val$object_name, c("WD01", "WD02", "WALL-1PF")) - expect_equal(nrow(get_idf_value(idd_env, idf_env, c("Material", "BuildingSurface:Detailed"), field = c(9, 24), align = TRUE)), 3) - # }}} - expect_equal(nrow(get_idf_value(idd_env, idf_env, object = c("WD01", "WD02"), field = c(4, 9), complete = TRUE)), 15) - expect_equal(nrow(get_idf_value(idd_env, idf_env, c("Material", "BuildingSurface:Detailed"), field = c(4, 9), complete = TRUE)), 31) - expect_equal(nrow(get_idf_value(idd_env, idf_env, object = c("WD01", "WD02"), field = c(4, 9), align = TRUE)), 2) - expect_equal(nrow(get_idf_value(idd_env, idf_env, object = c("WD02"), field = c(4, 9), align = TRUE)), 2) - expect_equal(nrow(get_idf_value(idd_env, idf_env, c("BuildingSurface:Detailed"), field = c(4, 9), align = TRUE)), 2) - # }}} - - # 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_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)) - 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)) - 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)) - expect_equal(get_idf_value(idd_env, idf_env, c("Construction", "Material"), - field = c(4L, 9L), align = TRUE)$value_id, c(13L, 9L, -1L) - ) - 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)) - ) - ) - - 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_equal( - get_idf_node_relation(idd_env, idf_env, id, depth = NULL), - set(idf_env$reference[0L], NULL, "dep", integer()) - ) - # }}} -}) -# }}} - -# 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)) - ) - ) - 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") - ) - ) - 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")))) - - # 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 - ) - ) - ) - - # 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 - ) - ) - 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) - ) - ) - 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) - ) - ) - - # 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()) - ) - 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) - ) - ) - - # 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()) - ) - 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 - ) - ) -}) -# }}} - -# 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() - ) - ), - value = data.table(), - dot = data.table(rleid = 1:2, dot = list(const1, const2), - dot_nm = NA_character_, depth = 1L - ) - ) - ) -}) -# }}} - -# 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)) -}) -# }}} - -# 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() - - 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 - )) - - expect_silent(rp <- add_idf_object(idd_env, idf_env, - RunPeriod = list("Test2", 1, 1, 2, 1), .default = TRUE, .all = TRUE) - ) - 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) - ) -}) -# }}} - -# 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() - - 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") - ) - 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_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" - ) - - # delete fields - expect_equal(nrow(set_idf_object(idd_env, idf_env, - ..8 = list(name = "name", start_year = NULL), .default = FALSE)$value), - 11L) - - # 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") - ) - ) - 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")) - - # 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" - ) - ) - expect_equivalent(cmt$value, data.table()) - expect_equivalent(cmt$reference, idf_env$reference) -}) -# }}} - -# DEL {{{ -test_that("Del", { - eplusr_option(verbose_info = FALSE) - # 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(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" - ) - 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)) -}) -# }}} - -# RENAME {{{ -test_that("Rename", { - # 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(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") -}) -# }}} - -# 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() - - 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" - ) - expect_error( - insert_idf_object(idd_env, idf_env, version = idf$version(), my_building = idf$Building, .unique = FALSE), - class = "error_insert_unique" - ) - expect_error( - insert_idf_object(idd_env, idf_env, version = numeric_version("8.7.0"), idf$Material), - class = "error_not_same_version" - ) - expect_error( - insert_idf_object(idd_env, idf_env, version = idf$version(), idf$Material, .unique = FALSE), - class = "error_validity" - ) - # can skip Version object - expect_silent( - ins <- insert_idf_object(idd_env, idf_env, version = idf$version(), idf$Version) - ) - 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) - ) - expect_equivalent(ins$object, - data.table(object_id = 54L, class_id = 55L, comment = list(), - object_name = "new_mat", object_name_lower = "new_mat" - ) - ) - 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", { - # 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(load_idf_object(idd_env, idf_env, 8.8), class = "error_empty_input") - - mat1 <- idf$definition("Material")$to_string() - mat2 <- idf$to_table(class = "Construction") - - mat2[4, class := "construction"] - expect_error(load_idf_object(idd_env, idf_env, 8.8, mat1, mat2), class = "error_class_name") - - mat2[4, `:=`(class = "Construction", index = 20L)] - expect_error(load_idf_object(idd_env, idf_env, 8.8, mat1, mat2), class = "error_bad_field_index") - - mat2[4, index := 2L] - expect_error(load_idf_object(idd_env, idf_env, 8.8, mat1, mat2), class = "error_validity") - - mat_chr <- c("Construction,", "new_const1,", paste0(idf$Material[[1]]$name(), ";")) - - 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" - ) - ) - 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 - ) - ) -}) -# }}} - -# UPDATE {{{ -test_that("Update", { - # 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(update_idf_object(idd_env, idf_env, 8.8), class = "error_empty_input") - - mat <- idf$definition("Material")$to_string() - const <- idf$to_table(class = "Construction") - - const[4, class := "construction"] - expect_error(update_idf_object(idd_env, idf_env, 8.8, mat, const), class = "error_class_name") - - const[4, `:=`(class = "Construction", id = 100L)] - expect_error(update_idf_object(idd_env, idf_env, 8.8, mat, const), class = "error_object_id") - - 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") - - const[4, index := 2L] - expect_error(update_idf_object(idd_env, idf_env, 8.8, mat, const), class = "error_missing_object_name") - - 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") - - expect_silent(upd <- update_idf_object(idd_env, idf_env, version = idf$version(), const, idf$Material[[1]]$to_string())) - - 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") - ) - ) - - 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)) - ) - ) - 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_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_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() - - 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" - ) - ) -}) -# }}} - -# 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() - - expect_equivalent(get_idf_table(idd_env, idf_env, "Material"), - data.table(id = 14L, name = "C5 - 4 IN HW CONCRETE", class = "Material", - index = 1:9, - field = c( - "Name", "Roughness", "Thickness", "Conductivity", "Density", - "Specific Heat", "Thermal Absorptance", "Solar Absorptance", - "Visible Absorptance" - ), - value = c( - "C5 - 4 IN HW CONCRETE", "MediumRough", "0.1014984", "1.729577", - "2242.585", "836.8", "0.9", "0.65", "0.65" - ) - ) - ) - expect_equivalent(get_idf_table(idd_env, idf_env, "Material", string_value = FALSE), - data.table(id = 14L, name = "C5 - 4 IN HW CONCRETE", class = "Material", - index = 1:9, - field = c( - "Name", "Roughness", "Thickness", "Conductivity", "Density", - "Specific Heat", "Thermal Absorptance", "Solar Absorptance", - "Visible Absorptance" - ), - value = list( - "C5 - 4 IN HW CONCRETE", "MediumRough", 0.1014984, 1.729577, - 2242.585, 836.8, 0.9, 0.65, 0.65 - ) - ), tolerance = 1e-5 - ) - expect_equivalent(get_idf_table(idd_env, idf_env, "Material", string_value = FALSE, unit = TRUE), - data.table(id = 14L, name = "C5 - 4 IN HW CONCRETE", class = "Material", - index = 1:9, - field = c( - "Name", "Roughness", "Thickness", "Conductivity", "Density", - "Specific Heat", "Thermal Absorptance", "Solar Absorptance", - "Visible Absorptance" - ), - value = list( - "C5 - 4 IN HW CONCRETE", "MediumRough", - units::set_units(0.1014984, "m"), - units::set_units(1.729577, "W/K/m"), - units::set_units(2242.585, "kg/m^3"), - units::set_units(836.8, "J/K/kg"), - 0.9, 0.65, 0.65 - ) - ), tolerance = 1e-5 - ) - expect_equivalent(get_idf_table(idd_env, idf_env, "Material", string_value = FALSE, unit = TRUE, wide = TRUE), - data.table(id = 14L, name = "C5 - 4 IN HW CONCRETE", class = "Material", - "Name" = "C5 - 4 IN HW CONCRETE", - "Roughness" = "MediumRough", - "Thickness" = units::set_units(0.1014984, "m"), - "Conductivity" = units::set_units(1.729577, "W/K/m"), - "Density" = units::set_units(2242.585, "kg/m^3"), - "Specific Heat" = units::set_units(836.8, "J/K/kg"), - "Thermal Absorptance" = 0.9, - "Solar Absorptance" = 0.65, - "Visible Absorptance" = 0.65 - ), tolerance = 1e-5 - ) - expect_equivalent(get_idf_table(idd_env, idf_env, "Material", string_value = FALSE, unit = TRUE, wide = TRUE, group_ext = "group"), - data.table(id = 14L, name = "C5 - 4 IN HW CONCRETE", class = "Material", - "Name" = "C5 - 4 IN HW CONCRETE", - "Roughness" = "MediumRough", - "Thickness" = units::set_units(0.1014984, "m"), - "Conductivity" = units::set_units(1.729577, "W/K/m"), - "Density" = units::set_units(2242.585, "kg/m^3"), - "Specific Heat" = units::set_units(836.8, "J/K/kg"), - "Thermal Absorptance" = 0.9, - "Solar Absorptance" = 0.65, - "Visible Absorptance" = 0.65 - ), tolerance = 1e-5 - ) -}) -# }}} diff --git a/tests/testthat/test_reload.R b/tests/testthat/test_reload.R deleted file mode 100644 index 4cc7e9400..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_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_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_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_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_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_true(job$status()$successful) - expect_true(grp$status()$successful) - expect_true(par$status()$successful) - -}) -# }}} 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 - ) - ) - # }}} -}) diff --git a/tests/testthat/test_utils.R b/tests/testthat/test_utils.R deleted file mode 100644 index 994708b0a..000000000 --- a/tests/testthat/test_utils.R +++ /dev/null @@ -1,17 +0,0 @@ -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")) -})