Nothing
#' @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 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 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",
"extensible"),
nest = c("memo")
),
field = list(
flat = c("field", "required-field", "units", "ip-units",
"unitsbasedonfield", "minimum", "minimum>", "maximum", "maximum<",
"default", "autosizable", "autocalculatable", "type",
"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")
),
type = list(
lgl = c("unique-object", "required-object", "required-field",
"unitsbasedonfield", "autosizable", "autocalculatable",
"begin-extensible", "deprecated", "obsolete", "retaincase"),
int = c("min-fields", "extensible"),
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", "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"),
property = c("format", "min_fields", "num_fields", "last_required",
"unique_object", "required_object", "has_name", "memo",
"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"),
property = c("field_anid", "units", "ip_units", "is_name",
"required_field", "extensible_group",
"type_enum", "src_enum", "type",
"autosizable", "autocalculatable",
"has_range", "maximum", "minimum", "lower_incbounds", "upper_incbounds",
"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, epw = FALSE, encoding = "unknown") {
# read idd string, get idd version and build
idd_dt <- read_lines(path, encoding = encoding)
idd_version <- get_idd_ver(idd_dt)
idd_build <- get_idd_build(idd_dt)
# delete all comment and blank lines
idd_dt <- clean_idd_lines(idd_dt)
# 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)
# mark line types
idd_dt <- mark_idd_lines(idd_dt, type_enum)
# group table
dt <- sep_group_table(idd_dt, type_enum)
dt_group <- dt$group
idd_dt <- dt$left
# class table
dt <- sep_class_table(idd_dt, type_enum)
dt_class <- dt$class
idd_dt <- dt$left
# field table
dt_field <- get_field_table(idd_dt, type_enum)
# dcast class and field tables
# NOTE: "*_id" column should always put first
dt_class <- dcast_slash(dt_class, "class_id",
IDD_SLASHKEY$class, c("group_id", "class_name")
)
dt_field <- dcast_slash(dt_field, c("field_id", "field_anid"),
IDD_SLASHKEY$field, c("class_id")
)
# complete property columns
dt_field <- complete_property(dt_field, "field", dt_class, epw = epw)
dt_class <- complete_property(dt_class, "class", dt_field, epw = epw)
# ConnectorList references are missing until v9.1
# See https://github.com/NREL/EnergyPlus/issues/7172
if (idd_version < "9.1") {
id_conlst <- dt_class[J("ConnectorList"), on = "class_name", class_id]
dt_field[J(id_conlst, c(3L, 5L)), on = c("class_id", "field_index"), `:=`(
object_list = list("plantconnectors")
)]
id_con <- dt_class[J(c("Connector:Mixer", "Connector:Splitter")), on = "class_name", class_id]
dt_field[J(id_con, c(1L)), on = c("class_id", "field_index"), `:=`(
reference = list("plantconnectors")
)]
}
# Object-list property missing in HeatPump:PlantLoop:EIR:Cooling A9 since
# v9.3
# See https://github.com/NREL/EnergyPlus/issues/7837
if (idd_version >= "9.3") {
id_clg <- dt_class[J("HeatPump:PlantLoop:EIR:Cooling"), on = "class_name", class_id]
dt_field[J(id_clg, 7L), on = c("class_id", "field_index"), `:=`(
object_list = list("plhpheatingnames"),
is_name = FALSE, reference = list(NULL)
)]
}
# extract field reference map
dt <- parse_field_reference_table(dt_field)
dt_field <- dt$left
dt_reference <- dt$reference
list(version = idd_version, build = idd_build, group = dt_group,
class = dt_class, field = dt_field,
reference = dt_reference
)
}
# }}}
# parse_idf_file {{{
parse_idf_file <- function(path, idd = NULL, ref = TRUE, encoding = "unknown") {
# read IDF string and get version first to get corresponding IDD
idf_dt <- read_lines(path, encoding = encoding)
# delete blank lines
idf_dt <- idf_dt[!stri_isempty(string)]
idf_ver <- get_idf_ver(idf_dt)
if (has_ext(path, "ddy")) {
idd <- withCallingHandlers(get_idd_from_ver(idf_ver, idd),
eplusr_warning = function(w) invokeRestart("muffleWarning")
)
} else {
idd <- get_idd_from_ver(idf_ver, idd)
}
# get idd version and table
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)
# type enum
type_enum <- list(unknown = 0L, special = 1L, macro = 2L, comment = 3L,
object = 4L, object_value = 5L, value = 6L, value_last = 7L
)
# separate lines into bodies, and comments
idf_dt <- sep_idf_lines(idf_dt, type_enum)
# mark line types
idf_dt <- mark_idf_lines(idf_dt, type_enum)
# header options
dt <- sep_header_options(idf_dt, type_enum)
options <- dt$options
idf_dt <- dt$left
# object table
dt <- sep_object_table(idf_dt, type_enum, idd_env)
dt_object <- dt$object
idf_dt <- dt$left
# value table
dt_value <- get_value_table(idf_dt, idd_env)
# combine
list_idf <- list(options = options, object = dt_object, value = dt_value)
# update object name
dt_object <- update_object_name(dt_object, dt_value)
# 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(idd_env, dt_value, from, to)
# value reference map
if (ref) {
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),
src_object_id = integer(0L), src_value_id = integer(0L),
src_enum = integer(0L)
)
}
# remove unuseful columns
set(dt_value, NULL, setdiff(names(dt_value),
c("value_id", "value_chr", "value_num", "object_id", "field_id")), NULL
)
# column order
setcolorder(dt_object, c("object_id", "object_name", "object_name_lower", "comment", "class_id"))
setcolorder(dt_value, c("value_id", "value_chr", "value_num", "object_id", "field_id"))
list(version = idd_ver, options = options,
object = dt_object, value = dt_value, reference = dt_reference
)
}
# }}}
# get_idd_ver {{{
get_idd_ver <- function(idd_dt) {
ver_line <- idd_dt$string[[1L]]
if (!stri_startswith_fixed(ver_line, "!IDD_Version")) {
parse_error("idd", "No IDD version on 1st line", idd_dt[1L])
} else {
ver <- standardize_ver(stri_sub(ver_line, 14L))
if (is.na(ver)) parse_error("idd", "Invalid IDD version on 1st line", idd_dt[1L])
ver
}
}
# }}}
# get_idd_build {{{
get_idd_build <- function(idd_dt) {
build_line <- idd_dt$string[[2L]]
if (!stri_startswith_fixed(build_line, "!IDD_BUILD")) {
NA_character_
} else {
stri_sub(build_line, 12L)
}
}
# }}}
# get_idf_ver {{{
get_idf_ver <- function(idf_dt) {
is_ver <- stri_startswith_fixed(idf_dt$string, "Version",
opts_fixed = stringi::stri_opts_fixed(case_insensitive = TRUE)
)
ver_line_spe <- idf_dt[is_ver]
ver_line_nor <- idf_dt[which(is_ver) + 1L]
reg_ver <- "(\\d+\\.\\d+(?:\\.\\d+)*)"
set(ver_line_spe, NULL, "version",
stri_match_first_regex(
ver_line_spe$string, paste0("Version\\s*,\\s*", reg_ver, "\\s*;(?:\\s*!.*)*$"),
opts_regex = stringi::stri_opts_regex(case_insensitive = TRUE)
)[, 2L]
)
set(ver_line_nor, NULL, "version", stri_match_first_regex(ver_line_nor$string, paste0("^", reg_ver, "\\s*;"))[, 2L])
ver_line <- rbindlist(list(ver_line_spe, ver_line_nor), use.names = FALSE)[!is.na(version)]
if (!nrow(ver_line)) {
NULL
} else if (nrow(ver_line) == 1L) {
ver <- standardize_ver(ver_line$version, complete = FALSE)
if (is.na(ver)) parse_error("idf", "Invalid IDF version found", ver_line, subtype = "ver")
attr(ver, "line") <- ver_line$line
ver
} else {
parse_error("idf", "Multiple IDF versions found", ver_line, subtype = "ver")
}
}
# }}}
# clean_idd_lines {{{
clean_idd_lines <- function(dt) {
# trucate to characters left of ! in order to handle cases when there are
# inline comments starting with "!", e.g.
# "GrouhdHeatTransfer:Basement:EquivSlab, ! Supplies ..."
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]
dt
}
# }}}
# sep_idd_lines {{{
sep_idd_lines <- function(dt, col = "string") {
# mark first slash
set(dt, NULL, "slash_loc", stri_locate_first_fixed(dt$string, "\\")[, 1L])
setindexv(dt, "slash_loc")
# separate field and slash
dt[J(NA_integer_), on = "slash_loc", `:=`(body = string)]
# also remove slash and delete extra spaces, like "\ group Hybrid Model"
dt[!J(NA_integer_), on = "slash_loc", `:=`(
body = stri_trim_right(stri_sub(string, to = slash_loc - 1L)),
slash = stri_trim_left(stri_sub(string, slash_loc + 1L))
)]
# 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))
)]
setindexv(dt, "slash_key")
# a) for logical slash key, e.g. "\required-field"
dt[J(IDD_SLASHKEY$type$lgl), on = "slash_key", `:=`(slash_value = "TRUE")]
# 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]+)?|Inf)"))
]
# change all values of reference, object-list and refercne-class-name to
# lower case
dt[J(c("reference", "reference-class-name", "object-list")), on = "slash_key",
`:=`(slash_value = stri_trans_tolower(slash_value))
]
# check for mismatched object-list and reference
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_error("idd", "Invalid \\object-list value", dt[invld_objlst],
post = "Neither paired \\reference nor \\reference-class-name exist for \\object-list above."
)
}
# 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_error("idd", "Invalid slash key", dt[invld_key])
# check invalid slash value {{{
set(dt, NULL, "slash_value_lower", stri_trans_tolower(dt[["slash_value"]]))
# check invalid \format value
invld_val <- which(dt$slash_key == "format" &
!dt$slash_value_lower %chin% c("singleline", "vertices",
"compactschedule", "fluidproperty", "viewfactor", "spectral")
)
if (length(invld_val))
parse_error("idd", "Invalid format value", dt[invld_val])
# check invalid \type value
invld_val <- which(
dt$slash_key == "type" &
!dt$slash_value_lower %chin% c("integer", "real", "alpha", "choice",
"object-list", "external-list", "node")
)
if (length(invld_val))
parse_error("idd", "Invalid type value", dt[invld_val])
# check invalid \external-list value
invld_val <- which(
dt$slash_key == "external-list" &
!dt$slash_value_lower %chin% c("autorddvariable", "autorddmeter", "autorddvariablemeter")
)
if (length(invld_val))
parse_error("idd", "Invalid external list value", dt[invld_val])
# }}}
set(dt, NULL, c("slash", "slash_loc", "space_loc", "slash_value_lower"), NULL)
dt
}
# }}}
# mark_idd_lines {{{
mark_idd_lines <- function(dt, type_enum) {
setindexv(dt, "slash_key")
# add type indicator
set(dt, NULL, "type", type_enum$unknown)
set(dt, NULL, "semicolon", stri_endswith_fixed(dt$body, ";"))
setindexv(dt, "slash_key")
# mark slash lines
dt[stri_isempty(body), `:=`(type = type_enum$slash)]
# mark group
dt[J("group"), on = "slash_key", `:=`(type = type_enum$group)]
# mark class
# cannot use empty slash_key as an indicator because in some versions, class
# slash may in the same line as class names
dt[stri_endswith_fixed(body, ","), `:=`(type = type_enum$class)]
# mark field
dt[stri_detect_regex(body, "^([AN]\\d+\\s*,\\s*)+|(([AN]\\d+\\s*,\\s*)*[AN]\\d+\\s*;)$"),
`:=`(type = type_enum$field)
]
# mark last field per class
dt[J(type_enum$field, TRUE), on = c("type", "semicolon"), `:=`(type = type_enum$field_last)]
# ignore section if exists, e.g. "Simulation Data;"
dt <- dt[!J(TRUE, type_enum$unknown), on = c("semicolon", "type")]
# if there are still known lines, throw an error
if (any(dt$type == type_enum$unknown)) {
parse_error("idd", "Invalid line", dt[type == type_enum$unknown])
}
set(dt, NULL, "semicolon", NULL)
}
# }}}
# sep_group_table {{{
sep_group_table <- function(dt, type_enum) {
setindexv(dt, "type")
is_group <- dt[J(type_enum$group), on = "type", which = TRUE, nomatch = 0L]
dt[is_group, `:=`(group_id = seq_along(slash_key), group_name = slash_value)]
dt_group <- dt[is_group, .SD, .SDcols = c("group_id", "group_name", "line")]
# assign default group if necessary
if (!nrow(dt_group)) {
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"))
dt_group <- data.table(group_id = 1L, group_name = "Default Group", line = 0L)
}
# check missing group
if (any(dt$line < dt_group$line[1L])) {
invld_grp <- dt[line < dt_group$line[1L]]
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")]
dt_group <- rbindlist(list(
data.table(group_id = 1L, group_name = "Default Group", line = 0L),
dt_group[, `:=`(group_id = group_id + 1L)]
))
}
set(dt_group, NULL, "line", NULL)
# fill downwards
dt[, `:=`(group_id = group_id[1L]), by = cumsum(!is.na(group_id))]
# remove group lines
dt <- dt[!J(type_enum$group), on = "type", .SD, .SDcols = !"group_name"]
list(left = dt, group = dt_group)
}
# }}}
# sep_class_table {{{
sep_class_table <- function(dt, type_enum) {
setindexv(dt, "type")
dt[J(type_enum$class), on = "type", `:=`(
class_id = seq_along(body),
class_name = stri_trim_right(stri_sub(body, to = -2L))
)]
# check duplicated class names
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_error("idd", "Duplicated class names found", invld_cls, length(dup_cls))
}
# fill downwards
dt[, `:=`(class_id = class_id[1L], class_name = class_name[1L]), by = cumsum(!is.na(class_id))]
# check missing class name
if (anyNA(dt$class_id)) {
invld_cls <- dt[is.na(class_id)]
parse_error("idd", "Missing class name", invld_cls, invld_cls[type == type_enum$field_last, .N])
}
# add expected type indicator
set(dt, NULL, "type_exp", dt$type)
dt[J(c(type_enum$field, type_enum$field_last)), on = "type", `:=`(type_exp = type_enum$field)]
l <- dt[J(c(type_enum$field, type_enum$field_last)), on = "type", line[.N], by = class_id, nomatch = 0L]$V1
dt[J(l), on = "line", `:=`(type_exp = type_enum$field_last)]
setindexv(dt, c("type", "type_exp"))
# check missing class name
mis_cls <- dt[J(type_enum$field_last, type_enum$field), on = c("type", "type_exp"), nomatch = 0L]
if (nrow(mis_cls)) {
invld_cls <- dt[class_id %in% mis_cls$class_id]
invld_cls[, `:=`(line_s = line)]
invld_cls <- invld_cls[
invld_cls[, list(line_s = line[1L] + 1L), by = class_id],
on = list(class_id, line_s > line_s)
]
if (invld_cls[.N, type] == type_enum$field_last) {
n <- invld_cls[type == type_enum$field_last, .N]
} else {
n <- invld_cls[type == type_enum$field_last, .N] + 1L
}
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_error("idd", "Incomplete class", invld_cls, length(incomp_cls))
}
# after checking possible errors, resign type
dt[J(type_enum$field_last), on = "type", `:=`(type = type_enum$field)]
# line when class starts
s <- dt[, list(start = line[1L]), by = class_id]
# line when class slash ends
e <- dt[J(type_enum$field), on = "type", list(end = line[1L] - 1L), by = class_id, nomatch = 0L]
# join
i <- merge(s, e, by = "class_id", all = TRUE)
# manually add "\format" if there is no slash in class
if (any(same <- i$start == i$end)) {
setindexv(dt, "class_id")
# in case that class slash is on the same line as clas name
ins <- dt[J(i[same, class_id], NA_character_), on = c("class_id", "slash_key"), mult = "first", nomatch = 0L]
ins[, `:=`(
string = "\\format standard",
body = "format standard",
slash_key = "format",
slash_value = "standard",
type = type_enum$slash,
line = line + 1L
)]
# insert
dt <- rbindlist(list(ins, dt))
setorderv(dt, "line")
# change added line number
dt[dt[J(ins$class_id), on = "class_id", .I[2L], by = class_id, nomatch = 0L]$V1,
`:=`(line = line - 1L)]
}
setindexv(dt, "line")
# get table
dt_class <- i[dt, on = list(class_id, start <= line, end >= line),
nomatch = 0L][!J(NA_character_), on = "slash_key", .SD,
.SDcols = -c("string", "body", "type", "type_exp", "end")]
dt <- dt[!J(c(dt_class$start, s$start)), on = "line", .SD,
.SDcols = -c("line", "string", "type_exp", "group_id", "class_name")]
set(dt_class, NULL, "start", NULL)
list(left = dt, class = dt_class)
}
# }}}
# get_field_table {{{
get_field_table <- function(dt, type_enum) {
# add row indicator
set(dt, NULL, "row", seq_len(nrow(dt)))
setindexv(dt, "type")
# count field number per line
dt[J(type_enum$field), on = "type", `:=`(field_count = stri_count_charclass(body, "[,;]"))]
set(dt, NULL, "type", NULL)
setindexv(dt, "field_count")
# get all slash lines
slsh <- dt[J(NA_integer_), on = "field_count", nomatch = 0L]
set(slsh, NULL, "field_count", NULL)
set(slsh, NULL, "field_anid", NA_character_)
# get all single field lines
sgl <- dt[J(1L), on = "field_count", nomatch = 0L]
set(sgl, NULL, "field_count", NULL)
sgl[, `:=`(field_anid = stri_trim_right(stri_sub(body, to = -2L)))]
# get all condensed field lines
con <- dt[field_count > 1L]
set(con, NULL, "field_count", NULL)
# split fields and slashes
## hats off to Matt Dowle:
## https://stackoverflow.com/questions/15673662/applying-a-function-to-each-row-of-a-data-table
con <- con[, {
s <- stri_split_charclass(body, "[,;]", omit_empty = TRUE)
l <- vapply(s, length, integer(1L))
list(
row = rep(row, l),
body = rep(body, l),
class_id = rep(class_id, l),
slash_key = rep(slash_key, l),
slash_value = rep(slash_value, l),
field_anid = stri_trim_both(unlist(s))
)
}]
# combine
dt_field <- setorderv(rbindlist(list(slsh, sgl, con), use.names = TRUE), "row")
# fill downwards id and anid
set(dt_field, NULL, "id", seq_len(nrow(dt_field)))
left <- dt_field[!is.na(field_anid),
list(id, field_id = .I, field_anid = stri_trans_toupper(field_anid))
]
set(dt_field, NULL, "field_anid", NULL)
dt_field <- left[dt_field, on = "id", roll = TRUE]
set(dt_field, NULL, "id", NULL)
dt_field
}
# }}}
# dcast_slash {{{
dcast_slash <- function(dt, id, keys, keep = NULL) {
if (!is.null(keep)) assert_names(names(dt), must.include = keep)
f <- stats::as.formula(paste0(paste0(id[[1L]], collapse = "+"), "~slash_key"))
setindexv(dt, "slash_key")
setindexv(dt, c(id[[1L]], "slash_key"))
i <- unique(dt[, .SD, .SDcols = c(id, keep)], by = c(id[[1L]]))
setindexv(i, 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")
# combine
if (nrow(flat) && nrow(nest)) {
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)) {
nest[i, on = c(id[[1L]])]
} else if (!nrow(nest)) {
flat[i, on = c(id[[1L]])]
} else {
dt[0L, .SD, .SDcols = c(id, keep)]
}
}
# }}}
# complete_property {{{
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)
# get slash type from slash key
slash_type <- function(key) {
types <- IDD_SLASHKEY$type
chk <- vapply(types, function(type) key %in% type, logical(1L))
names(types)[chk]
}
# get slash type checking function from slash key
slash_is_type <- function(key) {
switch(slash_type(key), lgl = is.logical, int = is.integer, dbl = is.double,
chr = is.character, lst = is.list)
}
# get slash type conversion function from slash key
slash_as_type <- function(key) {
switch(slash_type(key), lgl = as.logical, int = as.integer, dbl = as.double,
chr = as.character, lst = c)
}
# get slash initial value from slash key
slash_init_value <- function(key) {
res <- switch(slash_type(key), lgl = "FALSE", lst = list(), NA_character_)
slash_as_type(key)(res)
}
# 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]])) {
set(dt, NULL, key, slash_as_type(key)(dt[[key]]))
set(dt, seq_len(nrow(dt))[is.na(dt[[key]])], key, slash_init_value(key))
}
}
# add missing property columns if necessary
cols <- unlist(keys, use.names = FALSE)
if (!epw) cols <- setdiff(cols, c("missing", "exist-minimum", "exist-minimum>", "exist-maximum", "exist-maximum<"))
for (key in cols) {
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, epw = epw)
)
dt
}
# }}}
# parse_class_property {{{
parse_class_property <- function(dt, ref) {
# rename column names to lower case
nms <- stri_replace_all_fixed(names(dt), "-", "_")
setnames(dt, nms)
dt[is.na(format), `:=`(format = "standard")]
dt[is.na(min_fields), `:=`(min_fields = 0L)]
dt[is.na(extensible), `:=`(extensible = 0L)]
# rename
setnames(dt, "extensible", "num_extensible")
# get max field per class
set(dt, NULL, "num_fields", ref[, .N, by = class_id]$N)
# add `has_name`
set(dt, NULL, "has_name", ref[, any(is_name), by = class_id]$V1)
# add info about the index of last required field
set(dt, NULL, "last_required",
ref[required_field == TRUE, field_index[.N], by = list(class_id)][
J(dt$class_id), on = "class_id"][is.na(V1), `:=`(V1 = 0L)]$V1
)
# add first extensible index
set(dt, NULL, "first_extensible",
ref[extensible_group == 1L, field_index[1L], by = list(class_id)][
J(dt$class_id), on = "class_id"][is.na(V1), `:=`(V1 = 0L)]$V1
)
# add num of extensible group
set(dt, NULL, "num_extensible_group", 0L)
dt[num_extensible > 0L, `:=`(
num_extensible_group = (num_fields - first_extensible + 1L) %/% num_extensible
)]
# add underscore class names
set(dt, NULL, "class_name_us", underscore_name(dt$class_name))
# only keep useful columns
ignore <- setdiff(names(dt), unlist(CLASS_COLS, use.names = FALSE))
if (length(ignore) > 0L) set(dt, NULL, ignore, NULL)
setcolorder(dt, unlist(CLASS_COLS, use.names = FALSE))
dt
}
# }}}
# parse_field_property {{{
parse_field_property <- function(dt, ref, epw = FALSE) {
# rename column names to lower case
nms <- stri_replace_all_fixed(names(dt), "-", "_")
setnames(dt, nms)
# complete types
dt[is.na(type) & stri_startswith_fixed(field_anid, "A"), `:=`(type = "alpha")]
dt[is.na(type) & stri_startswith_fixed(field_anid, "N"), `:=`(type = "real")]
# add field index
set(dt, NULL, "field_index", rowidv(dt, "class_id"))
# transform all type values to lower-case
set(dt, NULL, "type", stri_trans_tolower(dt[["type"]]))
# add an integer-based field type column
t <- stri_replace_all_fixed(names(IDDFIELD_TYPE), "_", "-")
names(t) <- IDDFIELD_TYPE
set(dt, NULL, "type_enum", as.integer(chmatch(dt$type, t)))
# rename column `key` to `choice`
setnames(dt, "key", "choice")
# add extensible indicator
dt <- parse_field_property_extensible_group(dt, ref)
# parse field name
dt <- parse_field_property_name(dt)
# parse field range
dt <- parse_field_property_range(dt)
# 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)))
col_ref <- c("reference", "reference_class_name", "object_list")
# only keep useful columns
ignore <- setdiff(names(dt), c(unlist(FIELD_COLS, use.names = FALSE), col_ref))
if (length(ignore) > 0L) set(dt, NULL, ignore, NULL)
setcolorder(dt, intersect(unlist(FIELD_COLS, use.names = FALSE), names(dt)))
dt
}
# }}}
# parse_field_property_extensible_group {{{
parse_field_property_extensible_group <- function(dt, ref) {
ext <- dt[begin_extensible == TRUE, list(class_id, field_index)]
# only count once
ext <- ext[, list(first_extensible = field_index[1L]), by = class_id]
# handle the case when there is no extensible fields
if (!has_names(ref, "extensible") || !nrow(ext)) {
set(dt, NULL, "extensible_group", 0L)
return(dt)
}
# add extensible field number
ext <- ref[, list(class_id, num_extensible = as.integer(extensible))][ext, on = "class_id"]
# NOTE: few chances are classes not marked as extensible but with extensible fields
ext <- ext[!J(NA_integer_), on = "num_extensible"]
# add total field number
set(ext, NULL, "num_fields", dt[ext, on = "class_id", .N, by = class_id]$N)
# add total extensible group number
set(ext, NULL, "num_group", 0L)
# exclude incomplete groups
ext[, `:=`(num_group = as.integer((num_fields - first_extensible + 1L) / num_extensible))]
# add field extensible group number
ext[, `:=`(extensible_group = list(
c(rep(0L, first_extensible - 1L), rep(seq_len(num_group), each = num_extensible))
)),
by = class_id
]
ext <- ext[, {
n <- num_group * num_extensible + (first_extensible - 1L)
group <- unlist(extensible_group)
id <- rep(class_id, n)
index <- unlist(lapply(n, seq_len))
list(class_id = id, field_index = index, extensible_group = group)
}]
# insert into the main dt
dt[ext, on = c("class_id", "field_index"), `:=`(extensible_group = ext$extensible_group)]
dt[is.na(extensible_group), `:=`(extensible_group = 0L)]
dt
}
# }}}
# parse_field_property_name {{{
parse_field_property_name <- function(dt) {
# add name indicator
set(dt, NULL, "is_name", FALSE)
## name fields:
## a) fields with name equal to "Name" with type being "alpha" or "node"
## b) fields can be referenced and does not reference others
dt[
(field == "Name" & type %chin% c("alpha", "node")) |
(!vlapply(reference, is.null) & vlapply(object_list, is.null)),
`:=`(is_name = TRUE)
]
# fill missing ip units
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)]
setnames(dt, "si_name", "units")
set(dt, NULL, "ip_name", NULL)
dt[is.na(ip_units) & ip_units == "unknown", `:=`(ip_units = units)]
# add field names
setnames(dt, "field", "field_name")
dt[is.na(field_name), `:=`(field_name = field_anid)]
dt
}
# }}}
# parse_field_property_default {{{
parse_field_property_default <- function(dt) {
set(dt, NULL, "default_num", NA_real_)
set(dt, NULL, "default_chr", dt$default)
dt[type_enum <= IDDFIELD_TYPE$real, `:=`(default_num = suppressWarnings(as.double(default)))]
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)
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_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
}
# }}}
# parse_field_reference_table {{{
parse_field_reference_table <- function(dt) {
# mark source type
set(dt, NULL, "src_enum", IDDFIELD_SOURCE$none)
setindexv(dt, "field_id")
# for \object-list
obj_fld <- dt[, {
l <- vapply(object_list, length, integer(1L))
# handle the case when there is no \object-list
obj_lst <- if (all(l == 0L)) character(0) else unlist(object_list)
list(
class_id = rep(class_id[l > 0L], l[l > 0L]),
field_id = rep(field_id[l > 0L], l[l > 0L]),
object_list = obj_lst
)
}]
# fix errors when object-list fields having an type of "alpha"
dt[obj_fld, on = "field_id", `:=`(type = "object-list", type_enum = IDDFIELD_TYPE$object_list)]
# for \reference-class-name
ref_cls <- dt[, {
l <- vapply(reference_class_name, length, integer(1L))
# handle the case when there is no \reference-class-name
enum <- {if (all(l == 0L)) integer(0) else IDDFIELD_SOURCE$class}
dt[J(field_id[l > 0L]), on = "field_id", src_enum := IDDFIELD_SOURCE$class]
list(
reference = unlist(reference_class_name),
src_field_id = rep(field_id[l > 0L], l[l > 0L]),
src_class_id = rep(class_id[l > 0L], l[l > 0L]),
src_enum = enum
)
}]
# for \reference
ref_fld <- dt[, {
l <- vapply(reference, length, integer(1L))
fld <- l > 0L
mx <- fld & src_enum == IDDFIELD_SOURCE$class
src_enum[fld] <- IDDFIELD_SOURCE$field
dt[J(field_id[fld]), on = "field_id", src_enum := IDDFIELD_SOURCE$field]
dt[J(field_id[mx]), on = "field_id", src_enum := IDDFIELD_SOURCE$mixed]
list(
reference = unlist(reference[fld]),
src_field_id = rep(field_id[fld], l[fld]),
src_class_id = rep(class_id[fld], l[fld]),
src_enum = rep(src_enum[fld], l[fld])
)
}]
# handle the case when there is neither no \reference nor \reference-class-name
if (nrow(ref_fld) == 0L && nrow(ref_cls) == 0L) {
return(list(
left = dt,
reference = data.table(
class_id = integer(0), field_id = integer(0),
src_class_id = integer(0), src_field_id = integer(0),
src_enum = integer(0)
)
))
}
# combine \reference and \reference-class-name
refs <- rbindlist(list(ref_fld, ref_cls), fill = TRUE)
# combine object list and reference
obj_ref <- refs[obj_fld, on = list(reference = object_list), allow.cartesian = TRUE]
set(obj_ref, NULL, "reference", NULL)
setcolorder(obj_ref, c("class_id", "field_id", "src_class_id", "src_field_id", "src_enum"))
# remove unuseful columns
set(dt, NULL, c("object_list", "reference", "reference_class_name"), NULL)
list(left = dt, reference = obj_ref)
}
# }}}
# sep_idf_lines {{{
sep_idf_lines <- function(dt, type_enum) {
# mark location of first occurrence "!" and "!-"
dt[, `:=`(excl_loc = stri_locate_first_fixed(string, "!")[, 1L])]
dt[, `:=`(spcl_loc = stri_locate_first_fixed(string, "!-")[, 1L])]
setindexv(dt, c("excl_loc", "spcl_loc"))
# sep values and comments
dt[is.na(excl_loc), `:=`(body = string, comment = "")]
dt[!is.na(excl_loc), `:=`(
body = stri_trim_right(stri_sub(string, to = excl_loc - 1L)),
comment = stri_sub(string, excl_loc + 1L)
)]
dt[excl_loc <= spcl_loc, `:=`(excl_loc = NA_integer_)]
dt[is.na(excl_loc) & !is.na(spcl_loc), `:=`(comment = stri_trim_left(stri_sub(comment, 2L)))]
set(dt, NULL, c("excl_loc", "spcl_loc"), NULL)
dt
}
# }}}
# mark_idf_lines {{{
mark_idf_lines <- function(dt, type_enum) {
# add type indicator
set(dt, NULL, "type", type_enum$unknown)
setindexv(dt, "type")
# macro line
l_m <- dt[stri_startswith_fixed(string, "#"), which = TRUE]
if (length(l_m)) {
dt[l_m, c("type", "body", "comment") :=({
macro <- stri_split_fixed(string, " ", n = 2L, omit_empty = TRUE, simplify = TRUE)[, 1L]
is_m <- macro %in% MACRO_DICT
if (any(is_m)) {
type[is_m] <- type_enum$macro
body[is_m] <- ""
comment <- string
}
list(type, body, comment)
})]
if (nrow(dt[type == type_enum$macro])) {
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 ",
"the nearest downwards object."
)
)
}
}
# normal comments
dt[stri_startswith_fixed(string, "!"), `:=`(type = type_enum$comment)]
# special comments
dt[stri_startswith_fixed(string, "!-"), `:=`(type = type_enum$special)]
# mark values in object
dt[stri_endswith_fixed(body, ","), `:=`(type = type_enum$value)]
# mark last value in object
dt[stri_endswith_fixed(body, ";"), `:=`(type = type_enum$value_last)]
# if there are still known lines, throw an error
if (nrow(dt[type == type_enum$unknown]) > 0L) {
parse_error("idf", "Invalid line found", dt[type == type_enum$unknown], subtype = "line")
}
dt
}
# }}}
# sep_header_options {{{
sep_header_options <- function(dt, type_enum) {
dt_opt <- dt[J(type_enum$special), on = "type"]
dt <- dt[!dt_opt, on = "line"]
s <- stri_split_fixed(dt_opt[['comment']], " ", n = 2, simplify = TRUE)
set(dt_opt, NULL, "header", stri_trans_tolower(s[, 1L]))
set(dt_opt, NULL, "value", stri_trans_tolower(s[, 2L]))
# all available options
opts <- list(
generator = c(idf_editor = "idfeditor"),
option = c(
special_format = "usespecialformat",
view_in_ip = "viewinipunits",
sorted = "sortedorder",
new_top = "originalordertop",
new_bot = "originalorderbottom"
)
)
# helper
get_option <- function(header, value) {
if (header %in% names(opts)) {
opt <- opts[[header]]
vals <- stri_split_fixed(value, " ", omit_empty = TRUE)[[1L]]
names(opt)[opt %in% vals]
}
}
# only parse lines with valid headers
dt_opt <- dt_opt[header %in% names(opts)]
opt <- list(idf_editor = FALSE, special_format = FALSE, view_in_ip = FALSE,
save_format = "sorted")
res <- list(left = dt, options = opt)
if (!nrow(dt_opt)) return(res)
out <- unlist(dt_opt[, `:=`(options = list(get_option(header, value))), by = line]$options)
if (!length(out)) return(res)
save_format <- c("sorted", "new_top", "new_bot")
for (lgl in setdiff(out, save_format)) res$options[[lgl]] <- TRUE
sf <- save_format[save_format %in% out][1L]
if (!is.na(sf)) res$options$save_format <- sf
res
}
# }}}
# sep_object_table {{{
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]
# check incomplete object
incomp_obj <- dt[is.na(object_id) & type >= type_enum$value]
if (nrow(incomp_obj)) {
parse_error("idf", "Incomplete object", dt[is.na(object_id)], 1L, subtype = "object")
}
# extract class names
dt[dt[type >= type_enum$value, .I[1L], by = list(object_id)]$V1,
c("type", "class_name_lower", "body") :=({
n <- stri_locate_first_fixed(body, ",")[, 1L]
# in case there are invalid class names ends with semicolon
n[is.na(n)] <- 0L
l <- stri_length(body)
class_name_lower <- stri_trim_right(stri_trans_tolower(stri_sub(body, to = n - 1L)))
body[n < l] <- stri_trim_left(stri_sub(body[n < l], n[n < l] + 1L))
type[n < l] <- type_enum$object_value
type[n == l] <- type_enum$object
list(type, class_name_lower, body)
})
]
# add class id and name
set(idd$class, NULL, "class_name_lower", stri_trans_tolower(idd$class$class_name))
dt[!is.na(class_name_lower), c("class_id", "class_name", "group_id") := ({
nm_in <- class_name_lower
cls <- idd$class[J(nm_in), on = "class_name_lower"]
list(cls$class_id, cls$class_name, cls$group_id)
})]
set(idd$class, NULL, "class_name_lower", NULL)
# check for version {{{
id_ver <- dt[class_name == "Version", object_id]
# if multiple version found, stop
if (length(id_ver) > 1L) {
parse_error("idf", "Multiple IDF versions found", dt[object_id %in% id_ver], length(id_ver), subtype = "ver")
}
# }}}
# check invalid class name
invld_obj <- dt[is.na(class_id) & !is.na(class_name_lower)]
if (nrow(invld_obj)) {
parse_error("idf", "Invalid class name", invld_obj, subtype = "class")
}
# fill class id and class name
left <- dt[!is.na(class_id), list(line, class_id, class_name, group_id)]
set(dt, NULL, c("class_id", "class_name", "group_id", "class_name_lower"), NULL)
dt_cmt <- left[dt[type < type_enum$value], on = "line", roll = -Inf]
dt_val <- left[dt[type > type_enum$comment], on = "line", roll = Inf]
dt <- setorderv(rbindlist(list(dt_cmt, dt_val)), "line")
# lines with type "object" and "object_value" are duplicated
dt <- unique(dt)
# get table
dt_object <- dt[type <= type_enum$object_value, .SD, .SDcols = c("object_id", "class_id", "comment", "type")]
# clean comment
clean_comment <- function(x, type) {
x <- x[type == type_enum$comment]
if (!length(x)) NULL else x
}
dt_object <- dt_object[,
list(class_id = class_id[1L], comment = list(clean_comment(comment, type))),
by = object_id
]
# if trailing comments are found, give message
if (dt_object[.N, is.na(class_id)]) dt_object <- dt_object[-.N]
dt <- dt[type > type_enum$object]
# remove unuseful columns
set(dt, NULL, c("class_name", "group_id", "type", "comment"), NULL)
list(left = dt, object = dt_object)
}
# }}}
# get_value_table {{{
get_value_table <- function(dt, idd, escape = FALSE) {
# count value number per line
set(dt, NULL, "value_count", stri_count_fixed(dt$body, ",") + stri_endswith_fixed(dt$body, ";"))
# in case there are multiple semicolon in one line
if (any(stri_count_fixed(dt$body, ";") > 1L) && !escape) {
parse_error("idf", "Invalid line found", dt[stri_count_fixed(body, ";") > 1L], subtype = "line")
}
setindexv(dt, "value_count")
# get all comments and single value lines
sgl <- dt[value_count < 2L]
set(sgl, NULL, "value_count", NULL)
set(sgl, NULL, "value_chr", stri_trim_right(stri_sub(sgl$body, to = -2L)))
# get all condensed value lines
con <- dt[value_count > 1L]
# split values
con <- con[, {
s <- stri_split_charclass(body, "[,;]", n = value_count, omit_empty = NA, tokens_only = TRUE)
l <- vapply(s, length, integer(1L))
list(
line = rep(line, l),
body = rep(body, l),
string = rep(string, l),
object_id = rep(object_id, l),
class_id = rep(class_id, l),
value_chr = stri_trim_both(unlist(s))
)
}]
# combine
dt <- setorderv(rbindlist(list(sgl, con), use.names = TRUE), "line")
# add value id
set(dt, NULL, "value_id", seq_len(nrow(dt)))
# add field index
set(dt, NULL, "field_index", rowidv(dt, "object_id"))
left <- idd$class[, list(class_id, num_extensible, num_fields)]
ext <- dt[left, on = list(class_id, field_index > num_fields), nomatch = 0L]
setnames(ext, "field_index", "num_fields")
# replace empty value with NA
dt[stri_isempty(value_chr), `:=`(value_chr = NA_character_)]
# in order to get the object id with wrong field number
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_max$class_id, dt_max$field_index,
c("type_enum", "src_enum", "is_name", "units", "ip_units"),
complete = TRUE
),
eplusr_error_invalid_field_index = function(e) e
)
# issue parse error if invalid field number found
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
obj <- dt_max[invld, on = c("class_id", field_index = "field_in")]$object_id
# modify message
msg <- gsub(" *#\\d+\\|", "-->", gsub("index", "number", fld$message))
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)
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)))]
# add numeric type values
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",
"is_name", "type_enum", "src_enum", "class_name", "units", "ip_units"
)
ignore <- setdiff(names(dt), nms)
if (length(ignore) > 0L) set(dt, NULL, ignore, NULL)
setcolorder(dt, nms)
dt
}
# }}}
# update_object_name {{{
update_object_name <- function(dt_object, dt_value) {
if (!nrow(dt_value)) return(dt_object)
dt_nm <- dt_value[is_name == TRUE,
list(object_name = value_chr, object_name_lower = stri_trans_tolower(value_chr)),
by = "object_id"]
if (!nrow(dt_nm)) {
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 = i.object_name, object_name_lower = i.object_name_lower)]
dt_object
}
# }}}
# convert_value_unit {{{
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 <- 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"))
val[, c("value_num") :=
{
s <- units::set_units(value_num, get(from)[1L], mode = "standard")
s <- units::set_units(s, get(to)[1L], mode = "standard")
units::drop_units(s)
},
by = list(si, ip)
]
dt_value[val, on = "value_id", `:=`(value_num = i.value_num, value_chr = as.character(i.value_num))]
dt_value
}
# }}}
# 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)
# }}}
# 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 <- val_src[J(IDDFIELD_SOURCE$class), on = "src_enum", nomatch = 0L,
list(
src_object_id = object_id,
src_field_id = field_id,
src_value_id = value_id,
src_value_chr = class_name,
src_enum
)
]
# b) reference field values
fld_src <- val_src[J(IDDFIELD_SOURCE$field), on = "src_enum", nomatch = 0L,
list(
src_object_id = object_id,
src_field_id = field_id,
src_value_id = value_id,
src_value_chr = value_chr,
src_enum
)
]
# c) reference both class names and field values
## seperate source enum here
mix_src <- val_src[J(IDDFIELD_SOURCE$mixed), on = "src_enum", nomatch = 0L,
{
list(
src_object_id = c(object_id, object_id),
src_field_id = c(field_id, field_id),
src_value_id = c(value_id, value_id),
src_value_chr = c(value_chr, class_name),
src_enum = rep(c(IDDFIELD_SOURCE$field, IDDFIELD_SOURCE$class), each = .N)
)
}
]
# combine
val_src <- rbindlist(list(cls_src, fld_src, mix_src))
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"),
allow.cartesian = TRUE, list(object_id, value_id, src_object_id, src_value_id, src_enum)]
# make sure every reference value has a corresponding source even NA
if (!all || nrow(ref) == nrow(val_ref)) return(ref)
ref[J(val_ref$object_id, val_ref$value_id), on = c("object_id", "value_id")]
}
# }}}
# parse_issue {{{
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)
mes <- NULL
if (is.data.frame(data)) {
if (is.null(num)) {
num <- nrow(data)
}
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) {
mes <- c(mes[1L:10L], "...[truncated. First 10 are shown.]")
}
mes <- cli::ansi_strtrim(mes)
}
if (stop) {
err_title <- paste0("[ Error Type ]: ", title)
err_num <- paste0("[Total Number]: ", num)
} else {
err_title <- paste0("[Warning Type]: ", title)
err_num <- paste0("[Total Number]: ", num)
}
if (!is.null(mes)) {
mes_rule <- cli::rule("Location", line = 1L)
mes_line <- paste(mes, sep = "\n", collapse = "\n")
} else {
mes_rule <- NULL
mes_line <- NULL
}
end_rule <- cli::rule(line = 2L)
if (!is.null(post)) {
# only show the first 10
if (length(post) > 10L) {
post <- c(post[1L:10L], "...[truncated. First 10 are shown.]")
}
post <- c(cli::rule("Detail", line = 1L), post)
}
all_mes <- paste0(c(start_rule, err_title, err_num, mes_rule, mes_line, post, end_rule),
collapse = "\n")
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(all_mes, c(subtype, type), data = data)
} else {
warn(all_mes, c(subtype, type), data = data)
}
}
# }}}
# insert_version {{{
insert_version <- function(x, ver) {
if (is.character(x)) {
paste0(x, "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
}
}
# }}}
# vim: set fdm=marker:
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.