R/tab_core_top.R
In systemPipeR/systemPipeS: systemPipeShiny: An Interactive Framework for Workflow Management and Visualization
Defines functions
core_topUI
## UI
########### loaded but not in use under current SPS version
#' @noRd
core_topUI <- function(id){
ns <- NS(id)
init <-
"sal <- systemPipeR::SPRproject(resume = TRUE)
sal <- systemPipeR::runWF(sal)
sal"
div(
tags$script(src = "sps/js/split1.6.0.js"),
pushbar::pushbar_deps(),
pushbar::pushbar(
id = ns("wf_push"),
from = "top",
style= "background:#ECF0F5; padding:5px; min-height:100vh; overflow-y:auto; overflow-x: hidden;",
tagList(
fluidRow(
div(style = " text-align: center;",
shinyWidgets::actionBttn(ns("close_push"),
style = "simple",
label = "Close this workflow session",
icon = icon("xmark"),
color = "danger",
size = "sm")) %>%
bsHoverPopover(
"Close this session",
"Clicking here kills the workflow R session, clear all data
stored in that R session and reset
your working directory to SPS app directory. If you have
workflow jobs running, they will be forced to terminate.",
"bottom"
)
),
div(
style = "height: 95vh;",
div(
id = ns("leftcol"), class = "split split-horizontal", style = "overflow: hidden;",
# source code ----
div( id = ns("source_code"), class ="split split-content",
div(
class = "split-header",
h3("Source Code", class = "split-title"),
div(class = "split-tool", actionButton("a", "", icon = icon("minus"), class = ""))
),
div(
class = "split-body", style = "position: relative;",
aceEditor(
ns("code"), mode = "r", height = "30vh", value = init,
autoComplete = "live", fontSize = 14,
autoCompleters = c("static", "text"),
autoScrollEditorIntoView = TRUE,
maxLines = 9999,
debounce = 10,
autoCompleteList = getNamespaceExports("systemPipeR") %>%
{.[!str_detect(., "^\\.")]} %>%
{paste0("systemPipeR::", .)} %>%
list(systemPipeR = .)) %>%
{.[[2]][["attribs"]][["style"]] = "height: 30vh; min-height: 30vh;"; .},
fluidRow(
column(6,
actionButton(ns("eval"), "Run"),
div(id = ns("loading_eval"), style = "display: none;",
spsLoader())
),
column(6,
tags$b(class = "pull-right", id = ns("rs_status"), "No active R session")
)
),
tags$p("There is about one second delay sending code from UI to
backend. Wait a second after editing code before hitting 'Run'.")
)
),
# console ----
div( id = ns("console"), class ="split split-content",
div(
class = "split-header",
h3("Console Output", class = "split-title"),
div(
class = "split-tool",
actionButton(
ns("console_stop"), "",
class = "shinyjs-hide",
icon = icon("stop"),
`data-toggle`="tooltip",
`data-placement`="bottom",
title="Interrupt session"
),
tags$style(glue('
#@{ns("console_stop")}@ .fa-stop {color: #d03e3b;}
', .open = "@{", .close = "}@")),
div(
class = "dropdown",
# `data-toggle`="tooltip",
# `data-placement`="top",
# title = "console options",
style = "display: inline;",
tags$button(
class="btn btn-default dropdown-toggle",
type = "button",
id = ns("out_options"),
`data-toggle` = "dropdown",
`aria-haspopup`= "true",
`aria-expanded`= "false",
tags$i(class = "fa fa-gears")
),
tags$ul(
class="dropdown-menu",
`aria-labelledby` = ns("out_options"),
tags$li(class = "dropdown-header", "Stop on error"),
tags$li(
style = "margin-left: 15px;",
shinyWidgets::switchInput(
size = "mini",
value = TRUE,
inputId = ns("stop_on_err"),
offStatus = "danger",
width = "50%"
)
)
)
),
actionButton(
ns("clear_console"), "",
icon = icon("trash"),
`data-toggle`="tooltip",
`data-placement`="bottom",
title="clear console"
),
actionButton("a", "", icon = icon("minus"), class = "")
)
),
div(
class = "split-body",
verbatimTextOutput(ns("output")) %>%
{.$attribs[['style']] <- " margin:0; overflow: visible;"; .}
)
)
),
div(
id = ns("rightcol"), class ="split split-horizontal",
# wf log ----
div(
id = ns("wf_log"), class ="split split-content",
div(
class = "split-header",
h3("Workflow Status", class = "split-title"),
div(
class = "split-tool",
actionButton("a", "", icon = icon("minus"), class = "")
)
),
div(class = "split-body",
tabsetPanel(
tabPanel(
"Status Plot",
systemPipeR::plotwfOutput(ns("status_plot"))
),
tabPanel(
"Workflow log",
uiOutput(ns("logs")) %>%
{.$attribs[['style']] <- " margin:0; overflow: visible;"; .},
)
),
div(style="width:100%", spsHr()),
p("This panel always displays the most recent
workflow status and log stored in `.SPRproject` folder, updates every 10s."),
div(
style="height:5px; width:100%",
shinyWidgets::progressBar(
ns("update_log"), value = 0,
status = "primary", striped = TRUE,
size = "xs"
)
)
)
),
# plot ----
div(
id = ns("plot_panel"), class ="split split-content",
div(
class = "split-header",
h3("Plots", class = "split-title"),
div(
class = "split-tool",
# div(
# class = "dropdown",
# style = "display: inline;",
# tags$button(
# class="btn btn-default dropdown-toggle",
# type = "button",
# id = ns("plot_options"),
# `data-toggle` = "dropdown",
# `aria-haspopup`= "true",
# `aria-expanded`= "false",
# tags$i(class = "fa fa-gear")
# ),
# tags$ul(
# class="dropdown-menu",
# `aria-labelledby` = ns("plot_options"),
# tags$b("Delete/Clear also remove server-end files"),
# tags$li(
# style = "margin-left: 15px;",
# shinyWidgets::switchInput(
# size = "small",
# value = FALSE,
# inputId = ns("stop_on_err"),
# offStatus = "danger",
# width = "50%"
# )
# )
# )
# ),
actionButton("a", "", icon = icon("minus"), class = "")
)
),
div(
style = "position: relative; height: 100%;",
div(
class = "rs_plot",
div(class = "rs_plot_arrow",
actionButton("rs-plot-left", "",
icon = icon("chevron-left")
)
),
div(class = "text-center rs_plot_container",
id = "rs_plot",
tags$img()
),
div(class = "rs_plot_arrow arrow_right",
actionButton("rs-plot-right", "",
icon = icon("chevron-right")
)
)
),
fluidRow(
class = "rs_plot_footer",
style = "position: relative; height: 5%",
actionButton(
"rs-plot-trash", "", icon = icon("trash"),
`data-toggle`="tooltip",
`data-placement`="top",
title="delete current plot"
),
actionButton(
"rs-plot-clear", "", icon = icon("broom"),
`data-toggle`="tooltip",
`data-placement`="top",
title="clear all plots"
),
h5("0 / 0"),
actionButton(
"rs-plot-canvas", "", icon = icon("paintbrush"),
`data-toggle`="tooltip",
`data-placement`="top",
title="Send to canvas",
onclick=paste0('toCanvas("', "#rs_plot img", '", "', "core_canvas", '");
if(toastr) toastr.info("Sceenshot sent to Canvas", "", {positionClass: "toast-bottom-right", timeOut: 2000});
')
),
actionButton(
"rs-plot-png", "", icon = icon("file-image"),
`data-toggle`="tooltip",
`data-placement`="top",
title="Save as image",
onclick = paste0('toPng("', '#rs_plot img', '")')
)
)
)
)
)
)
)
)
)
}
## server
#' @importFrom shinyWidgets actionBttn confirmSweetAlert
#' @importFrom shinyjs toggleState
#' @noRd
core_topServer <- function(id, shared){
module <- function(input, output, session){
pushbar::setup_pushbar(blur = TRUE, overlay = TRUE)
ns <- session$ns
# update session status ----
rs_status_text <- reactiveVal("")
update_rs <- observe({
invalidateLater(1000)
text_new <- utils::capture.output(shared$wf$rs$print())
req(rs_status_text() != text_new)
shinyjs::html("rs_status", text_new)
if(shared$wf$rs$get_state() == "busy"){
shinyjs::addCssClass("rs_status", "text-warning sps-blink")
shinyjs::removeCssClass("rs_status", "text-success")
shinyjs::show("console_stop", anim = TRUE, animType = "fade")
} else {
shinyjs::addCssClass("rs_status", "text-success")
shinyjs::removeCssClass("rs_status", "text-warning sps-blink")
shinyjs::hide("console_stop", anim = TRUE, animType = "fade")
}
rs_status_text(text_new)
}, suspended = TRUE)
## toggle rs indicator text switch
observeEvent(shared$wf$rs_info$created, ignoreInit = TRUE, {
if(shared$wf$rs_info$created) {
update_rs$resume()
ob_log$resume()
ob_log_plot$resume()
}
else {
update_rs$suspend()
ob_log$suspend()
ob_log_plot$suspend()
shinyjs::html("rs_status", "no R session active")
shinyjs::removeCssClass("rs_status", "text-success")
shinyjs::removeCssClass("rs_status", "text-warning")
}
})
# close session ----
observeEvent(input$close_push, ignoreInit = TRUE, {
if(shared$wf$rs$get_state() == "busy") shinytoastr::toastr_warning(
"Session is still busy", position = "bottom-right"
)
shinyWidgets::confirmSweetAlert(
session,
inputId = ns("confirm_close"),
title = "Close current session?",
text = if (shared$wf$rs$get_state() == "busy") "Session is running! Any running workflow or R code will be stopped, and it may cause error. Unsaved data will be lost."
else "Unsaved data will be lost.",
type = if(shared$wf$rs$get_state() == "busy") "warning" else "info"
)
})
observeEvent(input$confirm_close, ignoreInit = TRUE, {
req(input$confirm_close)
# destroy observers
update_rs$suspend()
out_watcher$suspend()
plot_watcher$suspend()
ob_log$suspend()
ob_log_plot$suspend()
# update status
shared$wf$wf_session_open <- FALSE
try({shared$wf$rs$close(); shared$wf$rs$finalize()}, silent = TRUE)
shared$wf$rs_info$created <- FALSE
shared$wf$rs <- NULL
shared$wf$rs_info$log_name <- NULL
shared$wf$rs_info$log_path <- NULL
# close session
pushbar::pushbar_close()
shinytoastr::toastr_info(
glue("Workflow session {shared$wf$rs_info$pid} closed."),
position = "bottom-right", timeOut = 2000)
shared$wf$rs_info$pid <- NULL
options(width = if(!is.null(spsOption("console_width"))) spsOption("console_width") else 80)
})
# init editor code ----
# observeEvent(shared$wf$wf_session_open, {
# req(shared$wf$wf_session_open)
# if(!emptyIsFalse(shared$wf$wf_path))
# toastr_warning("Workflow path not detected", position = "bottom-right", timeOut = 3000)
# updateAceEditor(
# session = session, editorId = "code",
# value = glue(
# '
# sysargslist <- systemPipeR::initWF(script="{shared$wf$wf_path}", overwrite = TRUE)
# sysargslist <- systemPipeR::configWF(x=sysargslist)
# sysargslist <- systemPipeR::runWF(sysargslist = sysargslist, steps = "ALL")
# sysargslist
# ')
# )
# }, ignoreInit = TRUE)
## run code ----
err <- reactiveVal(NULL)
res <- reactiveVal(NULL)
last_stdout <- reactiveVal(NULL)
log_start_n <- reactiveVal(0)
log_path <- reactive(shared$wf$rs_info$log_path)
code_que <- reactiveVal(list())
code_submitted <- reactiveVal(FALSE)
# need to create a que hold code
observeEvent(input$eval, ignoreInit = TRUE, {
req(shared$wf$rs_info$created)
err(NULL); res(NULL)
if(!emptyIsFalse(input$code))
toastr_error("No code to run", position = "bottom-right", timeOut = 3000)
req(input$code)
shinyjs::hide("eval")
shinyjs::show("loading_eval")
## add code to queue
code_que(tryCatch(
rlang::parse_exprs(input$code),
error = function(e){
err_msg <- str_split(e$message, "\n") %>% unlist()
err_msg[1] <- paste0("Code parsing ERROR, illegal R code in : ", err_msg[1])
for(i in err_msg){
insertUI(
selector = paste0("#", ns("output")),
ui = p(class = "text-danger", i))
}
shinyjs::hide("loading_eval")
shinyjs::show("eval")
}
))
})
# start to send code ----
observeEvent(code_que(), ignoreInit = TRUE, {
if(!emptyIsFalse(code_que())){
shinyjs::hide("loading_eval")
shinyjs::show("eval")
}
req(emptyIsFalse(code_que()))
## update console
shinyCatch({
code <- rlang::expr_text(code_que()[[1]]) %>% str_split("\n") %>% unlist()
code[1] = paste0("> ", code[1])
for(i in code){
insertUI(
selector = paste0("#", ns("output")),
ui = p(class = "text-primary", i))
}
}, blocking_level = "error")
## send code to child
shared$wf$rs$call(function(code) {
on.exit({
if(!is.null(ggplot2::last_plot())) {
grid::grid.draw(ggplot2::last_plot())
dev.off()
ggplot2::set_last_plot(NULL)
.cur_plot <<- NULL
}
if(dev.cur() != 1){
if(!identical(.cur_plot, recordPlot())){
.cur_plot <<- recordPlot()
png(file.path(
.rs_dir,
paste0(
"plot",
stringr::str_pad(.plot_num, 3, pad = "0"),
"_001.png")
))
replayPlot(.cur_plot); dev.off()
.plot_num <<- .plot_num + 1
}
}
})
eval(code, env = .GlobalEnv)
}, args = list(
code = code_que()[[1]]
))
code_submitted(TRUE)
})
# turn on output watcher
observeEvent(code_submitted(), {
req(code_submitted())
# if(emptyIsFalse(que())) out_watcher$suspend()
out_watcher$resume()
})
# watch for console output ----
out_watcher <- observe(suspended = TRUE, {
invalidateLater(1000)
req(shared$wf$rs)
if(shared$wf$rs$poll_process(1) == "timeout"){
## while code still running
log_current_n <- R.utils::countLines(log_path())
new_lines <- NULL
if(log_start_n() < log_current_n) new_lines <- readr::read_lines(log_path(), skip = log_start_n())
for(i in new_lines){
insertUI(selector = paste0("#", ns("output")), ui = p(i))
}
log_start_n(log_current_n)
} else {
## when code finished
rs_out <- shared$wf$rs$read()
res <- rs_out$result
if(inherits(res, "ggplot")) res <- NULL # prevent ggplot to be rendered on parent
res <- utils::capture.output(rs_out$result)
if(is.character(res)) res <- remove_ANSI(res)
## mute output for certain functions
if(rlang::expr_text(code_que()[1][[1]]) %>%
stringr::str_detect(
paste0(
"^",
"(print\\()|",
"(library\\()"
))
){
res <- NULL # handle print resulting duplicates on console
}
if(length(res) < 1) res <- NULL # prevent character(0) capture
else if(length(res) > 1) NULL # do nothing if > 1
else if(res == "NULL") res <- NULL # mute NULL output
if(length(res) > 100){
insertUI(
selector = paste0("#", ns("output")),
ui = p(tags$b(class = "text-warning", "You are outputing too many lines to console, only display first 100"))
)
res <- res[seq(100)]
}
for(i in res) insertUI(selector = paste0("#", ns("output")), ui = p(class = "text-info", paste0(i)))
if(!is.null(rs_out$error)){
err <- rs_out$error %>% utils::capture.output()
for(i in err) insertUI(selector = paste0("#", ns("output")), ui = p(class = "text-danger", paste0(i)))
toastr_error(title = "ERROR", message = "Check console output", position = "bottom-right", timeOut = 3000)
if(emptyIsFalse(input$stop_on_err)){
code_que(list())
}
}
code_que(isolate(code_que())[-1]) # clear top line in queue
code_submitted(FALSE) # turn off output watcher
}
})
# rs interrupt ----
observeEvent(input$console_stop, {
req(shared$wf$rs$get_state() == "busy")
shared$wf$rs$interrupt()
code_que(list())
})
# update plots ----
rs_plots <- reactiveValues(plots_new = c(), plots_done = c(), plots_done_md5 = c())
plot_watcher <- observe(suspended = TRUE, {
invalidateLater(3000)
plots <- shinyCatch({fs::dir_ls(shared$wf$rs_info$rs_dir, glob = "*.png", type = "file")}, blocking_level = "error")
# watch for finished plots
plots_size <- fs::file_size(plots)
plots_done_new <- plots[plots_size > 0]
req(!identical(plots_done_new, rs_plots$plots_done))
plots_done_new <- plots_done_new[!plots_done_new %in% rs_plots$plots_done]
req(length(plots_done_new) > 0) # stop if no new plot
plots_done_pass <- plots_done_new[!plots_done_new %in% rs_plots$plots_new]
## check for previously unfinished but currently done plots
plots_check <- rs_plots$plots_new[plots_done_new %in% rs_plots$plots_new]
if(length(plots_check) > 0){
plots_check_md5 <- lapply(plots_check, function(x) openssl::md5(file(x)) %>% as.character) %>%
unlist()
### remove them if one copy is in the stack
file.remove(plots_check[plots_check_md5 %in% rs_plots$plots_done_md5])
plots_check <- plots_check[!plots_check_md5 %in% rs_plots$plots_done_md5]
}
# watch for not finished plots
rs_plots$plots_new <- plots[plots_size == 0]
## combine all new plots
plots_done_all <- c(plots_done_pass, plots_check)
req(length(plots_done_all) > 0)
## update done plots
rs_plots$plots_done <- c(isolate(rs_plots$plots_done), plots_done_all)
## update md5s
md5s <- lapply(plots_done_all, function(x) openssl::md5(file(x)) %>% as.character) %>%
unlist()
rs_plots$plots_done_md5 <- c(isolate(rs_plots$plots_done_md5), md5s)
## send to front
session$sendCustomMessage("rs_plot", as.list(plots_done_all %>% basename() %>% paste0("rs/", .)))
})
# start to watch plot when rs is active
observeEvent(shared$wf$rs_info$created, {
if(shared$wf$rs_info$created){
plot_watcher$resume()
} else {
plot_watcher$suspend()
}
})
# clear console
observeEvent(input$clear_console, ignoreInit = TRUE, {
removeUI(selector = paste0("#", ns("output"), " > *"), multiple = TRUE, immediate = TRUE)
})
## capture SPR logs----
observeEvent(1, {
output$logs <- renderUI({
tagList(lapply(seq(10), function(x) br()))
})
}, once = TRUE)
logs <- reactiveVal(NULL)
log_old <- reactiveVal("")
ob_log <- observe(suspended = TRUE, {
invalidateLater(10000, session)
req(dir.exists(file.path(shared$wf$env_path, ".SPRproject")))
log_file <- shinyCatch({
fs::dir_ls(file.path(shared$wf$env_path, ".SPRproject"), glob = "*_logWF_*", type = "file") %>%
{.[file.mtime(.) %>% which.max()]}
},blocking_level = "error", shiny = FALSE)
req(length(log_file) > 0)
log_mtime <- file.mtime(log_file)
req(!identical(log_mtime, log_old()))
logs(readLines(log_file))
log_old(log_mtime)
output$logs <- renderUI({
markdown(logs())
})
Sys.sleep(1)
updateProgressBar(session, "update_log", 100)
})
ob_log_plot <- observe(suspended = TRUE, {
invalidateLater(10000, session)
req(dir.exists(file.path(shared$wf$env_path, ".SPRproject")))
updateProgressBar(session, "update_log", 0)
sal_yaml <- file.path(shared$wf$env_path, ".SPRproject", "SYSargsList.yml")
req(file.exists(sal_yaml))
sal <- spsUtil::quiet(try(systemPipeR::SPRproject(projPath = shared$wf$env_path, resume = TRUE), TRUE))
req(inherits(sal, "SYSargsList"))
output$status_plot <- systemPipeR::renderPlotwf({
systemPipeR::plotWF(sal, rstudio = TRUE, plot_ctr = FALSE)
})
Sys.sleep(1)
updateProgressBar(session, "update_log", 100)
})
# kill/clean wf session on end ----
session$onEnded(function(){
try({shared$wf$rs$close(); shared$wf$rs$finalize()}, silent = TRUE)
options(width = {wd <- spsOption("console_width") ;if(is.numeric(wd)) wd else 80})
})
}
moduleServer(id, module)
}
systemPipeR/systemPipeS documentation built on Oct. 21, 2023, 12:18 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions core_topUI
## UI
########### loaded but not in use under current SPS version
#' @noRd
core_topUI <- function(id){
ns <- NS(id)
init <-
"sal <- systemPipeR::SPRproject(resume = TRUE)
sal <- systemPipeR::runWF(sal)
sal"
div(
tags$script(src = "sps/js/split1.6.0.js"),
pushbar::pushbar_deps(),
pushbar::pushbar(
id = ns("wf_push"),
from = "top",
style= "background:#ECF0F5; padding:5px; min-height:100vh; overflow-y:auto; overflow-x: hidden;",
tagList(
fluidRow(
div(style = " text-align: center;",
shinyWidgets::actionBttn(ns("close_push"),
style = "simple",
label = "Close this workflow session",
icon = icon("xmark"),
color = "danger",
size = "sm")) %>%
bsHoverPopover(
"Close this session",
"Clicking here kills the workflow R session, clear all data
stored in that R session and reset
your working directory to SPS app directory. If you have
workflow jobs running, they will be forced to terminate.",
"bottom"
)
),
div(
style = "height: 95vh;",
div(
id = ns("leftcol"), class = "split split-horizontal", style = "overflow: hidden;",
# source code ----
div( id = ns("source_code"), class ="split split-content",
div(
class = "split-header",
h3("Source Code", class = "split-title"),
div(class = "split-tool", actionButton("a", "", icon = icon("minus"), class = ""))
),
div(
class = "split-body", style = "position: relative;",
aceEditor(
ns("code"), mode = "r", height = "30vh", value = init,
autoComplete = "live", fontSize = 14,
autoCompleters = c("static", "text"),
autoScrollEditorIntoView = TRUE,
maxLines = 9999,
debounce = 10,
autoCompleteList = getNamespaceExports("systemPipeR") %>%
{.[!str_detect(., "^\\.")]} %>%
{paste0("systemPipeR::", .)} %>%
list(systemPipeR = .)) %>%
{.[[2]][["attribs"]][["style"]] = "height: 30vh; min-height: 30vh;"; .},
fluidRow(
column(6,
actionButton(ns("eval"), "Run"),
div(id = ns("loading_eval"), style = "display: none;",
spsLoader())
),
column(6,
tags$b(class = "pull-right", id = ns("rs_status"), "No active R session")
)
),
tags$p("There is about one second delay sending code from UI to
backend. Wait a second after editing code before hitting 'Run'.")
)
),
# console ----
div( id = ns("console"), class ="split split-content",
div(
class = "split-header",
h3("Console Output", class = "split-title"),
div(
class = "split-tool",
actionButton(
ns("console_stop"), "",
class = "shinyjs-hide",
icon = icon("stop"),
`data-toggle`="tooltip",
`data-placement`="bottom",
title="Interrupt session"
),
tags$style(glue('
#@{ns("console_stop")}@ .fa-stop {color: #d03e3b;}
', .open = "@{", .close = "}@")),
div(
class = "dropdown",
# `data-toggle`="tooltip",
# `data-placement`="top",
# title = "console options",
style = "display: inline;",
tags$button(
class="btn btn-default dropdown-toggle",
type = "button",
id = ns("out_options"),
`data-toggle` = "dropdown",
`aria-haspopup`= "true",
`aria-expanded`= "false",
tags$i(class = "fa fa-gears")
),
tags$ul(
class="dropdown-menu",
`aria-labelledby` = ns("out_options"),
tags$li(class = "dropdown-header", "Stop on error"),
tags$li(
style = "margin-left: 15px;",
shinyWidgets::switchInput(
size = "mini",
value = TRUE,
inputId = ns("stop_on_err"),
offStatus = "danger",
width = "50%"
)
)
)
),
actionButton(
ns("clear_console"), "",
icon = icon("trash"),
`data-toggle`="tooltip",
`data-placement`="bottom",
title="clear console"
),
actionButton("a", "", icon = icon("minus"), class = "")
)
),
div(
class = "split-body",
verbatimTextOutput(ns("output")) %>%
{.$attribs[['style']] <- " margin:0; overflow: visible;"; .}
)
)
),
div(
id = ns("rightcol"), class ="split split-horizontal",
# wf log ----
div(
id = ns("wf_log"), class ="split split-content",
div(
class = "split-header",
h3("Workflow Status", class = "split-title"),
div(
class = "split-tool",
actionButton("a", "", icon = icon("minus"), class = "")
)
),
div(class = "split-body",
tabsetPanel(
tabPanel(
"Status Plot",
systemPipeR::plotwfOutput(ns("status_plot"))
),
tabPanel(
"Workflow log",
uiOutput(ns("logs")) %>%
{.$attribs[['style']] <- " margin:0; overflow: visible;"; .},
)
),
div(style="width:100%", spsHr()),
p("This panel always displays the most recent
workflow status and log stored in `.SPRproject` folder, updates every 10s."),
div(
style="height:5px; width:100%",
shinyWidgets::progressBar(
ns("update_log"), value = 0,
status = "primary", striped = TRUE,
size = "xs"
)
)
)
),
# plot ----
div(
id = ns("plot_panel"), class ="split split-content",
div(
class = "split-header",
h3("Plots", class = "split-title"),
div(
class = "split-tool",
# div(
# class = "dropdown",
# style = "display: inline;",
# tags$button(
# class="btn btn-default dropdown-toggle",
# type = "button",
# id = ns("plot_options"),
# `data-toggle` = "dropdown",
# `aria-haspopup`= "true",
# `aria-expanded`= "false",
# tags$i(class = "fa fa-gear")
# ),
# tags$ul(
# class="dropdown-menu",
# `aria-labelledby` = ns("plot_options"),
# tags$b("Delete/Clear also remove server-end files"),
# tags$li(
# style = "margin-left: 15px;",
# shinyWidgets::switchInput(
# size = "small",
# value = FALSE,
# inputId = ns("stop_on_err"),
# offStatus = "danger",
# width = "50%"
# )
# )
# )
# ),
actionButton("a", "", icon = icon("minus"), class = "")
)
),
div(
style = "position: relative; height: 100%;",
div(
class = "rs_plot",
div(class = "rs_plot_arrow",
actionButton("rs-plot-left", "",
icon = icon("chevron-left")
)
),
div(class = "text-center rs_plot_container",
id = "rs_plot",
tags$img()
),
div(class = "rs_plot_arrow arrow_right",
actionButton("rs-plot-right", "",
icon = icon("chevron-right")
)
)
),
fluidRow(
class = "rs_plot_footer",
style = "position: relative; height: 5%",
actionButton(
"rs-plot-trash", "", icon = icon("trash"),
`data-toggle`="tooltip",
`data-placement`="top",
title="delete current plot"
),
actionButton(
"rs-plot-clear", "", icon = icon("broom"),
`data-toggle`="tooltip",
`data-placement`="top",
title="clear all plots"
),
h5("0 / 0"),
actionButton(
"rs-plot-canvas", "", icon = icon("paintbrush"),
`data-toggle`="tooltip",
`data-placement`="top",
title="Send to canvas",
onclick=paste0('toCanvas("', "#rs_plot img", '", "', "core_canvas", '");
if(toastr) toastr.info("Sceenshot sent to Canvas", "", {positionClass: "toast-bottom-right", timeOut: 2000});
')
),
actionButton(
"rs-plot-png", "", icon = icon("file-image"),
`data-toggle`="tooltip",
`data-placement`="top",
title="Save as image",
onclick = paste0('toPng("', '#rs_plot img', '")')
)
)
)
)
)
)
)
)
)
}
## server
#' @importFrom shinyWidgets actionBttn confirmSweetAlert
#' @importFrom shinyjs toggleState
#' @noRd
core_topServer <- function(id, shared){
module <- function(input, output, session){
pushbar::setup_pushbar(blur = TRUE, overlay = TRUE)
ns <- session$ns
# update session status ----
rs_status_text <- reactiveVal("")
update_rs <- observe({
invalidateLater(1000)
text_new <- utils::capture.output(shared$wf$rs$print())
req(rs_status_text() != text_new)
shinyjs::html("rs_status", text_new)
if(shared$wf$rs$get_state() == "busy"){
shinyjs::addCssClass("rs_status", "text-warning sps-blink")
shinyjs::removeCssClass("rs_status", "text-success")
shinyjs::show("console_stop", anim = TRUE, animType = "fade")
} else {
shinyjs::addCssClass("rs_status", "text-success")
shinyjs::removeCssClass("rs_status", "text-warning sps-blink")
shinyjs::hide("console_stop", anim = TRUE, animType = "fade")
}
rs_status_text(text_new)
}, suspended = TRUE)
## toggle rs indicator text switch
observeEvent(shared$wf$rs_info$created, ignoreInit = TRUE, {
if(shared$wf$rs_info$created) {
update_rs$resume()
ob_log$resume()
ob_log_plot$resume()
}
else {
update_rs$suspend()
ob_log$suspend()
ob_log_plot$suspend()
shinyjs::html("rs_status", "no R session active")
shinyjs::removeCssClass("rs_status", "text-success")
shinyjs::removeCssClass("rs_status", "text-warning")
}
})
# close session ----
observeEvent(input$close_push, ignoreInit = TRUE, {
if(shared$wf$rs$get_state() == "busy") shinytoastr::toastr_warning(
"Session is still busy", position = "bottom-right"
)
shinyWidgets::confirmSweetAlert(
session,
inputId = ns("confirm_close"),
title = "Close current session?",
text = if (shared$wf$rs$get_state() == "busy") "Session is running! Any running workflow or R code will be stopped, and it may cause error. Unsaved data will be lost."
else "Unsaved data will be lost.",
type = if(shared$wf$rs$get_state() == "busy") "warning" else "info"
)
})
observeEvent(input$confirm_close, ignoreInit = TRUE, {
req(input$confirm_close)
# destroy observers
update_rs$suspend()
out_watcher$suspend()
plot_watcher$suspend()
ob_log$suspend()
ob_log_plot$suspend()
# update status
shared$wf$wf_session_open <- FALSE
try({shared$wf$rs$close(); shared$wf$rs$finalize()}, silent = TRUE)
shared$wf$rs_info$created <- FALSE
shared$wf$rs <- NULL
shared$wf$rs_info$log_name <- NULL
shared$wf$rs_info$log_path <- NULL
# close session
pushbar::pushbar_close()
shinytoastr::toastr_info(
glue("Workflow session {shared$wf$rs_info$pid} closed."),
position = "bottom-right", timeOut = 2000)
shared$wf$rs_info$pid <- NULL
options(width = if(!is.null(spsOption("console_width"))) spsOption("console_width") else 80)
})
# init editor code ----
# observeEvent(shared$wf$wf_session_open, {
# req(shared$wf$wf_session_open)
# if(!emptyIsFalse(shared$wf$wf_path))
# toastr_warning("Workflow path not detected", position = "bottom-right", timeOut = 3000)
# updateAceEditor(
# session = session, editorId = "code",
# value = glue(
# '
# sysargslist <- systemPipeR::initWF(script="{shared$wf$wf_path}", overwrite = TRUE)
# sysargslist <- systemPipeR::configWF(x=sysargslist)
# sysargslist <- systemPipeR::runWF(sysargslist = sysargslist, steps = "ALL")
# sysargslist
# ')
# )
# }, ignoreInit = TRUE)
## run code ----
err <- reactiveVal(NULL)
res <- reactiveVal(NULL)
last_stdout <- reactiveVal(NULL)
log_start_n <- reactiveVal(0)
log_path <- reactive(shared$wf$rs_info$log_path)
code_que <- reactiveVal(list())
code_submitted <- reactiveVal(FALSE)
# need to create a que hold code
observeEvent(input$eval, ignoreInit = TRUE, {
req(shared$wf$rs_info$created)
err(NULL); res(NULL)
if(!emptyIsFalse(input$code))
toastr_error("No code to run", position = "bottom-right", timeOut = 3000)
req(input$code)
shinyjs::hide("eval")
shinyjs::show("loading_eval")
## add code to queue
code_que(tryCatch(
rlang::parse_exprs(input$code),
error = function(e){
err_msg <- str_split(e$message, "\n") %>% unlist()
err_msg[1] <- paste0("Code parsing ERROR, illegal R code in : ", err_msg[1])
for(i in err_msg){
insertUI(
selector = paste0("#", ns("output")),
ui = p(class = "text-danger", i))
}
shinyjs::hide("loading_eval")
shinyjs::show("eval")
}
))
})
# start to send code ----
observeEvent(code_que(), ignoreInit = TRUE, {
if(!emptyIsFalse(code_que())){
shinyjs::hide("loading_eval")
shinyjs::show("eval")
}
req(emptyIsFalse(code_que()))
## update console
shinyCatch({
code <- rlang::expr_text(code_que()[[1]]) %>% str_split("\n") %>% unlist()
code[1] = paste0("> ", code[1])
for(i in code){
insertUI(
selector = paste0("#", ns("output")),
ui = p(class = "text-primary", i))
}
}, blocking_level = "error")
## send code to child
shared$wf$rs$call(function(code) {
on.exit({
if(!is.null(ggplot2::last_plot())) {
grid::grid.draw(ggplot2::last_plot())
dev.off()
ggplot2::set_last_plot(NULL)
.cur_plot <<- NULL
}
if(dev.cur() != 1){
if(!identical(.cur_plot, recordPlot())){
.cur_plot <<- recordPlot()
png(file.path(
.rs_dir,
paste0(
"plot",
stringr::str_pad(.plot_num, 3, pad = "0"),
"_001.png")
))
replayPlot(.cur_plot); dev.off()
.plot_num <<- .plot_num + 1
}
}
})
eval(code, env = .GlobalEnv)
}, args = list(
code = code_que()[[1]]
))
code_submitted(TRUE)
})
# turn on output watcher
observeEvent(code_submitted(), {
req(code_submitted())
# if(emptyIsFalse(que())) out_watcher$suspend()
out_watcher$resume()
})
# watch for console output ----
out_watcher <- observe(suspended = TRUE, {
invalidateLater(1000)
req(shared$wf$rs)
if(shared$wf$rs$poll_process(1) == "timeout"){
## while code still running
log_current_n <- R.utils::countLines(log_path())
new_lines <- NULL
if(log_start_n() < log_current_n) new_lines <- readr::read_lines(log_path(), skip = log_start_n())
for(i in new_lines){
insertUI(selector = paste0("#", ns("output")), ui = p(i))
}
log_start_n(log_current_n)
} else {
## when code finished
rs_out <- shared$wf$rs$read()
res <- rs_out$result
if(inherits(res, "ggplot")) res <- NULL # prevent ggplot to be rendered on parent
res <- utils::capture.output(rs_out$result)
if(is.character(res)) res <- remove_ANSI(res)
## mute output for certain functions
if(rlang::expr_text(code_que()[1][[1]]) %>%
stringr::str_detect(
paste0(
"^",
"(print\\()|",
"(library\\()"
))
){
res <- NULL # handle print resulting duplicates on console
}
if(length(res) < 1) res <- NULL # prevent character(0) capture
else if(length(res) > 1) NULL # do nothing if > 1
else if(res == "NULL") res <- NULL # mute NULL output
if(length(res) > 100){
insertUI(
selector = paste0("#", ns("output")),
ui = p(tags$b(class = "text-warning", "You are outputing too many lines to console, only display first 100"))
)
res <- res[seq(100)]
}
for(i in res) insertUI(selector = paste0("#", ns("output")), ui = p(class = "text-info", paste0(i)))
if(!is.null(rs_out$error)){
err <- rs_out$error %>% utils::capture.output()
for(i in err) insertUI(selector = paste0("#", ns("output")), ui = p(class = "text-danger", paste0(i)))
toastr_error(title = "ERROR", message = "Check console output", position = "bottom-right", timeOut = 3000)
if(emptyIsFalse(input$stop_on_err)){
code_que(list())
}
}
code_que(isolate(code_que())[-1]) # clear top line in queue
code_submitted(FALSE) # turn off output watcher
}
})
# rs interrupt ----
observeEvent(input$console_stop, {
req(shared$wf$rs$get_state() == "busy")
shared$wf$rs$interrupt()
code_que(list())
})
# update plots ----
rs_plots <- reactiveValues(plots_new = c(), plots_done = c(), plots_done_md5 = c())
plot_watcher <- observe(suspended = TRUE, {
invalidateLater(3000)
plots <- shinyCatch({fs::dir_ls(shared$wf$rs_info$rs_dir, glob = "*.png", type = "file")}, blocking_level = "error")
# watch for finished plots
plots_size <- fs::file_size(plots)
plots_done_new <- plots[plots_size > 0]
req(!identical(plots_done_new, rs_plots$plots_done))
plots_done_new <- plots_done_new[!plots_done_new %in% rs_plots$plots_done]
req(length(plots_done_new) > 0) # stop if no new plot
plots_done_pass <- plots_done_new[!plots_done_new %in% rs_plots$plots_new]
## check for previously unfinished but currently done plots
plots_check <- rs_plots$plots_new[plots_done_new %in% rs_plots$plots_new]
if(length(plots_check) > 0){
plots_check_md5 <- lapply(plots_check, function(x) openssl::md5(file(x)) %>% as.character) %>%
unlist()
### remove them if one copy is in the stack
file.remove(plots_check[plots_check_md5 %in% rs_plots$plots_done_md5])
plots_check <- plots_check[!plots_check_md5 %in% rs_plots$plots_done_md5]
}
# watch for not finished plots
rs_plots$plots_new <- plots[plots_size == 0]
## combine all new plots
plots_done_all <- c(plots_done_pass, plots_check)
req(length(plots_done_all) > 0)
## update done plots
rs_plots$plots_done <- c(isolate(rs_plots$plots_done), plots_done_all)
## update md5s
md5s <- lapply(plots_done_all, function(x) openssl::md5(file(x)) %>% as.character) %>%
unlist()
rs_plots$plots_done_md5 <- c(isolate(rs_plots$plots_done_md5), md5s)
## send to front
session$sendCustomMessage("rs_plot", as.list(plots_done_all %>% basename() %>% paste0("rs/", .)))
})
# start to watch plot when rs is active
observeEvent(shared$wf$rs_info$created, {
if(shared$wf$rs_info$created){
plot_watcher$resume()
} else {
plot_watcher$suspend()
}
})
# clear console
observeEvent(input$clear_console, ignoreInit = TRUE, {
removeUI(selector = paste0("#", ns("output"), " > *"), multiple = TRUE, immediate = TRUE)
})
## capture SPR logs----
observeEvent(1, {
output$logs <- renderUI({
tagList(lapply(seq(10), function(x) br()))
})
}, once = TRUE)
logs <- reactiveVal(NULL)
log_old <- reactiveVal("")
ob_log <- observe(suspended = TRUE, {
invalidateLater(10000, session)
req(dir.exists(file.path(shared$wf$env_path, ".SPRproject")))
log_file <- shinyCatch({
fs::dir_ls(file.path(shared$wf$env_path, ".SPRproject"), glob = "*_logWF_*", type = "file") %>%
{.[file.mtime(.) %>% which.max()]}
},blocking_level = "error", shiny = FALSE)
req(length(log_file) > 0)
log_mtime <- file.mtime(log_file)
req(!identical(log_mtime, log_old()))
logs(readLines(log_file))
log_old(log_mtime)
output$logs <- renderUI({
markdown(logs())
})
Sys.sleep(1)
updateProgressBar(session, "update_log", 100)
})
ob_log_plot <- observe(suspended = TRUE, {
invalidateLater(10000, session)
req(dir.exists(file.path(shared$wf$env_path, ".SPRproject")))
updateProgressBar(session, "update_log", 0)
sal_yaml <- file.path(shared$wf$env_path, ".SPRproject", "SYSargsList.yml")
req(file.exists(sal_yaml))
sal <- spsUtil::quiet(try(systemPipeR::SPRproject(projPath = shared$wf$env_path, resume = TRUE), TRUE))
req(inherits(sal, "SYSargsList"))
output$status_plot <- systemPipeR::renderPlotwf({
systemPipeR::plotWF(sal, rstudio = TRUE, plot_ctr = FALSE)
})
Sys.sleep(1)
updateProgressBar(session, "update_log", 100)
})
# kill/clean wf session on end ----
session$onEnded(function(){
try({shared$wf$rs$close(); shared$wf$rs$finalize()}, silent = TRUE)
options(width = {wd <- spsOption("console_width") ;if(is.numeric(wd)) wd else 80})
})
}
moduleServer(id, module)
}
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.