289 lines
7.7 KiB
R
289 lines
7.7 KiB
R
# ---- Node Helper Functions ----
|
|
node_new <- function(nodes, hash, name, gap_y = 0.75, min_y = 1) {
|
|
# new nodes are added into the clickpad area but with x = -0.75
|
|
# need to check if there are other nodes in the holding space and adjust y
|
|
taken_y <- nodes %>% purrr::keep(~ !is.na(.$y)) %>% purrr::map_dbl(`[[`, "y")
|
|
new_y <- find_new_y(taken_y, gap_y, min_y)
|
|
nodes[[hash]] <- list(name = name, x = -0.75, y = new_y)
|
|
nodes
|
|
}
|
|
|
|
find_new_y <- function(y, gap_y = 0.75, min_y = 0.5) {
|
|
if (!length(y)) return(min_y)
|
|
if (min(y) >= (min_y + gap_y)) return(min_y)
|
|
if (length(y) == 1) return(y + gap_y)
|
|
|
|
y <- sort(y)
|
|
|
|
gap_size <- c(lead(y) - y)[-length(y)]
|
|
if (any(gap_size >= 2 * gap_y)) {
|
|
first_gap <- which(gap_size > 2 * gap_y)[1]
|
|
return(y[first_gap] + gap_y)
|
|
}
|
|
|
|
max(y) + gap_y
|
|
}
|
|
|
|
node_name_valid <- function(nodes, name, warn = FALSE) {
|
|
if (!nzchar(name)) {
|
|
warnNotification("Please specify a name for the node")
|
|
return(FALSE)
|
|
}
|
|
name_in_nodes <- vapply(nodes, function(n) name == n$name, FALSE)
|
|
if (any(name_in_nodes)) {
|
|
if (warn) warnNotification('"', name, '" is already the name of a node')
|
|
FALSE
|
|
} else {
|
|
TRUE
|
|
}
|
|
}
|
|
|
|
node_names <- function(nodes, all = FALSE) {
|
|
if (!length(nodes)) {
|
|
return(character())
|
|
}
|
|
x <- invertNames(sapply(nodes, function(x) x$name))
|
|
if (all) {
|
|
return(x)
|
|
}
|
|
in_dag <- sapply(nodes, function(n) n$x >= 0)
|
|
x[in_dag]
|
|
}
|
|
|
|
node_name_from_hash <- function(nodes, hash) {
|
|
invertNames(node_names(nodes))[hash]
|
|
}
|
|
|
|
node_update <- function(nodes, hash, name = NULL, x = NULL, y = NULL, name_latex = NULL) {
|
|
# in general update a property if arg is not null, default to current value
|
|
nodes[[hash]]$name <- name %||% nodes[[hash]]$name
|
|
nodes[[hash]]$x <- x %||% nodes[[hash]]$x
|
|
nodes[[hash]]$y <- y %||% nodes[[hash]]$y
|
|
# for name_latex precedence is arg > name (arg) > existing > name (existing)
|
|
nodes[[hash]]$name_latex <- name_latex %||% (
|
|
(name %??% name) %>% escape_quotes() %>% escape_latex()
|
|
) %||% nodes[[hash]]$name_latex %||% (
|
|
(nodes[[hash]]$name %??% nodes[[hash]]$name) %>% escape_quotes() %>% escape_latex()
|
|
)
|
|
nodes
|
|
}
|
|
|
|
node_set_attribute <- function(nodes, hash, attribs) {
|
|
for (node in names(nodes)) {
|
|
for (attrib in attribs) {
|
|
nodes[[node]][[attrib]] <- node %in% hash
|
|
}
|
|
}
|
|
nodes
|
|
}
|
|
|
|
node_unset_attribute <- function(nodes, hashes, attribs) {
|
|
for (hash in hashes) {
|
|
for (attrib in attribs) {
|
|
nodes[[hash]][[attrib]] <- FALSE
|
|
}
|
|
}
|
|
nodes
|
|
}
|
|
|
|
node_with_attribute <- function(nodes, attrib) {
|
|
if (length(nodes) == 0) return(NULL)
|
|
n <- nodes %>%
|
|
purrr::map(attrib) %>%
|
|
purrr::keep(isTRUE)
|
|
if (length(n)) n
|
|
}
|
|
|
|
node_parent <- function(nodes) {
|
|
names(node_with_attribute(nodes, "parent"))
|
|
}
|
|
|
|
node_child <- function(nodes) {
|
|
names(node_with_attribute(nodes, "child"))
|
|
}
|
|
|
|
node_adjusted <- function(nodes) {
|
|
names(node_with_attribute(nodes, "adjusted"))
|
|
}
|
|
|
|
node_delete <- function(nodes, hash) {
|
|
.nodes <- nodes[setdiff(names(nodes), hash)]
|
|
if (length(.nodes)) .nodes else list()
|
|
}
|
|
|
|
node_frame <- function(nodes, full = FALSE) {
|
|
if (!length(nodes)) {
|
|
return(tibble())
|
|
}
|
|
x <- bind_rows(nodes) %>%
|
|
mutate(hash = names(nodes)) %>%
|
|
select(hash, everything()) %>%
|
|
mutate(visible = !is.na(x), in_dag = x > 0) %>%
|
|
node_frame_complete()
|
|
if (full) {
|
|
return(x)
|
|
}
|
|
filter(x, in_dag)
|
|
}
|
|
|
|
node_frame_complete <- function(nodes) {
|
|
nodes$adjusted <- nodes[["adjusted"]] %||% FALSE
|
|
nodes$color_draw <- nodes[["color_draw"]] %||% "Black"
|
|
nodes$color_fill <- nodes[["color_fill"]] %||% "White"
|
|
nodes$color_text <- nodes[["color_text"]] %||% "Black"
|
|
nodes
|
|
}
|
|
|
|
node_vertices <- function(nodes) {
|
|
v_df <- node_frame(nodes)
|
|
vertices(
|
|
name = v_df$name,
|
|
x = v_df$x,
|
|
y = v_df$y,
|
|
hash = v_df$hash
|
|
)
|
|
}
|
|
|
|
node_nearest <- function(nodes, coordinfo, threshold = 0.5) {
|
|
nodes %>%
|
|
node_frame() %>%
|
|
mutate(dist = (x - coordinfo$x)^2 + (y - coordinfo$y)^2) %>%
|
|
arrange(dist) %>%
|
|
filter(dist <= threshold) %>%
|
|
slice(1) %>%
|
|
select(-dist)
|
|
}
|
|
|
|
nodes_in_dag <- function(nodes, include_staged = FALSE) {
|
|
n <- nodes %>%
|
|
purrr::keep(~ !is.na(.$x))
|
|
|
|
if (!include_staged) {
|
|
n <- purrr::keep(n, ~ .$x > 0)
|
|
}
|
|
names(n)
|
|
}
|
|
|
|
node_btn_id <- function(node_hash) paste0("node_toggle_", node_hash)
|
|
node_btn_get_hash <- function(node_btn_id) sub("node_toggle_", "", node_btn_id, fixed = TRUE)
|
|
|
|
node_tikz_style <- function(hash, adjusted, color_draw, color_fill, color_text, ...) {
|
|
# B/.style={fill=DarkRed, text=White}
|
|
if (!adjusted && color_fill == "White" && color_text == "Black") {
|
|
return(NA_character_)
|
|
}
|
|
style <-
|
|
list(
|
|
draw = if (adjusted) color_draw,
|
|
fill = color_fill,
|
|
text = color_text
|
|
) %>%
|
|
purrr::compact() %>%
|
|
purrr::imap_chr(~ glue::glue("{.y}={.x}")) %>%
|
|
paste(collapse = ", ")
|
|
|
|
glue::glue("{hash}/.style={{{style}}}")
|
|
}
|
|
|
|
node_frame_add_style <- function(nodes) {
|
|
if (!"name_latex" %in% names(nodes)) nodes$name_latex <- ""
|
|
nodes %>%
|
|
mutate(
|
|
tikz_style = purrr::pmap_chr(nodes, node_tikz_style),
|
|
name_latex = case_when(
|
|
is.na(name_latex) | name_latex == "" ~ escape_latex(name),
|
|
TRUE ~ name_latex
|
|
),
|
|
tikz_node = case_when(
|
|
!is.na(tikz_style) ~ paste(glue::glue("|[{hash}]| {name_latex}")),
|
|
TRUE ~ name_latex
|
|
)
|
|
)
|
|
}
|
|
|
|
escape_quotes <- function(x) {
|
|
x %??% gsub("(['\"])", "\\\\\\1", x)
|
|
}
|
|
|
|
escape_latex <- function(x, force = FALSE) {
|
|
if (is.null(x)) return(NULL)
|
|
if (!force && grepl("$", x, fixed = TRUE)) {
|
|
# has at least one dollar sign so we'll try to parse out the math
|
|
x_math <- chunk_math(x)
|
|
is_math <- attr(x_math, "is_math")
|
|
if (is.null(is_math) || !any(is_math)) {
|
|
# no math, just escape the original string
|
|
return(escape_latex(x, force = TRUE))
|
|
}
|
|
x_math[!is_math] <- x_math[!is_math] %>%
|
|
purrr::map_chr(escape_latex, force = TRUE)
|
|
|
|
return(paste0(x_math, collapse = ""))
|
|
}
|
|
|
|
## escape: # $ % ^ & _ { }
|
|
## replace: ~ -> \~{}
|
|
## replace: \ -> \textbackslash
|
|
## replace: < > -> \textless \textgreater
|
|
x <- gsub("\\", "\\textbackslash ", x, fixed = TRUE)
|
|
x <- gsub("<", "\\textless ", x, fixed = TRUE)
|
|
x <- gsub(">", "\\textgreater ", x, fixed = TRUE)
|
|
x <- gsub("([#$%^&_{}])", "\\\\\\1", x)
|
|
x <- gsub("~", "\\~{}", x, fixed = TRUE)
|
|
x
|
|
}
|
|
|
|
chunk_math <- function(x) {
|
|
x_s <- strsplit(x, character())[[1]]
|
|
|
|
idx <- which(grepl("$", x_s, fixed = TRUE))
|
|
if (!length(idx)) {
|
|
return(x)
|
|
}
|
|
# remove \\$ pairs from indexes
|
|
idx_has_escape <- which(grepl("\\", x_s[idx[idx > 1L] - 1L], fixed = TRUE))
|
|
if (length(idx_has_escape)) {
|
|
idx <- idx[-(idx_has_escape + as.integer(any(idx == 1)))]
|
|
}
|
|
|
|
# only include $ that touch at least one alphanum character
|
|
x_around_dollar <- purrr::map_chr(idx, ~ {
|
|
substr(x, max(0, .x - 1, na.rm = TRUE), min(nchar(x), .x + 1))
|
|
})
|
|
idx_no_adjacent_alpha <- which(!grepl("[[:alnum:]+=*{}.-]", x_around_dollar))
|
|
if (length(idx_no_adjacent_alpha)) {
|
|
idx <- idx[-idx_no_adjacent_alpha]
|
|
}
|
|
if (!length(idx)) {
|
|
return(x)
|
|
}
|
|
|
|
# finally, find the math chunks
|
|
chunks <- c()
|
|
is_math <- c()
|
|
i <- 1L
|
|
while (i < length(idx)) {
|
|
# idx[i - 1] ... idx[i]-1 -> not math
|
|
# idx[i]...idx[i+1] -> math
|
|
# skip ahead to idx[i + 2]
|
|
idx_not_math <- max(idx[i-1], 0, na.rm = TRUE)
|
|
chunks <- c(
|
|
chunks,
|
|
if (idx_not_math != idx[i] - 1L) substr(x, idx_not_math, idx[i] - 1L),
|
|
substr(x, idx[i], idx[i + 1]),
|
|
if (is.na(idx[i + 2]) & !idx[i + 1] == nchar(x)) {
|
|
substr(x, idx[i + 1] + 1, nchar(x))
|
|
}
|
|
)
|
|
is_math <- c(
|
|
is_math,
|
|
if (idx_not_math != idx[i] - 1L) FALSE,
|
|
TRUE,
|
|
if (is.na(idx[i + 2]) & !idx[i + 1] == nchar(x)) FALSE
|
|
)
|
|
i <- i + 2L
|
|
}
|
|
|
|
attributes(chunks)$is_math <- is_math
|
|
chunks
|
|
}
|