transfer from old repo
This commit is contained in:
parent
cfa4a5f9cc
commit
277e2b8cf3
1111 changed files with 83736 additions and 0 deletions
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)
|
||||
Loading…
Reference in a new issue