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
|
||||
))
|
||||
}
|
||||
)
|
||||
)
|
||||
}
|
||||
Loading…
Reference in a new issue