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