transfer from old repo
This commit is contained in:
parent
cfa4a5f9cc
commit
277e2b8cf3
1111 changed files with 83736 additions and 0 deletions
289
apps/shinyDAG-1.0.0/R/node.R
Normal file
289
apps/shinyDAG-1.0.0/R/node.R
Normal file
|
|
@ -0,0 +1,289 @@
|
|||
# ---- 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
|
||||
}
|
||||
Loading…
Reference in a new issue