transfer from old repo
This commit is contained in:
parent
cfa4a5f9cc
commit
277e2b8cf3
1111 changed files with 83736 additions and 0 deletions
183
apps/shinyDAG-1.0.0/R/aes_ui.R
Normal file
183
apps/shinyDAG-1.0.0/R/aes_ui.R
Normal file
|
|
@ -0,0 +1,183 @@
|
|||
|
||||
# * ui_edge_controls() builds an individual UI control element. These elements
|
||||
# are re-rendered whenever the tab is opened, so this function finds the
|
||||
# current value of the input and uses that instead of the value declared
|
||||
# in the definition in ui_edge_controls_row(). This function also isolates
|
||||
# the edge control UI from other changes in nodes, etc, because they happen
|
||||
# on different screens.
|
||||
ui_controls <- function(hash, inputFn, prefix_input, label, ..., input = NULL) {
|
||||
stopifnot(!is.null(input))
|
||||
current_value_arg_name <- intersect(names(list(...)), c("selected", "value"))
|
||||
if (!length(current_value_arg_name)) {
|
||||
stop("Must specifiy `selected` or `value` when specifying edge UI controls")
|
||||
}
|
||||
input_name <- paste(prefix_input, hash, sep = "__")
|
||||
input_label <- label
|
||||
|
||||
if (input_name %in% names(isolate(input))) {
|
||||
# Make sure current value doesn't change
|
||||
dots <- list(...)
|
||||
dots[current_value_arg_name] <- paste(isolate(input[[input_name]]))
|
||||
dots$inputId <- input_name
|
||||
dots$label <- HTML(input_label)
|
||||
do.call(inputFn, dots)
|
||||
} else {
|
||||
# Create new input
|
||||
inputFn(input_name, HTML(input_label), ...)
|
||||
}
|
||||
}
|
||||
|
||||
get_hashed_input_with_prefix <- function(input, prefix, hash_sep = "__") {
|
||||
prefix <- glue::glue("^({prefix}){hash_sep}")
|
||||
|
||||
tibble(
|
||||
inputId = grep(prefix, names(input), value = TRUE)
|
||||
) %>%
|
||||
filter(!grepl("-selectized$", inputId)) %>%
|
||||
# get current value of input
|
||||
mutate(value = lapply(inputId, function(x) input[[x]])) %>%
|
||||
tidyr::separate(inputId, into = c("var", "hash"), sep = hash_sep) %>%
|
||||
tidyr::spread(var, value) %>%
|
||||
mutate_if(is.list, ~ purrr::map(.x, ~ if (is.null(.x)) NA else .x)) %>%
|
||||
tidyr::unnest() %>%
|
||||
split(.$hash)
|
||||
}
|
||||
|
||||
# The input for angles (here for easy refactoring or future changes)
|
||||
selectDegree <- function(inputId, label = "Degree", min = -180, max = 180, by = 15, value = 0, ...) {
|
||||
sliderInput(inputId, label = label, min = min, max = max, value = value, step = by)
|
||||
}
|
||||
|
||||
|
||||
# Edge Aesthetic UI -------------------------------------------------------
|
||||
|
||||
# These helper functions build up the Edge UI elements.
|
||||
#
|
||||
# * ui_edge_controls_row() creates the entire row of UI elements for a given
|
||||
# edge. This function is where the UI inputs are initially defined.
|
||||
|
||||
ui_edge_controls_row <- function(hash, from_name, to_name, ..., input = NULL) {
|
||||
stopifnot(!is.null(input))
|
||||
|
||||
extra <- list(...)
|
||||
|
||||
col_4 <- function(x) {
|
||||
tags$div(class = "col-sm-6 col-md-3", style = "min-height: 80px", x)
|
||||
}
|
||||
title_row <- function(x) tags$div(class = "col-xs-12", tags$h3(x))
|
||||
edge_label <- paste0(from_name, " → ", to_name)
|
||||
|
||||
tagList(
|
||||
fluidRow(
|
||||
title_row(HTML(edge_label))
|
||||
),
|
||||
fluidRow(
|
||||
# Edge Curve Angle
|
||||
col_4(ui_controls(
|
||||
hash,
|
||||
inputFn = selectDegree,
|
||||
prefix_input = "angle",
|
||||
label = "Angle",
|
||||
value = extra[["angle"]] %||% 0,
|
||||
width = "95%",
|
||||
input = input
|
||||
)),
|
||||
# Edge Color
|
||||
col_4(ui_controls(
|
||||
hash,
|
||||
inputFn = xcolorPicker,
|
||||
prefix_input = "color",
|
||||
label = "Edge",
|
||||
selected = extra[["color"]] %||% "Black",
|
||||
width = "95%",
|
||||
input = input
|
||||
)),
|
||||
# Curve Angle
|
||||
col_4(ui_controls(
|
||||
hash,
|
||||
inputFn = selectInput,
|
||||
prefix_input = "lty",
|
||||
label = "Line Type",
|
||||
choices = c("solid", "dashed"),
|
||||
selected = extra[["lty"]] %||% "solid",
|
||||
width = "95%",
|
||||
input = input
|
||||
)),
|
||||
# Curve Angle
|
||||
col_4(ui_controls(
|
||||
hash,
|
||||
inputFn = selectInput,
|
||||
prefix_input = "lineT",
|
||||
label = "Line Thickness",
|
||||
choices = c("ultra thin", "very thin", "thin", "semithick", "thick", "very thick", "ultra thick"),
|
||||
selected = extra[["lineT"]] %||% "thin",
|
||||
width = "95%",
|
||||
input = input
|
||||
))
|
||||
)
|
||||
)
|
||||
}
|
||||
|
||||
|
||||
# Node Aesthetic UI -------------------------------------------------------
|
||||
|
||||
ui_node_controls_row <- function(hash, name, adjusted, name_latex, ..., input = NULL) {
|
||||
stopifnot(!is.null(input))
|
||||
|
||||
extra <- list(...)
|
||||
|
||||
col_4 <- function(x) {
|
||||
tags$div(class = "col-sm-6 col-md-3", style = "min-height: 80px", x)
|
||||
}
|
||||
title_row <- function(x) tags$div(class = "col-xs-12", tags$h3(x))
|
||||
|
||||
tagList(
|
||||
fluidRow(
|
||||
title_row(HTML(name))
|
||||
),
|
||||
fluidRow(
|
||||
# LaTeX version of node label
|
||||
col_4(ui_controls(
|
||||
hash,
|
||||
inputFn = textInput,
|
||||
prefix_input = "name_latex",
|
||||
label = "LaTeX Label",
|
||||
value = name_latex,
|
||||
width = "95%",
|
||||
input = input
|
||||
)),
|
||||
# Text Color
|
||||
col_4(ui_controls(
|
||||
hash,
|
||||
inputFn = xcolorPicker,
|
||||
prefix_input = "color_text",
|
||||
label = "Text",
|
||||
selected = extra[["color_text"]] %||% "Black",
|
||||
width = "95%",
|
||||
input = input
|
||||
)),
|
||||
# Fill Color
|
||||
col_4(ui_controls(
|
||||
hash,
|
||||
inputFn = xcolorPicker,
|
||||
prefix_input = "color_fill",
|
||||
label = "Fill",
|
||||
selected = extra[["color_fill"]] %||% "White",
|
||||
width = "95%",
|
||||
input = input
|
||||
)),
|
||||
# Box Color (if shown)
|
||||
if (adjusted) {
|
||||
col_4(ui_controls(
|
||||
hash,
|
||||
inputFn = xcolorPicker,
|
||||
prefix_input = "color_draw",
|
||||
label = "Border",
|
||||
selected = extra[["color_draw"]] %||% "Black",
|
||||
width = "95%",
|
||||
input = input
|
||||
))
|
||||
}
|
||||
)
|
||||
)
|
||||
}
|
||||
28
apps/shinyDAG-1.0.0/R/columns.R
Normal file
28
apps/shinyDAG-1.0.0/R/columns.R
Normal file
|
|
@ -0,0 +1,28 @@
|
|||
class_3_col <- "col-md-4 col-md-offset-0 col-sm-8 col-sm-offset-2 col-xs-12"
|
||||
|
||||
|
||||
# Component Builders ------------------------------------------------------
|
||||
|
||||
two_column_flips_on_mobile <- function(left, right, override_width_classes = TRUE) {
|
||||
|
||||
left_col_class <- "col-sm-12 col-md-pull-6 col-md-6 col-lg-5 col-lg-pull-7"
|
||||
right_col_class <- "col-sm-12 col-md-push-6 col-md-6 col-lg-7 col-lg-push-5"
|
||||
|
||||
if (!override_width_classes) {
|
||||
right <- tags$div(class = right_col_class, right)
|
||||
left <- tags$div(class = left_col_class, left)
|
||||
} else {
|
||||
strip_col_class <- function(x) gsub("col-(xs|sm|md|lg)-\\d{1,2}\\s*", "", x)
|
||||
left$attrib$class <- strip_col_class(left$attrib$class)
|
||||
right$attrib$class <- strip_col_class(right$attrib$class)
|
||||
|
||||
left$attrib$class <- paste(left$attrib$class, left_col_class)
|
||||
right$attrib$class <- paste(right$attrib$class, right_col_class)
|
||||
}
|
||||
|
||||
fluidRow(right, left)
|
||||
}
|
||||
|
||||
col_4 <- function(x) {
|
||||
tags$div(class = "col-sm-6 col-md-3", style = "min-height: 80px", x)
|
||||
}
|
||||
114
apps/shinyDAG-1.0.0/R/edge.R
Normal file
114
apps/shinyDAG-1.0.0/R/edge.R
Normal file
|
|
@ -0,0 +1,114 @@
|
|||
# rve$edges is a named list, e.g. for hash(A) -> hash(B):
|
||||
# rve$edges[edge_key(hash(A), hash(B))] = list(from = hash(A), to = hash(B))
|
||||
|
||||
# ---- Edge Helper Functions ----
|
||||
edge_key <- function(x, y) digest::digest(c(x, y))
|
||||
|
||||
edge_frame <- function(edges, nodes, ...) {
|
||||
dots <- rlang::enexprs(...)
|
||||
|
||||
dag_edges <- edges_in_dag(edges, nodes)
|
||||
|
||||
if (!length(dag_edges)) return(tibble())
|
||||
|
||||
ensure_exists <- function(x, ...) {
|
||||
cols <- list(...)
|
||||
stopifnot(!is.null(names(cols)), all(nzchar(names(cols))))
|
||||
for (col in names(cols)) {
|
||||
x[[col]] <- x[[col]] %||% cols[[col]]
|
||||
}
|
||||
x %>% tidyr::replace_na(cols)
|
||||
}
|
||||
|
||||
edges %>%
|
||||
bind_rows(.id = "hash") %>%
|
||||
filter(hash %in% edges_in_dag(edges, nodes)) %>%
|
||||
tidyr::nest(-from) %>%
|
||||
left_join(
|
||||
nodes %>% node_frame() %>% select(from = hash, from_name = name),
|
||||
by = "from"
|
||||
) %>%
|
||||
tidyr::unnest() %>%
|
||||
tidyr::nest(-to) %>%
|
||||
left_join(
|
||||
nodes %>% node_frame() %>% select(to = hash, to_name = name),
|
||||
by = "to"
|
||||
) %>%
|
||||
tidyr::unnest() %>%
|
||||
select(hash, names(edges[[1]]), everything()) %>%
|
||||
ensure_exists(angle = 0L, color = "black", lty = "solid", lineT = "thin") %>%
|
||||
mutate(!!!dots)
|
||||
}
|
||||
|
||||
edges_in_dag <- function(edges, nodes) {
|
||||
if (!length(nodes) || !length(edges)) return(character())
|
||||
all_edges <- bind_rows(edges) %>%
|
||||
mutate(hash = names(edges)) %>%
|
||||
tidyr::gather(position, node_hash, from:to)
|
||||
|
||||
edges_not_in_graph <- all_edges %>%
|
||||
filter(!node_hash %in% nodes_in_dag(nodes))
|
||||
|
||||
setdiff(all_edges$hash, edges_not_in_graph$hash)
|
||||
}
|
||||
|
||||
edge_edges <- function(edges, nodes, ...) {
|
||||
do.call(edge, as.list(edge_frame(edges, nodes, ...)))
|
||||
}
|
||||
|
||||
edge_exists <- function(edges, from_hash = NULL, to_hash = NULL) {
|
||||
if (purrr::some(list(from_hash, to_hash), is.null)) return(FALSE)
|
||||
|
||||
edges %>%
|
||||
purrr::keep(~ .$from %in% from_hash) %>%
|
||||
purrr::keep(~ .$to %in% to_hash) %>%
|
||||
length() %>%
|
||||
`>`(0)
|
||||
}
|
||||
|
||||
edge_points <- function(edges, nodes, push_by = 0) {
|
||||
dag_edges <- edges_in_dag(edges, nodes)
|
||||
|
||||
if (!length(dag_edges)) return(tibble())
|
||||
|
||||
edge_frame(edges, nodes) %>%
|
||||
tidyr::nest(-from) %>%
|
||||
left_join(
|
||||
nodes %>% node_frame() %>% select(from = hash, from.x = x, from.y = y),
|
||||
by = "from"
|
||||
) %>%
|
||||
tidyr::unnest() %>%
|
||||
tidyr::nest(-to) %>%
|
||||
left_join(
|
||||
nodes %>% node_frame() %>% select(to = hash, to.x = x, to.y = y),
|
||||
by = "to"
|
||||
) %>%
|
||||
tidyr::unnest() %>%
|
||||
select(hash, names(edges[[1]]), everything()) %>%
|
||||
mutate(
|
||||
d_x = to.x - from.x,
|
||||
d_y = to.y - from.y,
|
||||
from.x = from.x + push_by * d_x,
|
||||
from.y = from.y + push_by * d_y,
|
||||
to.x = to.x - push_by * d_x,
|
||||
to.y = to.y - push_by * d_y,
|
||||
color = if_else(color == "", "Black", color)
|
||||
) %>%
|
||||
select(-d_x, -d_y)
|
||||
}
|
||||
|
||||
edge_toggle <- function(edges, from_hash, to_hash) {
|
||||
existing <-
|
||||
edges %>%
|
||||
purrr::keep(~ .$from == from_hash) %>%
|
||||
purrr::keep(~ .$to == to_hash)
|
||||
|
||||
if (length(existing)) {
|
||||
for (edge_key in names(existing)) {
|
||||
edges[[edge_key]] <- NULL
|
||||
}
|
||||
} else {
|
||||
edges[[edge_key(from_hash, to_hash)]] <- list(from = from_hash, to = to_hash)
|
||||
}
|
||||
edges
|
||||
}
|
||||
41
apps/shinyDAG-1.0.0/R/inputs.R
Normal file
41
apps/shinyDAG-1.0.0/R/inputs.R
Normal file
|
|
@ -0,0 +1,41 @@
|
|||
# A fancy selectizeInput for angles
|
||||
selectDegree <- function(
|
||||
inputId,
|
||||
label = "Degree",
|
||||
min = -180 + by,
|
||||
max = 180,
|
||||
by = 45,
|
||||
value = 0,
|
||||
...
|
||||
) {
|
||||
if (sign(min + (max - min)) != sign(by)) {
|
||||
by <- -by
|
||||
}
|
||||
choices <- seq(min, max, by)
|
||||
|
||||
selectizeInput(inputId, label = label, choices, selected = value, multiple = FALSE, ..., )
|
||||
}
|
||||
|
||||
|
||||
# A button group that toggles state and optionally allows one button to be active at a time
|
||||
buttonGroup <- function(inputId, options, btn_class = "btn-default", multiple = FALSE, aria_label = NULL) {
|
||||
btn_class <- paste("btn", paste(btn_class, collapse = " "))
|
||||
button_list <- purrr::imap(options, button_in_group, class = btn_class)
|
||||
selected <- shiny::restoreInput(inputId, default = "")
|
||||
tagList(
|
||||
singleton(tags$head(tags$script(src = "shinythingsButtonGroup.js"))),
|
||||
tags$div(
|
||||
class = "shinythings-btn-group btn-group",
|
||||
id = inputId,
|
||||
`data-input-id` = inputId,
|
||||
`data-active` = selected,
|
||||
`data-multiple` = as.integer(multiple),
|
||||
role = "group",
|
||||
button_list
|
||||
)
|
||||
)
|
||||
}
|
||||
|
||||
button_in_group <- function(input_id, text, class = "btn btn-default") {
|
||||
tags$button(id = input_id, class = class, text)
|
||||
}
|
||||
310
apps/shinyDAG-1.0.0/R/module/clickpad.R
Normal file
310
apps/shinyDAG-1.0.0/R/module/clickpad.R
Normal file
|
|
@ -0,0 +1,310 @@
|
|||
clickpad_UI <- function(id, ...) {
|
||||
library(plotly)
|
||||
ns <- NS(id)
|
||||
tagList(
|
||||
plotlyOutput(ns("plot"), ...)
|
||||
)
|
||||
}
|
||||
|
||||
clickpad_debug <- function(id, relayout = TRUE, doubleclick = TRUE, selected = FALSE, clickannotation = TRUE) {
|
||||
ns <- NS(id)
|
||||
col_width <- 12 / sum(relayout, doubleclick, selected, clickannotation)
|
||||
tagList(
|
||||
fluidRow(
|
||||
style = "overflow-y: scroll; max-height: 200px;",
|
||||
if (relayout) column(
|
||||
col_width,
|
||||
tags$p(tags$code("plotly_relayout")),
|
||||
verbatimTextOutput(ns("v_relayout"))
|
||||
),
|
||||
if (doubleclick) column(
|
||||
col_width,
|
||||
tags$p(tags$code("plotly_doubleclick")),
|
||||
verbatimTextOutput(ns("v_doubleclick"))
|
||||
),
|
||||
if (selected) column(
|
||||
col_width,
|
||||
tags$p(tags$code("plotly_selected")),
|
||||
verbatimTextOutput(ns("v_selected"))
|
||||
),
|
||||
if (clickannotation) column(
|
||||
col_width,
|
||||
tags$p(tags$code("plotly_clickannotation")),
|
||||
verbatimTextOutput(ns("v_clickannotation"))
|
||||
)
|
||||
)
|
||||
)
|
||||
}
|
||||
|
||||
clickpad <- function(
|
||||
input, output, session,
|
||||
nodes, edges,
|
||||
plotly_source = "clickpad"
|
||||
) {
|
||||
library(plotly)
|
||||
ns <- session$ns
|
||||
|
||||
node_primary <- reactive({ node_parent(nodes()) })
|
||||
node_secondary <- reactive({ node_child(nodes()) })
|
||||
node_is_adjusted <- reactive({ node_adjusted(nodes()) })
|
||||
node_exposure <- reactive({ names(node_with_attribute(nodes(), "exposure")) })
|
||||
node_outcome <- reactive({ names(node_with_attribute(nodes(), "outcome")) })
|
||||
|
||||
output$v_relayout <- renderPrint({
|
||||
str(event_data("plotly_relayout", priority = "event", source = plotly_source))
|
||||
})
|
||||
|
||||
output$v_doubleclick <- renderPrint({
|
||||
str(event_data("plotly_doubleclick", priority = "event", source = plotly_source))
|
||||
})
|
||||
|
||||
output$v_selected <- renderPrint({
|
||||
str(event_data("plotly_clickannotation", priority = "event", source = plotly_source))
|
||||
})
|
||||
|
||||
output$v_clickannotation <- renderPrint({
|
||||
str(event_data("plotly_clickannotation", priority = "event", source = plotly_source))
|
||||
})
|
||||
|
||||
arrow_path <- function(from.x, from.y, to.x, to.y, dist = 0.2, ...) {
|
||||
# angle of the line between `from` and `to`
|
||||
theta <- atan2(to.y - from.y, to.x - from.x)
|
||||
|
||||
# push line starting/ending points away from node by a fixed distance
|
||||
path_points = list(
|
||||
x0 = from.x + dist * cos(theta),
|
||||
y0 = from.y + dist * sin(theta),
|
||||
x1 = to.x - dist * cos(theta),
|
||||
y1 = to.y - dist * sin(theta)
|
||||
)
|
||||
|
||||
# Find points for corners of arrow head (third point is `to`)
|
||||
arrow_anchor_x = path_points$x1 - dist * cos(theta)
|
||||
arrow_anchor_y = path_points$y1 - dist * sin(theta)
|
||||
ad <- 0.1 * dist / tan(1/6 * pi)
|
||||
|
||||
path_points$a1_x = arrow_anchor_x + ad * cos(theta + 1/2 * pi)
|
||||
path_points$a1_y = arrow_anchor_y + ad * sin(theta + 1/2 * pi)
|
||||
path_points$a2_x = arrow_anchor_x - ad * cos(theta + 1/2 * pi)
|
||||
path_points$a2_y = arrow_anchor_y - ad * sin(theta + 1/2 * pi)
|
||||
|
||||
# Draw arrow head in SVG path notation
|
||||
as.character(glue::glue_data(
|
||||
path_points,
|
||||
"M{x0},{y0} L{x1},{y1} L{a1_x},{a1_y} L{a2_x},{a2_y} L{x1},{y1}"
|
||||
))
|
||||
}
|
||||
|
||||
arrows <- reactive({
|
||||
if (is.null(edges()) || length(edges()) == 0) return(NULL)
|
||||
if (is.null(nodes()) || length(nodes()) == 0) return(NULL)
|
||||
|
||||
ep <- edge_points(edges(), nodes())
|
||||
if (!nrow(ep)) return(NULL)
|
||||
|
||||
ep %>%
|
||||
purrr::pmap_chr(arrow_path, dist = 0.2) %>%
|
||||
purrr::map(~ list(
|
||||
type = "path",
|
||||
line = list(color = "#000", width = 1),
|
||||
fillcolor = "#000",
|
||||
path = .x,
|
||||
opacity = 0.75
|
||||
))
|
||||
})
|
||||
|
||||
create_node_annotations <- function(x, y, name, hash, ...) {
|
||||
set_color <- function(
|
||||
default, not_in_dag = NULL,
|
||||
primary = NULL, secondary = NULL,
|
||||
exposure = NULL, outcome = NULL, adjusted = NULL,
|
||||
apply_order = c("primary", "not_in_dag", "adjusted", "exposure", "outcome", "secondary")
|
||||
) {
|
||||
applicable_states <- c(
|
||||
"primary" = !is.null(node_primary()) && hash %in% node_primary(),
|
||||
"secondary" = !is.null(node_secondary()) && hash %in% node_secondary(),
|
||||
"adjusted" = !is.null(node_is_adjusted()) && hash %in% node_is_adjusted(),
|
||||
"exposure" = !is.null(node_exposure()) && hash %in% node_exposure(),
|
||||
"outcome" = !is.null(node_outcome()) && hash %in% node_outcome(),
|
||||
"not_in_dag" = x < 0
|
||||
)
|
||||
|
||||
applicable_states <- applicable_states[applicable_states]
|
||||
if (!length(applicable_states)) return(default)
|
||||
|
||||
applicable_states <- applicable_states[apply_order]
|
||||
applicable_states <- applicable_states[!is.na(applicable_states)]
|
||||
if (!length(applicable_states)) return(default)
|
||||
|
||||
color <- switch(
|
||||
names(applicable_states)[1],
|
||||
primary = primary,
|
||||
secondary = secondary,
|
||||
adjusted = adjusted,
|
||||
outcome = outcome,
|
||||
exposure = exposure,
|
||||
not_in_dag = not_in_dag,
|
||||
default
|
||||
)
|
||||
|
||||
color %||% default
|
||||
}
|
||||
|
||||
background_color <- set_color(
|
||||
default = "rgba(255, 255, 255, 0.5)",
|
||||
not_in_dag = "#FDFDFD",
|
||||
primary = "rgba(246, 227, 209, 0.75)"
|
||||
)
|
||||
font_color <- set_color(
|
||||
default = "#000000",
|
||||
not_in_dag = "#666666",
|
||||
primary = "#D3751C",
|
||||
exposure = "#418c7a",
|
||||
outcome = "#ba2d0b",
|
||||
apply_order = c("not_in_dag", "exposure", "outcome", "primary")
|
||||
)
|
||||
border_color <- set_color(
|
||||
default = "#EDEDED",
|
||||
not_in_dag = "#AAAAAA",
|
||||
primary = list(NULL),
|
||||
adjusted = "#1c2d3f",
|
||||
apply_order = c("not_in_dag", "adjusted", "primary")
|
||||
)
|
||||
|
||||
list(text = name,
|
||||
node_hash = hash,
|
||||
x = x,
|
||||
y = y,
|
||||
font = list(size = 24, color = font_color),
|
||||
showarrow = FALSE,
|
||||
align = "center",
|
||||
captureevents = TRUE,
|
||||
textposition = "middle center",
|
||||
bordercolor = border_color,
|
||||
bgcolor = background_color,
|
||||
borderpad = 4)
|
||||
}
|
||||
|
||||
annotations <- reactive({
|
||||
if (is.null(nodes()) || length(nodes()) == 0) return(NULL)
|
||||
node_frame(nodes(), full = TRUE) %>%
|
||||
purrr::pmap(create_node_annotations)
|
||||
})
|
||||
|
||||
left_margin <- list(
|
||||
type = "rect",
|
||||
line = list(color = "#AAAAAA", width = 1),
|
||||
fillcolor = "#EEEEEE",
|
||||
x0 = -100,
|
||||
y0 = -100,
|
||||
x1 = 0,
|
||||
y1 = 100
|
||||
)
|
||||
|
||||
output$plot <- renderPlotly({
|
||||
debug_line("rendering clickpad")
|
||||
redraw_plot()
|
||||
|
||||
ax <- list(
|
||||
title = "",
|
||||
zeroline = FALSE,
|
||||
showline = FALSE,
|
||||
showticklabels = FALSE,
|
||||
showgrid = TRUE,
|
||||
range = list(-1.5, 12.5)
|
||||
)
|
||||
ay <- ax
|
||||
y_min <- purrr::map_dbl(nodes(), "y") %>% min()
|
||||
y_max <- purrr::map_dbl(nodes(), "y") %>% max()
|
||||
ay$range <- list(min(0.5, y_min), max(7.5, y_max))
|
||||
|
||||
p <- plot_ly(type = "scatter", source = plotly_source)
|
||||
|
||||
p %>%
|
||||
layout(
|
||||
annotations = annotations(),
|
||||
shapes = c(list(left_margin), arrows()),
|
||||
xaxis = ax,
|
||||
yaxis = ay
|
||||
) %>%
|
||||
config(
|
||||
edits = list(
|
||||
annotationPosition = TRUE
|
||||
),
|
||||
showAxisDragHandles = FALSE
|
||||
# displayModeBar = FALSE
|
||||
) %>%
|
||||
plotly::event_register("plotly_click") %>%
|
||||
plotly::event_register("plotly_doubleclick") %>%
|
||||
plotly::event_register("plotly_selected") %>%
|
||||
plotly::event_register("plotly_clickannotation") %>%
|
||||
htmlwidgets::onRender("
|
||||
function(el) {
|
||||
el.on('plotly_hover', function(d) { console.log('Hover: ', d) });
|
||||
el.on('plotly_click', function(d) { console.log('Click: ', d) });
|
||||
el.on('plotly_selected', function(d) { console.log('Select: ', d) });
|
||||
}
|
||||
")
|
||||
})
|
||||
|
||||
redraw_plot <- reactiveVal(Sys.time())
|
||||
|
||||
new_coords_lag <- list(hash = NA_character_, x = NA_real_, y = NA_real_)
|
||||
|
||||
new_locations <- reactive({
|
||||
req(annotations())
|
||||
## https://stackoverflow.com/questions/54990350/extract-xyz-coordinates-from-draggable-shape-in-plotly-ternary-r-shiny
|
||||
|
||||
event <- event_data("plotly_relayout", source = plotly_source)
|
||||
if (!length(event)) return()
|
||||
|
||||
annot_event <- event[grepl("^annotations\\[\\d+\\]\\.[xy]$", names(event))]
|
||||
annot_index <- sub(".+\\[(\\d+)\\].+", "\\1", names(annot_event)[1]) %>% as.integer()
|
||||
|
||||
if (is.na(annot_index) || !is.integer(annot_index)) return()
|
||||
|
||||
if (length(annotations()) <= annot_index) {
|
||||
stop("An error occurred, unable to match plotly update to correct node")
|
||||
}
|
||||
|
||||
node_hash <- annotations()[[annot_index + 1]]$node_hash
|
||||
# cli::cat_line("event_name: ", names(event)[1])
|
||||
# cli::cat_line("annot_index: ", annot_index)
|
||||
# cli::cat_line("node_hash: ", node_hash)
|
||||
|
||||
req(!is.null(node_hash))
|
||||
|
||||
new_x <- annot_event[grepl("\\.x", names(annot_event))] %>% unlist() %>% unname()
|
||||
new_x <- if (new_x > 0) round(new_x, 0) else new_x
|
||||
|
||||
new_y <- annot_event[grepl("\\.y", names(annot_event))] %>% unlist() %>% unname()
|
||||
new_y <- if (new_x > 0) round(new_y, 0) else new_y
|
||||
|
||||
i_nodes <- isolate(nodes())
|
||||
current_pos <- i_nodes[[node_hash]][c("x", "y")] %>% unlist() %>% unname()
|
||||
|
||||
new_coords <- list(
|
||||
hash = node_hash,
|
||||
x = new_x,
|
||||
y = new_y
|
||||
)
|
||||
|
||||
if (identical(c(new_coords$x, new_coords$y), current_pos)) {
|
||||
# No change in current node position
|
||||
return()
|
||||
}
|
||||
|
||||
if (identical(new_coords, new_coords_lag)) {
|
||||
# The plotly_redraw may not have been a result of annotation position change
|
||||
return()
|
||||
}
|
||||
|
||||
new_coords_lag <<- new_coords
|
||||
|
||||
# cli::cat_line("new_x: ", new_x)
|
||||
# cli::cat_line("new_y: ", new_y)
|
||||
new_coords
|
||||
})
|
||||
|
||||
return(reactive(new_locations()))
|
||||
}
|
||||
288
apps/shinyDAG-1.0.0/R/module/dagPreview.R
Normal file
288
apps/shinyDAG-1.0.0/R/module/dagPreview.R
Normal file
|
|
@ -0,0 +1,288 @@
|
|||
|
||||
# UI Function -------------------------------------------------------------
|
||||
|
||||
dagPreviewUI <- function(id, include_graph_downloads = TRUE, start_hidden = FALSE) {
|
||||
ns <- shiny::NS(id)
|
||||
|
||||
class_3_col <- "col-md-4 col-md-offset-0 col-sm-8 col-sm-offset-2 col-xs-12"
|
||||
|
||||
download_choices <- c(
|
||||
"PDF" = "pdf",
|
||||
"PNG" = "png",
|
||||
"LaTeX TikZ" = "tikz"
|
||||
)
|
||||
|
||||
if (include_graph_downloads) {
|
||||
download_choices <- c(
|
||||
download_choices,
|
||||
"dagitty (R: RDS)" = "dag_dagitty",
|
||||
"ggdag (R: RDS)" = "dag_tidy"
|
||||
)
|
||||
}
|
||||
|
||||
tagList(
|
||||
fluidRow(
|
||||
column(
|
||||
width = 12,
|
||||
align = "center",
|
||||
shinyjs::hidden(tags$div(
|
||||
id = ns("tikzOut-help"),
|
||||
class="alert alert-danger",
|
||||
role="alert",
|
||||
HTML(
|
||||
"<p>An error occurred while compiling the preview.",
|
||||
"Are there syntax errors in your labels?</p>",
|
||||
"<p>Note that using characters that are",
|
||||
'<a href="https://en.wikibooks.org/wiki/LaTeX/Special_Characters" target="_blank">reserved',
|
||||
'characters in LaTeX</a> syntax may cause issues. For example,',
|
||||
"single <code>$</code> need to be escaped: <code>\\$</code>.</p>"
|
||||
)
|
||||
)),
|
||||
tags$div(
|
||||
class = "dag-preview-tikz",
|
||||
shinycssloaders::withSpinner(uiOutput(ns("tikzOut")), color = "#C4C4C4", proxy.height = "400px")
|
||||
)
|
||||
)
|
||||
),
|
||||
fluidRow(
|
||||
tags$div(
|
||||
class = class_3_col,
|
||||
tags$div(
|
||||
id = ns("showPreviewContainer"),
|
||||
prettySwitch(ns("showPreview"), "Preview DAG", status = "primary", fill = TRUE, value = !start_hidden)
|
||||
)
|
||||
),
|
||||
tags$div(
|
||||
class = class_3_col,
|
||||
selectInput(
|
||||
inputId = ns("downloadType"),
|
||||
label = "Type of download",
|
||||
choices = download_choices
|
||||
),
|
||||
uiOutput(ns("downloadType_helptext"))
|
||||
),
|
||||
tags$div(
|
||||
class = paste(class_3_col, "dagpreview-download-ui"),
|
||||
div(
|
||||
class = "btn-group",
|
||||
role = "group",
|
||||
id = ns("download-buttons"),
|
||||
downloadButton(ns("downloadButton"))
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
}
|
||||
|
||||
|
||||
# Server Module -----------------------------------------------------------
|
||||
|
||||
# This module takes tikz code and creates DAG preview content and returns TRUE
|
||||
# or FALSE value to track whether the preview is visible.
|
||||
dagPreview <- function(
|
||||
input, output, session,
|
||||
session_dir,
|
||||
tikz_code,
|
||||
dag_dagitty = reactive(NULL),
|
||||
dag_tidy = reactive(NULL),
|
||||
has_edges = reactive(FALSE)
|
||||
) {
|
||||
ns <- session$ns
|
||||
SESSION_TEMPDIR <- file.path(session_dir, sub("-$", "", ns("")))
|
||||
|
||||
tikz_cache_dir <- reactiveVal(NULL)
|
||||
|
||||
# Render tikz preview ----
|
||||
observe({
|
||||
req(input$showPreview)
|
||||
|
||||
tikz_lines <- tikz_code()
|
||||
req(gsub("\\s", "", tikz_lines) != "")
|
||||
debug_input(tikz_lines, ns("tikz_code"))
|
||||
|
||||
useLib <- "\\usetikzlibrary{matrix,arrows,decorations.pathmorphing}"
|
||||
|
||||
pkgs <- paste(buildUsepackage(pkg = list("tikz"), uselibrary = useLib), collapse = "\n")
|
||||
|
||||
tex_dir <-
|
||||
tex_cached_preview(
|
||||
session_dir = SESSION_TEMPDIR,
|
||||
obj = tikz_lines,
|
||||
stem = "DAGimage",
|
||||
imgFormat = "png",
|
||||
returnType = "shiny",
|
||||
density = tex_opts$get("density"),
|
||||
keep_pdf = TRUE,
|
||||
usrPackages = pkgs,
|
||||
margin = tex_opts$get("margin"),
|
||||
cleanup = tex_opts$get("cleanup")
|
||||
)
|
||||
tikz_cache_dir(tex_dir)
|
||||
}, priority = -100)
|
||||
|
||||
# Create tikz preview UI ----
|
||||
output$tikzOut <- renderUI({
|
||||
req(input$showPreview)
|
||||
|
||||
shiny::validate(
|
||||
shiny::need(
|
||||
tryCatch({tikz_code(); TRUE}, error = function(e) FALSE) ||
|
||||
tryCatch(gsub("\\s", "", tikz_code()), error = function(e) "") != "",
|
||||
paste(
|
||||
"Nothing to see here... yet. Please use the Sketch tab to create",
|
||||
"and layout a DAG."
|
||||
)
|
||||
)
|
||||
)
|
||||
|
||||
if (is.null(tikz_cache_dir())) return()
|
||||
if (!length(tikz_cache_dir())) {
|
||||
shinyjs::show("tikzOut-help")
|
||||
return()
|
||||
} else {
|
||||
shinyjs::hide("tikzOut-help")
|
||||
}
|
||||
|
||||
image_path <- file.path(tikz_cache_dir(), "DAGimage.png")
|
||||
if (!file.exists(image_path)) {
|
||||
debug_line("Image does not exist: ", image_path)
|
||||
return()
|
||||
}
|
||||
|
||||
image_tmp <- tempfile("dag_image_", SESSION_TEMPDIR, ".png")
|
||||
file.copy(image_path, image_tmp)
|
||||
debug_line("Serving image: ", image_tmp)
|
||||
|
||||
tags$img(
|
||||
src = sub("www/", "", image_tmp, fixed = TRUE),
|
||||
contentType = "image/png",
|
||||
style = "max-width: 100%; max-height: 600px; -o-object-fit: contain;",
|
||||
alt = "DAG"
|
||||
)
|
||||
})
|
||||
|
||||
output$downloadType_helptext <- renderUI({
|
||||
is_tikz_download <- input$downloadType %in% c("pdf", "png", "tikz")
|
||||
if (is_tikz_download && !input$showPreview) {
|
||||
shinyjs::disable("downloadButton")
|
||||
return(helpText("Please preview DAG to enable downloads"))
|
||||
}
|
||||
|
||||
if (!is_tikz_download && !has_edges()) {
|
||||
shinyjs::disable("downloadButton")
|
||||
return(helpText("Please add at least one edge to the DAG"))
|
||||
}
|
||||
|
||||
if (!length(tikz_cache_dir())) {
|
||||
shinyjs::disable("downloadButton")
|
||||
return()
|
||||
}
|
||||
|
||||
shinyjs::enable("downloadButton")
|
||||
})
|
||||
|
||||
output$downloadButton <- downloadHandler(
|
||||
filename = function() {
|
||||
paste0(
|
||||
"DAG.",
|
||||
switch(
|
||||
input$downloadType,
|
||||
"dagitty" =,
|
||||
"ggdag" = "rds",
|
||||
"tikz" = "tex",
|
||||
"png" = "png",
|
||||
"pdf" = "pdf"
|
||||
)
|
||||
)
|
||||
},
|
||||
content = function(file) {
|
||||
if (input$downloadType == "pdf") {
|
||||
|
||||
file.copy(file.path(tikz_cache_dir(), "DAGimageDoc.pdf"), file)
|
||||
|
||||
} else if (input$downloadType == "png") {
|
||||
|
||||
file.copy(file.path(tikz_cache_dir(), "DAGimage.png"), file)
|
||||
|
||||
} else if (input$downloadType == "tikz") {
|
||||
|
||||
merge_tex_files(
|
||||
file.path(tikz_cache_dir(), "DAGimageDoc.tex"),
|
||||
file.path(tikz_cache_dir(), "DAGimage.tex"),
|
||||
file
|
||||
)
|
||||
|
||||
} else if (input$downloadType == "dag_dagitty") {
|
||||
|
||||
if (is.null(dag_dagitty())) return(NULL)
|
||||
|
||||
saveRDS(dag_dagitty(), file = file)
|
||||
|
||||
} else if (input$downloadType == "dag_tidy") {
|
||||
|
||||
if (is.null(dag_tidy())) return(NULL)
|
||||
|
||||
saveRDS(dag_tidy(), file = file)
|
||||
}
|
||||
},
|
||||
contentType = NA
|
||||
)
|
||||
|
||||
return(reactive(input$showPreview))
|
||||
}
|
||||
|
||||
|
||||
# Helper Functions --------------------------------------------------------
|
||||
|
||||
tex_cached_preview <- function(session_dir, ...) {
|
||||
# Takes arguments for texPreview() except for fileDir
|
||||
# hashes inputs and then writes preview into session_dir/args_hash
|
||||
# Skips rendering if the cache already exists
|
||||
# Returns directory containing the preview documents
|
||||
|
||||
args <- list(...)
|
||||
args_hash <- digest::digest(args)
|
||||
|
||||
session_token <- basename(dirname(session_dir))
|
||||
error_file <- paste0(session_token, "_", args_hash, ".tex")
|
||||
|
||||
cache_dir <- file.path(session_dir, args_hash)
|
||||
error_dir <- file.path("www", "errors")
|
||||
|
||||
if (dir.exists(cache_dir)) {
|
||||
return(cache_dir)
|
||||
} else {
|
||||
if (file.exists(file.path(error_dir, error_file))) {
|
||||
# we already know that this tikz code won't work
|
||||
warning("Bad tikz is still bad: ", error_file)
|
||||
return(character())
|
||||
}
|
||||
}
|
||||
|
||||
dir.create(cache_dir, recursive = TRUE)
|
||||
args$fileDir <- cache_dir
|
||||
tryCatch({
|
||||
do.call("texPreview", args)
|
||||
cache_dir
|
||||
}, error = function(e) {
|
||||
# write bad tex code to disk
|
||||
dir.create(error_dir, showWarnings = FALSE)
|
||||
cat(
|
||||
args$obj,
|
||||
sep = "\n",
|
||||
file = file.path(error_dir, error_file)
|
||||
)
|
||||
unlink(cache_dir, recursive = TRUE)
|
||||
character()
|
||||
})
|
||||
}
|
||||
|
||||
# Merge tikz TeX source into main TeX file
|
||||
merge_tex_files <- function(main_file, input_file, out_file) {
|
||||
x <- readLines(main_file)
|
||||
y <- readLines(input_file)
|
||||
which_line <- grep("input{", x, fixed = TRUE)
|
||||
which_line <- intersect(which_line, grep(basename(input_file), x))
|
||||
x[which_line] <- paste(y, collapse = "\n")
|
||||
writeLines(x, out_file)
|
||||
}
|
||||
133
apps/shinyDAG-1.0.0/R/module/examples.R
Normal file
133
apps/shinyDAG-1.0.0/R/module/examples.R
Normal file
|
|
@ -0,0 +1,133 @@
|
|||
add_slug <- function(ex) {
|
||||
ex %>%
|
||||
purrr::map(~ {
|
||||
.x$slug <- gsub("[.]rds$", "", .x$file, ignore.case = TRUE)
|
||||
.x
|
||||
})
|
||||
}
|
||||
|
||||
keep_ex_with_file <- function(ex) {
|
||||
ex %>%
|
||||
purrr::keep(~ file.exists(.$file))
|
||||
}
|
||||
|
||||
nullify_missing <- function(ex, field = "image") {
|
||||
ex %>%
|
||||
purrr::modify_depth(
|
||||
.depth = 1,
|
||||
~ purrr::modify_at(., field, ~ {
|
||||
if (!file.exists(.x)) list(NULL) else .x
|
||||
})
|
||||
)
|
||||
}
|
||||
|
||||
full_path <- function(ex, field, path = file.path("www", "examples")) {
|
||||
ex %>%
|
||||
purrr::modify_depth(
|
||||
.depth = 1,
|
||||
~ purrr::modify_at(., field, ~ file.path(path, .x))
|
||||
)
|
||||
}
|
||||
|
||||
rel_path <- function(ex, field, path = file.path("www/")) {
|
||||
ex %>%
|
||||
purrr::modify_depth(
|
||||
.depth = 1,
|
||||
~ purrr::modify_at(., field, ~ if (!is.null(.x)) sub(path, "", .x, fixed = TRUE) else list(NULL))
|
||||
)
|
||||
}
|
||||
|
||||
load_example_values <- function(ex) {
|
||||
purrr::map(ex, ~ {
|
||||
values <- readRDS(.x$file)
|
||||
.x$values <- list()
|
||||
.x$values$nodes <- values$rvn$nodes
|
||||
.x$values$edges <- values$rve$edges
|
||||
.x
|
||||
})
|
||||
}
|
||||
|
||||
load_examples <- function(path = file.path("www", "examples")) {
|
||||
ex_yaml <- file.path(path, "examples.yml")
|
||||
if (!file.exists(ex_yaml)) {
|
||||
stop("Unable to locate ", ex_yaml)
|
||||
}
|
||||
|
||||
ex <- yaml::read_yaml(ex_yaml)
|
||||
|
||||
ex %>%
|
||||
add_slug() %>%
|
||||
full_path("image", path) %>%
|
||||
full_path("file", path) %>%
|
||||
keep_ex_with_file() %>%
|
||||
nullify_missing("image") %>%
|
||||
rel_path("image") %>%
|
||||
load_example_values()
|
||||
}
|
||||
|
||||
|
||||
EXAMPLES <- load_examples()
|
||||
|
||||
examples_UI <- function(id) {
|
||||
ns <- NS(id)
|
||||
|
||||
make_examples_ui <- function(name, description, slug, image = NULL, ...) {
|
||||
tagList(
|
||||
tags$h3(name),
|
||||
if (!is.null(image)) tags$div(
|
||||
class = "example-image",
|
||||
tags$img(src = image)
|
||||
),
|
||||
tags$p(
|
||||
HTML(description)
|
||||
),
|
||||
actionButton(ns(slug), "Load Example")
|
||||
)
|
||||
}
|
||||
|
||||
tagList(
|
||||
EXAMPLES %>%
|
||||
purrr::map(`[`, c("name", "description", "slug", "image")) %>%
|
||||
purrr::map(~ purrr::pmap(.x, make_examples_ui))
|
||||
)
|
||||
}
|
||||
|
||||
examples <- function(input, output, session) {
|
||||
input_ids <- EXAMPLES %>% purrr::map_chr("slug")
|
||||
values <- EXAMPLES %>% purrr::map("values")
|
||||
names(values) <- input_ids
|
||||
|
||||
lagged_value <- setNames(rep(0L, length(input_ids)), input_ids)
|
||||
|
||||
example_value <- reactiveVal(NULL)
|
||||
|
||||
observe({
|
||||
current_btn_vals <- purrr::map_int(input_ids, ~ input[[.x]])
|
||||
req(any(current_btn_vals > 0L))
|
||||
# cli::cat_line("lagged: ", lagged_value)
|
||||
# cli::cat_line("current: ", current_btn_vals)
|
||||
|
||||
idx <- which(current_btn_vals != lagged_value)
|
||||
lagged_value <<- current_btn_vals
|
||||
|
||||
if (!length(idx)) {
|
||||
example_value(NULL)
|
||||
return(NULL)
|
||||
}
|
||||
|
||||
changed_input <- input_ids[idx]
|
||||
|
||||
example_value(values[[changed_input]])
|
||||
})
|
||||
|
||||
return(reactive(example_value()))
|
||||
}
|
||||
|
||||
|
||||
# ui <- fluidPage(
|
||||
# examples_UI("example")
|
||||
# )
|
||||
# server <- function(input, output, session){
|
||||
# callModule(examples, 'example')
|
||||
# }
|
||||
# shinyApp(ui, server)
|
||||
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
|
||||
}
|
||||
37
apps/shinyDAG-1.0.0/R/tests/test-escape_latex.R
Normal file
37
apps/shinyDAG-1.0.0/R/tests/test-escape_latex.R
Normal file
|
|
@ -0,0 +1,37 @@
|
|||
source("../node.R")
|
||||
|
||||
latex_text <- list(
|
||||
list(t = "$m^2$", e = "$m^2$"),
|
||||
list(t = "a $m^2$", e = "a $m^2$"),
|
||||
list(t = "$m^2$ b", e = "$m^2$ b"),
|
||||
list(t = "a $m^2$ b", e = "a $m^2$ b"),
|
||||
list(t = "a $e=$$m^2$ b", e = "a $e=$$m^2$ b"),
|
||||
list(t = "a $$ math", e = "a \\$\\$ math"),
|
||||
list(t = "\\textbackslash", e = "\\textbackslash textbackslash"),
|
||||
list(t = "# of", e = "\\# of"),
|
||||
list(t = "$ amount", e = "\\$ amount"),
|
||||
list(t = "my $$ is", e = "my \\$\\$ is"),
|
||||
list(t = "$m $$ m$", e = "$m $$ m$"),
|
||||
list(t = "$$ is $mc^2$", e = "\\$\\$ is $mc^2$"),
|
||||
list(t = "a > b", e = "a \\textgreater b"), #<< extra space before b
|
||||
list(t = "a < b", e = "a \\textless b"), #<< same
|
||||
list(t = "a % b", e = "a \\% b"),
|
||||
list(t = "a_b", e = "a\\_b"),
|
||||
list(t = "a & b", e = "a \\& b"),
|
||||
list(t = "a & b \\ c", e = "a \\& b \\textbackslash c"), #<< + space
|
||||
list(t = "{a}", e = "\\{a\\}"),
|
||||
list(t = "a ~ b", e = "a \\~{} b")
|
||||
)
|
||||
|
||||
passed_test <- purrr::map_lgl(latex_text, function(x) {
|
||||
identical(escape_latex(x$t), x$e)
|
||||
})
|
||||
|
||||
if (all(passed_test)) {
|
||||
cat('\nAll (', sum(passed_test), ') tests passed!', sep = '')
|
||||
} else {
|
||||
cat('\nThere were', sum(!passed_test), "failures...")
|
||||
purrr::walk(latex_text[!passed_test], function(x) {
|
||||
cat("\n'", x$t, "' returned '", escape_latex(x$t), "' not '", x$e, "'", sep = "")
|
||||
})
|
||||
}
|
||||
81
apps/shinyDAG-1.0.0/R/xcolorPicker.R
Normal file
81
apps/shinyDAG-1.0.0/R/xcolorPicker.R
Normal file
|
|
@ -0,0 +1,81 @@
|
|||
# xcolors list ----
|
||||
|
||||
if (!file.exists(file.path("data", "xcolors.csv"))) {
|
||||
if (!dir.exists('data')) {
|
||||
stop("Not sure where I am")
|
||||
}
|
||||
message("Getting xcolors color list")
|
||||
read_gz <- function(x) readLines(gzcon(url(x)))
|
||||
|
||||
xcolors <-
|
||||
list(
|
||||
# x11 = "http://www.ukern.de/tex/xcolor/tex/x11nam.def.gz",
|
||||
svg = "http://www.ukern.de/tex/xcolor/tex/svgnam.def.gz"
|
||||
) %>%
|
||||
purrr::map(read_gz) %>%
|
||||
purrr::flatten_chr() %>%
|
||||
stringr::str_subset("^(%%|\\\\| )", negate = TRUE) %>%
|
||||
stringr::str_remove("(;%|\\})$") %>%
|
||||
readr::read_csv(col_names = c("color", "r", "g", "b")) %>%
|
||||
arrange(color) %>%
|
||||
readr::write_csv(file.path("data", "xcolors.csv"))
|
||||
} else {
|
||||
xcolors <-
|
||||
file.path("data/xcolors.csv") %>%
|
||||
read.csv(stringsAsFactors = FALSE)
|
||||
}
|
||||
|
||||
# Color Functions ----
|
||||
|
||||
choose_dark_or_light <- function(x, black = "#000000", white = "#FFFFFF") {
|
||||
# x = color_hex
|
||||
color_rgb <- col2rgb(x)[, 1]
|
||||
# from https://stackoverflow.com/a/3943023/2022615
|
||||
color_rgb <- color_rgb / 255
|
||||
color_rgb[color_rgb <= 0.03928] <- color_rgb[color_rgb <= 0.03928]/12.92
|
||||
color_rgb[color_rgb > 0.03928] <- ((color_rgb[color_rgb > 0.03928] + 0.055)/1.055)^2.4
|
||||
lum <- t(c(0.2126, 0.7152, 0.0722)) %*% color_rgb
|
||||
if (lum[1, 1] > 0.179) eval(black) else eval(white)
|
||||
}
|
||||
|
||||
xcolor_style <- function(hex, text, ...) {
|
||||
glue::glue('background-color:{hex};color:{text}')
|
||||
}
|
||||
|
||||
# Prep Color List ----
|
||||
|
||||
xcolors <-
|
||||
xcolors %>%
|
||||
mutate(
|
||||
hex = rgb(r, g, b, maxColorValue = 1),
|
||||
text = purrr::map_chr(hex, choose_dark_or_light)
|
||||
) %>%
|
||||
select(color, hex, text)
|
||||
|
||||
|
||||
xcolors_list <- xcolors$color
|
||||
names(xcolors_list) <- purrr::pmap_chr(xcolors, xcolor_style)
|
||||
|
||||
xcolor_label <- function(value) {
|
||||
xcolors %>% filter(color == value) %>% purrr::pmap_chr(xcolor_style)
|
||||
}
|
||||
|
||||
# xcolorPicker() ----
|
||||
|
||||
xcolorPicker <- function(inputId, label = NULL, selected = NULL, ...) {
|
||||
selectizeInput(
|
||||
inputId,
|
||||
label = label,
|
||||
choices = c("", xcolors_list),
|
||||
multiple = FALSE,
|
||||
selected = selected,
|
||||
options = list(
|
||||
searchField = "value",
|
||||
render = I(
|
||||
'{
|
||||
item: (item, escape) => `<div>${escape(item.value)}</div>`,
|
||||
option: (item, escape) => `<div style="${item.label};line-height: 2.5em">${escape(item.value)}</div>`
|
||||
}'
|
||||
))
|
||||
)
|
||||
}
|
||||
Loading…
Reference in a new issue