Nothing
#' @importFrom cli cat_bullet cat_line cat_rule rule symbol
#' @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<-"
#' @importFrom stringi stri_subset_regex stri_match_first_regex stri_rand_strings
#' @include parse.R
NULL
# IDF OBJECT
# get_idfobj_value {{{
get_idfobj_value <- function(idd_env, idf_env, object, which = NULL, all = FALSE,
simplify = FALSE, unit = FALSE, underscore = FALSE) {
val <- get_idf_value(idd_env, idf_env, NULL, object, which, NULL, all = all, align = TRUE, underscore = underscore)
if (simplify) return(val$value_chr)
add_field_property(idd_env, val, "type_enum")
if (unit) add_field_property(idd_env, val, c("units", "ip_units"))
get_value_list(val, unit)
}
# }}}
# get_value_list {{{
#' @importFrom checkmate assert_names
get_value_list <- function(dt_value, unit = FALSE) {
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 &
!stri_trans_tolower(dt_value$value_chr) %chin% c("autosize", "autocalculate")
val <- dt_value$value_num
is_double <- dt_value$type_enum == IDDFIELD_TYPE$real
exists <- !is.na(val)
res[num & is_double] <- val[num & is_double]
res[num & !is_double] <- as.integer(val[num & !is_double])
if (any(unlist(res[exists & num & !is_double]) != val[exists & num & !is_double])) {
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."
), "warning_value_int_trunc"
)
}
if (unit) {
if (in_ip_mode()) {
prefix <- "ip"
input <- "ip_units"
} else {
prefix <- "si"
input <- "units"
}
u <- !is.na(dt_value[[input]]) & num
if (any(u)) {
col <- paste0(prefix, "_standard_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) {
units::set_units(val, unit, mode = "standard")
})
}
}
setattr(res, "names", dt_value$field_name)
res
}
# }}}
# get_idfobj_possible {{{
#' @importFrom checkmate assert_subset
get_idfobj_possible <- function(idd_env, idf_env, object, field = NULL,
type = c("auto", "default", "choice", "range", "source")) {
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")
if ("default" %chin% type) prop <- c(prop, "default_chr", "default_num")
if ("choice" %chin% type) prop <- c(prop, "choice")
if ("range" %chin% type) prop <- c(prop, "minimum", "lower_incbounds", "maximum", "upper_incbounds")
val <- get_idf_value(idd_env, idf_env, NULL, object, field, property = prop, align = TRUE)
# auto fields
if ("auto" %chin% type) {
val[J(TRUE), on = "autosizable", `:=`(auto = "Autosize")]
val[J(TRUE), on = "autocalculatable", `:=`(auto = "Autocalculate")]
set(val, NULL, c("autosizable", "autocalculatable"), NULL)
}
# default
if ("default" %chin% type) {
setnames(val, c("value_id", "value_chr", "value_num"),
c("ori_value_id", "ori_value_chr", "ori_value_num"))
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) {
set(val, NULL, "default", list(get_value_list(val)))
} else {
set(val, NULL, "default", get_value_list(val))
}
setnames(val, c("ori_value_id", "ori_value_chr", "ori_value_num"),
c("value_id", "value_chr", "value_num"))
}
# range
if ("range" %chin% type) {
val[, `:=`(range = list(ranger(minimum, lower_incbounds, maximum, upper_incbounds))), by = c("value_id")]
}
# source
if ("source" %chin% type) {
# handle NODE
node <- val[J(IDDFIELD_TYPE$node), on = "type_enum", nomatch = 0L, list(field_id)]
if (nrow(node)) {
add_field_property(idd_env, idf_env$value, "type_enum")
nodes <- idf_env$value[J(IDDFIELD_TYPE$node), on = "type_enum", unique(value_chr)]
set(idf_env$value, NULL, "type_enum", NULL)
set(node, NULL, "source", list(list(nodes)))
}
setnames(idf_env$value, "field_id", "src_field_id")
src <- get_idd_relation(idd_env, NULL, val$field_id, depth = 0L, direction = "ref_to")
src <- idf_env$value[src, on = c("src_field_id"), allow.cartesian = TRUE, nomatch = 0L]
# add class name in case of class-name reference
add_joined_cols(idd_env$class, src, c(src_class_id = "class_id"), c(src_class_name = "class_name"))
src[J(1L), on = "src_enum", `:=`(value_chr = src_class_name)]
src <- src[, list(source = list(value_chr)), by = "field_id"]
setnames(idf_env$value, "src_field_id", "field_id")
add_joined_cols(rbindlist(list(node, src), fill = TRUE), val, "field_id", "source")
}
res <- val[, .SD, .SDcols = c(
"class_id", "class_name", "object_id", "object_name",
"field_id", "field_index", "field_name",
"value_id", "value_chr", "value_num",
type
)]
setattr(res, "class", c("IdfValuePossible", class(res)))
res
}
# }}}
# get_idfobj_relation {{{
get_idfobj_relation <- function(idd_env, idf_env, object_id = NULL, value_id = NULL,
name = TRUE, direction = c("ref_to", "ref_by", "node", "all"),
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")
checkmate::assert_subset(direction, all_dir, FALSE)
rel <- list(ref_to = NULL, ref_by = NULL, node = NULL)
if ("all" %in% direction) direction <- unique(c(direction, all_dir))
if ("ref_to" %in% direction) {
rel$ref_to <- get_idf_relation(idd_env, idf_env, object_id = object_id, value_id,
depth = depth, name = name, direction = "ref_to", keep_all = keep_all,
object = object, class = class, group = group, class_ref = match.arg(class_ref)
)
}
if ("ref_by" %in% direction) {
rel$ref_by <- get_idf_relation(idd_env, idf_env, object_id = object_id, value_id,
depth = depth, name = name, direction = "ref_by", keep_all = keep_all,
object = object, class = class, group = group, class_ref = match.arg(class_ref)
)
}
if ("node" %in% direction) {
rel$node <- get_idf_node_relation(idd_env, idf_env, object_id = object_id, value_id,
name = name, keep_all = keep_all, depth = depth,
object = object, class = class, group = group
)
}
setattr(rel, "class", c("IdfRelation", class(rel)))
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 = "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
)
}
# }}}
# get_idfobj_string {{{
get_idfobj_string <- function(idd_env, idf_env, object_id, comment = TRUE, leading = 4L, sep_at = 29L, all = FALSE) {
val <- get_idf_value(idd_env, idf_env, object = object_id, property = c("units", "ip_units"), all = all)
cls <- paste0(val$class_name[[1L]], ",")
# get field value
fld <- format_field(val, leading = leading, sep_at = sep_at,
index = FALSE, blank = FALSE, end = TRUE, required = FALSE)
if (comment) {
id <- object_id
cmt <- idf_env$object[J(id), on = "object_id", comment][[1L]]
} else {
cmt <- NULL
}
if (!is.null(cmt)) cmt <- c(paste0("!", cmt), "")
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)
if (is.null(comment)) {
set(obj, NULL, "comment", list(list(NULL)))
} else {
comment <- as.character(comment)
assert_count(width)
cmt <- unlist(stri_split_fixed(comment, "\n", omit_empty = FALSE), 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.")
}
}
obj
}
# }}}
# 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.