diff --git a/Dockerfile b/Dockerfile
index 8284d59..e9e0390 100644
--- a/Dockerfile
+++ b/Dockerfile
@@ -4,7 +4,7 @@ RUN apt-get update -y && apt-get install -y libssh-dev python3-pip git libmariad
RUN R -q -e 'install.packages(c("ellipsis"), repos="https://cran.rstudio.com/")'
RUN R -q -e 'install.packages(c("shiny"), repos="https://cran.rstudio.com/")'
-RUN R -q -e 'install.packages(c("shinyFeedback", "shinyWidgets", "shinydashboard", "shinydashboardPlus", "ssh", "remotes", "markdown", "lubridate", "jsonlite", "dplyr", "DT", "glue", "httr", "purrr", "RColorBrewer", "rlang", "shinyBS", "shinyjs", "tidyverse", "uuid", "memoise", "rclipboard", "shinyvalidate", "shinylogs", "testhat", "bsicons", "listviewer", "htmltools", "cookies", "RMariaDB", "DBI", "parsedate", "testthat", "shinylogs", "ids"), repos="https://cran.r-project.org")'
+RUN R -q -e 'install.packages(c("shinyFeedback", "shinyWidgets", "shinydashboard", "shinydashboardPlus", "ssh", "remotes", "markdown", "lubridate", "jsonlite", "dplyr", "DT", "glue", "httr", "purrr", "RColorBrewer", "rlang", "shinyBS", "shinyjs", "tidyverse", "uuid", "memoise", "rclipboard", "shinyvalidate", "shinylogs", "testhat", "bsicons", "listviewer", "htmltools", "cookies", "RMariaDB", "DBI", "parsedate", "testthat", "shinylogs", "ids", "shinycssloaders"), repos="https://cran.r-project.org")'
RUN R -q -e "remotes::install_github('getwilds/proofr@v0.3.0')"
diff --git a/app/about.md b/app/about.md
index 53a2814..dad4112 100644
--- a/app/about.md
+++ b/app/about.md
@@ -1,5 +1,7 @@
-### Resources
+### Getting Help with PROOF and WDL at Fred Hutch
- Get started with PROOF [How-To documentation](https://sciwiki.fredhutch.org/dasldemos/proof-how-to/) and [troubleshooting tips](https://sciwiki.fredhutch.org/dasldemos/proof-troubleshooting/)
+- Ask a question about or report a problem with PROOF in our [GitHub repository](https://github.com/getwilds/proof/issues/new?template=Blank+issue)
+- Email us at [wilds@fredhutch.org](mailto:wilds@fredhutch.org)
- Find curated WDL workflow repositories and containers in Fred Hutch [DaSL's getWILDS GitHub organization](https://github.com/orgs/getwilds/repositories?q=wdl).
- Find Cromwell and WDL Resources in [Fred Hutch's GitHub organization](https://github.com/FredHutch?utf8=%E2%9C%93&q=wdl+OR+cromwell&type=&language=).
- Learn about Cromwell and WDL on the [Fred Hutch Biomedical Data Science Wiki](https://sciwiki.fredhutch.org/compdemos/Cromwell/).
@@ -10,7 +12,7 @@
## Users Elsewhere
This Shiny app and the R packages it relies on are all open source. Thus, if you are at a different institution and want to use this application to support your work or your users, we encourage you to look through our resources and fork our repositories. Feel free to contact DaSL developers by filing issues or emailing `wilds@fredhutch.org`. For this use case, we have provided the more general "DIY Cromwell" login button at the top.
-### Resources
+### Some Resources for Using Cromwell
- DIY: Get a Cromwell server running by yourself (does not require logging in). To learn more about how to get your Cromwell server running, read through the instructions in the GitHub repo [FredHutch/diy-cromwell-server](https://github.com/FredHutch/diy-cromwell-server)
- `rcromwell`: An [R package](https://github.com/getwilds/rcromwell) that makes interacting with the Cromwell API easier.
- `shiny-cromwell`: This app's [GitHub repo](https://github.com/FredHutch/shiny-cromwell) contains information on how to set started with this application.
diff --git a/app/buttons.R b/app/buttons.R
index 1f2fc9f..19bef6c 100644
--- a/app/buttons.R
+++ b/app/buttons.R
@@ -2,7 +2,8 @@ logInButton <-
actionButton(
inputId = "proofAuth",
label = "PROOF Login",
- class = "btn-sm",
+ class = "btn-success btn-sm",
+ style = "color: white;",
icon = icon("truck-fast")
)
@@ -20,6 +21,7 @@ logInCromwellButton <-
inputId = "ownCrom",
label = "DIY Cromwell",
class = "btn-sm",
+ style = "color: white;",
icon = icon("plug-circle-xmark")
)
logOutCromwellButton <-
diff --git a/app/modals.R b/app/modals.R
index 464e939..9ee890f 100644
--- a/app/modals.R
+++ b/app/modals.R
@@ -13,7 +13,11 @@ loginModal <- function(failed = FALSE, error = "Invalid username or password") {
},
footer = tagList(
modalButton("Cancel"),
- actionButton("submit", "Submit")
+ shinyFeedback::loadingButton(
+ inputId = "submit",
+ label = "Submit",
+ class = "btn btn-default"
+ )
),
easyClose = TRUE
)
diff --git a/app/server.R b/app/server.R
index 2167472..eb83f54 100644
--- a/app/server.R
+++ b/app/server.R
@@ -26,6 +26,7 @@ library(rcromwell)
library(cookies)
library(listviewer)
+library(rclipboard)
library(ids)
@@ -41,7 +42,6 @@ source("cookies-db.R")
SANITIZE_ERRORS <- FALSE
PROOF_TIMEOUT <- 20
-FOCUS_ID <- 1
SHINY_LOGGING <- as.logical(Sys.getenv("SHINY_LOG", FALSE))
# FIXME: maybe remove later, was running into some timeouts during testing
@@ -57,14 +57,35 @@ server <- function(input, output, session) {
session$allowReconnect(TRUE)
- # Upper right github icon for source code
- output$gitHtml <- renderText({
- glue('Code: FredHutch/shiny-cromwell
-
- Built from: {substring(COMMIT_SHORT_SHA, 1, 7)}
-
- Last built on: {stamp("Mar 1, 1999", quiet = TRUE)(ymd_hms(COMMIT_TIMESTAMP))}
- ')
+ # For the Help page
+ output$gitHtml <- renderUI({
+ div(
+ tags$span(
+ tags$b("Code:"),
+ tags$a(
+ "FredHutch/shiny-cromwell",
+ href = glue("https://github.com/FredHutch/shiny-cromwell/tree/{COMMIT_BRANCH}"),
+ target="_blank"
+ )
+ ),
+ tags$br(),
+ tags$span(
+ tags$b("Built from:"),
+ tags$a(
+ glue("{substring(COMMIT_SHORT_SHA, 1, 7)}"),
+ href = glue("https://github.com/FredHutch/shiny-cromwell/tree/{COMMIT_SHA}"),
+ target="_blank"
+ )
+ ),
+ tags$br(),
+ tags$span(
+ tags$b('Last built on:', style = "display:inline;"),
+ tags$p(
+ glue('Last built on: {stamp("Mar 1, 1999", quiet = TRUE)(ymd_hms(COMMIT_TIMESTAMP))}'),
+ style = "display:inline;"
+ )
+ )
+ )
})
rv <- reactiveValues(token = "", url = "", validateFilepath="", own = FALSE, user = "")
@@ -76,8 +97,7 @@ server <- function(input, output, session) {
inputJSON_state = NULL,
input2JSON_state = NULL,
workOptions_state = NULL,
- abortWorkflowID_state = NULL,
- troubleWorkflowID_state = NULL
+ abortWorkflowID_state = NULL
)
# Login and UI component handling
@@ -164,6 +184,9 @@ server <- function(input, output, session) {
same_site = "strict"
)
+ # reset loading spinner
+ shinyFeedback::resetLoadingButton("submit")
+
removeModal()
}
} else {
@@ -286,6 +309,14 @@ server <- function(input, output, session) {
}
})
+ observe({
+ if (proof_loggedin_serverup(rv$url, rv$token)) {
+ shinyjs::toggleState("cromwellStart",
+ proof_status(token = rv$token)$jobStatus != "RUNNING"
+ )
+ }
+ })
+
# Disable or enable the Delete button for deleting proof server
observeEvent(input$cromwellDelete, {
showModal(verifyCromwellDeleteModal())
@@ -334,7 +365,7 @@ server <- function(input, output, session) {
cromwellProofStatusData <- reactivePoll(2000, session,
checkFunc = function() {
if (!is.null(input$tabs)) {
- if (input$tabs != "cromwell") return(NULL)
+ if (input$proof != "Server") return(NULL)
}
if (proof_loggedin(rv$token)) {
tmp <- proof_status(token = rv$token)
@@ -351,6 +382,7 @@ server <- function(input, output, session) {
proofStatusTextGenerator <- function(name, list_index, tip = "", value_if_null = NULL) {
renderUI({
if (proof_loggedin(rv$token)) {
+ dat <- cromwellProofStatusData()
if (nzchar(tip)) {
tags$span(
bslib::tooltip(
@@ -360,7 +392,7 @@ server <- function(input, output, session) {
),
HTML(paste0(
strong(glue("{name}: ")),
- purrr::flatten(cromwellProofStatusData())[[list_index]] %||% value_if_null
+ purrr::flatten(dat)[[list_index]] %||% value_if_null
))
)
} else {
@@ -368,7 +400,7 @@ server <- function(input, output, session) {
icon("question-circle"),
HTML(paste0(
strong(glue("{name}: ")),
- purrr::flatten(cromwellProofStatusData())[[list_index]] %||% value_if_null
+ purrr::flatten(dat)[[list_index]] %||% value_if_null
))
)
}
@@ -478,6 +510,7 @@ server <- function(input, output, session) {
url = rv$url,
token = rv$token
)
+ shinyjs::disable("submitWorkflow")
HTML(glue('
@@ -488,6 +521,12 @@ server <- function(input, output, session) {
})
})
+ observe({
+ shinyjs::toggleState("submitWorkflow",
+ !rlang::is_empty(input$wdlFile$datapath)
+ )
+ })
+
# reset
observeEvent(input$resetSubmission, {
reset_inputs(c(
@@ -499,37 +538,21 @@ server <- function(input, output, session) {
rv_file$input2JSON_state <- 'reset'
rv_file$workOptions_state <- 'reset'
output$submissionResult <- renderText({})
+ shinyjs::disable("submitWorkflow")
})
###### Troubleshoot tab ######
- ## Troubleshoot a workflow
- input_troubleWorkflowID <- reactive({
- reactiveInput(rv_file$troubleWorkflowID_state, input$troubleWorkflowID)
- })
- observeEvent(input$troubleWorkflowID, {
- rv_file$troubleWorkflowID_state <- 'loaded'
- })
-
- observeEvent(input$troubleWorkflow, {
+ observeEvent(input$selectedWorkflowId, {
output$troubleResult <- renderPrint({
- validate_workflowid(isolate(input$troubleWorkflowID))
stop_safe_loggedin_serverup(rv$url, rv$token, rv$own)
cromwell_glob(
- workflow_id = isolate(input_troubleWorkflowID()),
+ workflow_id = input$selectedWorkflowId,
url = rv$url,
token = rv$token
)
})
})
- ## reset trouble
- observeEvent(input$resetTrouble, {
- reset_inputs("troubleWorkflowID")
- rv_file$troubleWorkflowID_state <- 'reset'
- output$troubleResult <- renderText({})
- })
-
-
############ CROMWELL Tracking Tab ############
workflowUpdate <- eventReactive(input$trackingUpdate, {
@@ -630,11 +653,8 @@ server <- function(input, output, session) {
observeEvent(input$linkToWorkflowDetailsTab, {
nav_select("proof", "Workflow Details")
})
- observeEvent(input$linkToTroubleshootingTab, {
- nav_select("proof", "Troubleshoot")
- })
- observeEvent(input$linkToResourcesTab, {
- nav_select("proof", "Resources")
+ observeEvent(input$linkToHelpTab, {
+ nav_select("proof", "Help")
})
### go back to tracking tab from details tab
@@ -706,6 +726,10 @@ server <- function(input, output, session) {
})
# Data for cards out of workflowUpdate data
+ workflowDetailsId <- function(workflow_id) {
+ paste0("goToWorkflowDetails-", workflow_id)
+ }
+
output$workflows_cards <- renderUI({
dflst <- apply(workflowUpdate(), 1, as.list)
dat <- lapply(dflst, function(w) {
@@ -715,18 +739,23 @@ server <- function(input, output, session) {
id = glue("job_card_{w$workflow_id}"),
class = "border border-secondary",
card_header(
- w$workflow_id,
- actionButton(
- "goToWorkflowDetails",
+ div(
+ span(bsicons::bs_icon("person-badge"), w$workflow_name),
+ span("(", bsicons::bs_icon("tag-fill"), w$Label),
+ span(bsicons::bs_icon("tag"), w$secondaryLabel, ")")
+ ),
+ proofLoadingButton(
+ inputId = workflowDetailsId(w$workflow_id),
label = "Workflow Details",
- icon = icon("rectangle-list"),
- class = "btn-secondary btn-sm",
- onclick = glue('Shiny.setInputValue(\"selectedWorkflowId\", \"{w$workflow_id}\");
+ class = "btn btn-secondary btn-sm",
+ onclick = glue('
+ Shiny.setInputValue(\"selectedWorkflowId\", \"{w$workflow_id}\");
+ Shiny.setInputValue(\"selectedWorkflowName\", \"{w$workflow_name}\");
Shiny.setInputValue(\"selectedWorkflowLabel\", \"{w$Label}\");
- Shiny.setInputValue(\"selectedWorkflowSecLabel\", \"{w$secondaryLabel}\")')
+ Shiny.setInputValue(\"selectedWorkflowSecLabel\", \"{w$secondaryLabel}\")
+ ')
),
class = "d-flex justify-content-between gap-1",
- # class = "bg-secondary"
),
card_body(
class = "d-flex align-items-left justify-content-between gap-1",
@@ -741,11 +770,7 @@ server <- function(input, output, session) {
card_body(
class = "d-flex justify-content-between gap-1",
fillable = FALSE,
- div(
- span(bsicons::bs_icon("person-badge"), w$workflow_name),
- span(bsicons::bs_icon("tag-fill"), w$Label),
- span(bsicons::bs_icon("tag"), w$secondaryLabel)
- ),
+ w$workflow_id,
actionButton(
inputId = "abortWorkflow",
label = "Abort Workflow",
@@ -812,9 +837,19 @@ server <- function(input, output, session) {
)
})
- observeEvent(input$goToWorkflowDetails, {
- print(input$goToWorkflowDetails)
- nav_select("proof", "Workflow Details")
+ reactive_buttons <- reactive({
+ button_ids <- names(input)
+ button_ids[grepl("goToWorkflowDetails", button_ids)]
+ })
+
+ observe({
+ matching_ids <- reactive_buttons()
+ lapply(matching_ids, function(id) {
+ observeEvent(input[[id]], {
+ nav_select("proof", "Workflow Details")
+ shinyFeedback::resetLoadingButton(id)
+ })
+ })
})
## reset trouble
@@ -828,11 +863,27 @@ server <- function(input, output, session) {
if (!is.null(input$selectedWorkflowId)) {
htmltools::tagList(
htmltools::tags$span(
- h3("Workflow Specific Job Information", bsicons::bs_icon("caret-right"), paste(substring(input$selectedWorkflowId, 1, 13), " ...")),
+ h4(input$selectedWorkflowName, style = "display:inline"),
+ h5(
+ " (",
+ span(bsicons::bs_icon("tag-fill"), input$selectedWorkflowLabel),
+ span(bsicons::bs_icon("tag"), input$selectedWorkflowSecLabel),
+ ")",
+ style = "display:inline"
+ )
),
htmltools::tags$div(
- span(bsicons::bs_icon("tag-fill"), input$selectedWorkflowLabel),
- span(bsicons::bs_icon("tag"), input$selectedWorkflowSecLabel)
+ rclipButton(
+ inputId = "clipbtn",
+ label = "",
+ clipText = input$selectedWorkflowId,
+ icon = icon("clipboard"),
+ tooltip = "Copy workflow ID",
+ placement = "left",
+ options = list(delay = list(show = 800, hide = 100), trigger = "hover"),
+ class = "btn-secondary btn-sm"
+ ),
+ input$selectedWorkflowId
)
)
}
@@ -841,9 +892,8 @@ server <- function(input, output, session) {
## Get a table of workflow labels
workflowLabels <- eventReactive(input$selectedWorkflowId, {
print("find Labels")
- data <- workflowUpdate()
- FOCUS_ID <- input$selectedWorkflowId
- workflow <- cromwell_workflow(FOCUS_ID,
+ workflow <- cromwell_workflow(
+ workflow_id = input$selectedWorkflowId,
url = rv$url,
token = rv$token
)
@@ -881,7 +931,7 @@ server <- function(input, output, session) {
everything()
)
)
- })
+ })
output$workflowDescribe <- renderUI({
wl <- purrr::discard_at(workflowLabels(), c("workflow", "inputs"))
@@ -898,35 +948,40 @@ server <- function(input, output, session) {
}, names(workflowLabelsLst), unname(workflowLabelsLst))
)
})
- ## Get a table of workflow options
- workflowOptions <- eventReactive(input$joblistCromwell_rows_selected, {
- print("find options")
- data <- workflowUpdate()
- FOCUS_ID <- data[input$joblistCromwell_rows_selected, ]$workflow_id
+
+ ## Workflow options
+ workflowOptions <- eventReactive(input$selectedWorkflowId, {
as.data.frame(jsonlite::fromJSON(
- cromwell_workflow(FOCUS_ID,
+ cromwell_workflow(input$selectedWorkflowId,
url = rv$url,
token = rv$token
)$options
))
})
- output$workflowOpt <- renderDT(
- data <- workflowOptions(),
- class = "compact",
- filter = "top",
- options = list(scrollX = TRUE), selection = "single", rownames = FALSE
- )
- ## Get a table of workflow inputs
- workflowInputs <- eventReactive(input$selectedWorkflowId, {
- print("find inputs")
- data <- workflowUpdate()
- FOCUS_ID <- input$selectedWorkflowId
- output$currentWorkflowId <- renderText({
- paste("Workflow ID: ", FOCUS_ID)
- })
+ output$workflowOpt <- renderUI({
+ if (NROW(workflowOptions()) > 0) {
+ renderDT(
+ expr = workflowOptions(),
+ class = "compact",
+ filter = "top",
+ options = list(scrollX = TRUE),
+ selection = "single",
+ rownames = FALSE
+ )
+ } else {
+ div(
+ "No options data found",
+ class = "alert alert-primary",
+ role = "alert"
+ )
+ }
+ })
- cromwell_workflow(FOCUS_ID,
+ ## Get a table of workflow inputs
+ workflowInputs <- eventReactive(input$selectedWorkflowId, {
+ cromwell_workflow(
+ workflow_id = input$selectedWorkflowId,
url = rv$url,
token = rv$token
)$inputs
@@ -939,11 +994,6 @@ server <- function(input, output, session) {
observeEvent(input$workflowInp_edit, {
str(input$workflowInp_edit, max.level=2)
})
- ### set workflow id display in viewer tab back to none
- ### when nothing selected in the Workflows Run table
- observeEvent(input$joblistCromwell_rows_selected, {
- output$currentWorkflowId <- renderText({"Workflow ID: "})
- }, ignoreNULL = FALSE)
## Render a list of jobs in a table for a workflow
output$joblistCromwell <- renderDT({
@@ -959,13 +1009,10 @@ server <- function(input, output, session) {
#### Call Data
- callsUpdate <- eventReactive(
- input$selectedWorkflowId,
+ callsUpdate <- eventReactive(input$selectedWorkflowId,
{
- data <- workflowUpdate()
- FOCUS_ID <<- input$selectedWorkflowId
- print("callsUpdate(); Querying cromwell for metadata for calls.")
- theseCalls <- cromwell_call(FOCUS_ID,
+ theseCalls <- cromwell_call(
+ workflow_id = input$selectedWorkflowId,
url = rv$url,
token = rv$token
)
@@ -974,7 +1021,15 @@ server <- function(input, output, session) {
} else {
callDat <<- theseCalls %>% mutate(executionStatus = "NA")
}
- suppressWarnings(callDat %>% select(one_of("workflow_name", "detailedSubName", "callName", "executionStatus", "shardIndex", "callRoot", "start", "end", "callDuration", "docker", "modules"), everything()))
+ suppressWarnings(
+ callDat %>%
+ select(
+ one_of("workflow_name", "detailedSubName", "callName",
+ "executionStatus", "shardIndex", "callRoot", "start",
+ "end", "callDuration", "docker", "modules"),
+ everything()
+ )
+ )
},
ignoreNULL = TRUE
)
@@ -1023,30 +1078,42 @@ server <- function(input, output, session) {
## Failure data
failsUpdate <- eventReactive(input$getFailedData,
{
- data <- workflowUpdate()
- FOCUS_ID <- input$selectedWorkflowId
- print("failsUpdate(); Querying cromwell for metadata for failures.")
- suppressWarnings(failDat <- cromwell_failures(FOCUS_ID,
+ suppressWarnings(cromwell_failures(
+ workflow_id = input$selectedWorkflowId,
url = rv$url,
token = rv$token
) %>%
select(one_of(
"callName", "jobId", "workflow_id", "detailedSubName", "shardIndex", "attempt",
"failures.message", "failures.causedBy.message"
- ), everything()) %>% unique())
- return(failDat)
+ ), everything()) %>%
+ unique())
},
ignoreNULL = TRUE
)
output$failurelistBatch <- renderDT(
- data <- failsUpdate(),
+ expr = failsUpdate(),
class = "compact",
filter = "top",
options = list(scrollX = TRUE),
rownames = FALSE
)
+ output$failurelistBatch <- renderUI({
+ if (NROW(failsUpdate()) > 0) {
+ renderDT(
+ expr = failsUpdate(),
+ class = "compact",
+ filter = "top",
+ options = list(scrollX = TRUE),
+ rownames = FALSE
+ )
+ } else {
+ alert("No failures data found")
+ }
+ })
+
output$downloadFails <- downloadHandler(
filename = function() {
paste0(unique(failsUpdate()$workflow_id), "-callFailureData.csv")
@@ -1059,36 +1126,41 @@ server <- function(input, output, session) {
### Call Caching data
cacheUpdate <- eventReactive(input$getCacheData,
{
- data <- workflowUpdate()
- FOCUS_ID <<- input$selectedWorkflowId
- print("cacheUpdate(); Querying cromwell for metadata for call caching.")
- theseCache <- cromwell_cache(FOCUS_ID,
+ theseCache <- cromwell_cache(
+ workflow_id = input$selectedWorkflowId,
url = rv$url,
token = rv$token
)
if ("callCaching.effectiveCallCachingMode" %in% colnames(theseCache)) {
- cacheDat <- theseCache
+ theseCache
} else {
- cacheDat <- theseCache %>% mutate(callCaching.effectiveCallCachingMode = "NA")
+ theseCache %>%
+ mutate(callCaching.effectiveCallCachingMode = "NA")
}
- cacheDat
},
ignoreNULL = TRUE
)
- output$cachingListBatch <- renderDT(
- data <- cacheUpdate() %>%
- select(
- any_of(
- c("workflow_name", "workflow_id", "callName", "shardIndex", "executionStatus")),
- everything()
- ) %>%
- unique(),
- class = "compact",
- filter = "top",
- options = list(scrollX = TRUE),
- rownames = FALSE
- )
+ output$cachingListBatch <- renderUI({
+ if (NROW(cacheUpdate()) > 0) {
+ renderDT(
+ expr = cacheUpdate() %>%
+ select(
+ any_of(
+ c("workflow_name", "workflow_id", "callName",
+ "shardIndex", "executionStatus")),
+ everything()
+ ) %>%
+ unique(),
+ class = "compact",
+ filter = "top",
+ options = list(scrollX = TRUE),
+ rownames = FALSE
+ )
+ } else {
+ alert("No call caching data found")
+ }
+ })
output$downloadCache <- downloadHandler(
filename = function() {
@@ -1103,28 +1175,28 @@ server <- function(input, output, session) {
### Go get the output data for the selected workflow
outputsUpdate <- eventReactive(input$getOutputData,
{
- data <- workflowUpdate()
- FOCUS_ID <<- input$selectedWorkflowId
- print("outputsUpdate(); Querying cromwell for a list of workflow outputs.")
- outDat <<- try(cromwell_outputs(FOCUS_ID,
+ cromwell_outputs(
+ workflow_id = input$selectedWorkflowId,
url = rv$url,
token = rv$token
- ), silent = TRUE)
- if (!is.data.frame(outDat)) {
- outDat <- dplyr::tibble("workflow_id" = "No outputs are available for this workflow yet.")
- }
- outDat
+ )
},
ignoreNULL = TRUE
)
## render outputs list to a table
- output$outputslistBatch <- renderDT(
- data <- outputsUpdate(),
- class = "compact",
- filter = "top",
- options = list(scrollX = TRUE),
- rownames = FALSE
- )
+ output$outputslistBatch <- renderUI({
+ if (NROW(outputsUpdate()) > 0) {
+ renderDT(
+ expr = outputsUpdate(),
+ class = "compact",
+ filter = "top",
+ options = list(scrollX = TRUE),
+ rownames = FALSE
+ )
+ } else {
+ alert("No output data found")
+ }
+ })
## Prep outputs table for download
output$downloadOutputs <- downloadHandler(
filename = function() {
diff --git a/app/tab-details.R b/app/tab-details.R
deleted file mode 100644
index 083f9cb..0000000
--- a/app/tab-details.R
+++ /dev/null
@@ -1,20 +0,0 @@
-library(listviewer)
-
-tab_details <- card(
- id = "details",
- navset_underline(
- nav_panel(
- title = "Workflow Inputs",
- textOutput("currentWorkflowId"),
- p(""),
- actionButton("linkToTrackingTab_from_workflow_inputs", "Back to Track Jobs Tab", width = "250px"),
- p(""),
- reactjsonOutput("workflowInp", height = "100%")
- ),
- nav_panel(
- title = "Mermaid",
- actionButton("linkToTrackingTab_from_mermaid", "Back to Track Jobs Tab", width = "250px"),
- uiOutput("mermaid_diagram")
- )
- )
-)
diff --git a/app/tab-servers.R b/app/tab-servers.R
index b59d84f..81df152 100644
--- a/app/tab-servers.R
+++ b/app/tab-servers.R
@@ -1,8 +1,17 @@
+alert_light <- function(...) {
+ div(
+ strong("Note:"),
+ ...,
+ class = "alert alert-light",
+ role = "alert"
+ )
+}
+
card1 <- card(
id = "cromwell_start_stop",
class = "border border-warning",
card_header(h2("Manage your PROOF Server")),
- p("Note: Hover over the ", icon("question-circle"), " icons to get more information about each item."),
+ alert_light("Hover over the ", icon("question-circle"), " icons to get more information about each item."),
h4("Get a PROOF Server Running"),
p("If you have a PROOF server running, 'Job Status' should indicate 'RUNNING'. If not, click the 'Start a PROOF server' button."),
uiOutput("proofStatusJobStatus"),
@@ -20,7 +29,10 @@ card1 <- card(
uiOutput("proofStatusServerTime"),
uiOutput("proofStatusSlurmJobAccount"),
h4("Stop your PROOF Server"),
- p(strong("Note"), " stopping your server cannot be undone, but you can always make another one!"),
+ alert_light(
+ "Stopping your server cannot be undone, but you can always make another one!",
+ "Also, stopping your server does not stop your running jobs."
+ ),
actionButton(
inputId = "cromwellDelete",
label = "Stop a PROOF Server",
@@ -34,7 +46,7 @@ card2 <- card(
id = "cromwell_troubleshoot",
class = "border border-warning",
card_header(h2("Troubleshoot Your PROOF Server")),
- p(strong("Note"), "If you're having trouble using your PROOF server, this information can be useful in getting help."),
+ alert_light("If you're having trouble using your PROOF server, this information can be useful in getting help."),
uiOutput("proofStatusSlurmJobId"),
uiOutput("proofStatusCromwellDir"),
uiOutput("proofStatusServerLogDir"),
diff --git a/app/tab-submission.R b/app/tab-submission.R
index d9d0996..ac3412c 100644
--- a/app/tab-submission.R
+++ b/app/tab-submission.R
@@ -25,11 +25,15 @@ tab_submission <- card(
value = "",
placeholder = "e.g., Cohort 2"
),
- actionButton(
+ shinyjs::disabled(actionButton(
inputId = "submitWorkflow",
label = "Submit Workflow",
icon = icon("paper-plane"),
- width = "250px"
+ width = "250px",
+ class = "btn-success"
+ )),
+ card(
+ uiOutput(outputId = "submissionResult")
),
actionButton(
inputId = "resetSubmission",
@@ -53,9 +57,6 @@ tab_submission <- card(
inputId = "workOptions", "Workflow Options JSON (optional):",
accept = ".json"
)
- ),
- card(
- uiOutput(outputId = "submissionResult")
)
)
)
diff --git a/app/tab-tracking.R b/app/tab-tracking.R
index 53e1b87..6e76b0d 100644
--- a/app/tab-tracking.R
+++ b/app/tab-tracking.R
@@ -3,6 +3,7 @@ library(bsicons)
library(htmltools)
library(glue)
library(bslib)
+library(shinycssloaders)
sidebar_tracking <- sidebar(
actionButton(
@@ -85,7 +86,9 @@ card_workflow_runs <- card(
workflow_cards <- layout_column_wrap(
width = 1/1,
fillable = FALSE,
- uiOutput("workflows_cards")
+ shinycssloaders::withSpinner(
+ uiOutput("workflows_cards")
+ )
)
tab_tracking <- page_sidebar(
diff --git a/app/tab-troubleshoot.R b/app/tab-troubleshoot.R
index f201ae7..2a9b195 100644
--- a/app/tab-troubleshoot.R
+++ b/app/tab-troubleshoot.R
@@ -1,4 +1,8 @@
-tab_troublehsoot <- nav_panel(NULL,
+library(shinyjs)
+
+source("utils.R")
+
+panel_troublehsoot <- nav_panel(title = "Troubleshoot",
card(
class = "border border-primary",
full_screen = TRUE,
@@ -6,23 +10,11 @@ tab_troublehsoot <- nav_panel(NULL,
card_body(
fillable = FALSE,
p("When a workflow fails but no jobs were started, or there appears to be no clear reason for a workflow to have failed, this tool can provide you the entire set of workflow metadata Cromwell has for your workflow in it's raw and unprocessed (json) form. For complex workflows, this can be rather large (and ugly!)."),
- textInput(
- inputId = "troubleWorkflowID",
- label = "Workflow id to get metadata for:",
- value = "",
- placeholder = "577b9aa4-b26b-4fd6-9f17-7fb33780bbd0",
- width = "25%"
- ),
- actionButton(
- inputId = "troubleWorkflow",
- class = "btn-sm",
- label = "Get Workflow Metadata",
- icon = icon("wrench"),
- width = "250px"
- ),
- actionButton("resetTrouble", "Reset", class = "btn-sm", width = "250px"),
br(),
- verbatimTextOutput(outputId = "troubleResult")
+ load_spinner(
+ verbatimTextOutput(outputId = "troubleResult")
+ )
)
- )
+ ),
+ shinyjs::useShinyjs()
)
diff --git a/app/tab-welcome.R b/app/tab-welcome.R
index dae26d1..ea453a9 100644
--- a/app/tab-welcome.R
+++ b/app/tab-welcome.R
@@ -3,14 +3,14 @@ ablank <- function(...) {
}
tab_welcome <- nav_panel(
- title = "Welcome",
+ title = "PROOF",
card(
card_body(
div(
h1("PROOF"),
h4("Run WDL workflows on the Fred Hutch cluster")
),
- p("This is a",
+ p("PROOF (Production Onramp for Optimization and Feasibility) is a",
ablank("Shiny", href="https://shiny.posit.co/"),
"app being developed by the",
ablank("Fred Hutch Data Science Lab, DaSL", href="https://hutchdatascience.org/"),
@@ -39,14 +39,10 @@ tab_welcome <- nav_panel(
),
tags$li("Check",
actionLink("linkToWorkflowDetailsTab", "workflow details")
- ),
- tags$li("Check the",
- actionLink("linkToTroubleshootingTab", "troubleshooting page"),
- " to dig into error messages if needed"
)
),
h4("To learn more about PROOF and WDL head over to the ",
- actionLink("linkToResourcesTab", "Resources page")
+ actionLink("linkToHelpTab", "Help page")
)
)
)
diff --git a/app/tab-workflow_details.R b/app/tab-workflow_details.R
index adaf462..bfafe30 100644
--- a/app/tab-workflow_details.R
+++ b/app/tab-workflow_details.R
@@ -1,5 +1,101 @@
library(listviewer)
+source("tab-troubleshoot.R")
+source("utils.R")
+
+panel_job_list <- nav_panel(
+ title = "Job List",
+ downloadButton("downloadJobs",
+ "Download Workflow Jobs Data", style = "width:20%"),
+ load_spinner(
+ DTOutput("tasklistBatch")
+ )
+)
+
+panel_workflow_description <- nav_panel(
+ title = "Workflow Description",
+ card_body(
+ load_spinner(
+ uiOutput("workflowDescribe")
+ )
+ )
+)
+
+panel_diagram <- nav_panel(
+ title = "Diagram",
+ load_spinner(
+ uiOutput("mermaid_diagram")
+ )
+)
+
+panel_job_failures <- nav_panel(
+ title = "Job Failures",
+ p("Specific information for jobs with a status of 'Failed', only available upon request."),
+ actionButton(
+ inputId = "getFailedData",
+ label = "Get/Refresh Failed Job Metadata",
+ icon = icon("refresh"),
+ width = "300px"
+ ),
+ downloadButton(
+ outputId = "downloadFails",
+ label = "Download Call Failure Data",
+ style = "width:300px;"
+ ),
+ uiOutput("failurelistBatch")
+)
+
+panel_call_caching <- nav_panel(
+ title = "Call Caching ",
+ p("Only available upon request. Note: this can be slow for very complex workflows. "),
+ actionButton(
+ inputId = "getCacheData",
+ label = "Get/Refresh Call Caching Metadata",
+ icon = icon("refresh"),
+ width = "300px"
+ ),
+ downloadButton(
+ outputId = "downloadCache",
+ label = "Download Call Caching Data",
+ style = "width:300px;"
+ ),
+ load_spinner(
+ uiOutput("cachingListBatch")
+ )
+)
+
+panel_options <- nav_panel(
+ title = "Workflow Options",
+ br(),
+ load_spinner(
+ uiOutput("workflowOpt")
+ )
+)
+
+panel_inputs <- nav_panel(
+ title = "Workflow Inputs",
+ load_spinner(
+ reactjsonOutput("workflowInp", height = "100%")
+ )
+)
+
+panel_outputs <- nav_panel(
+ title = "Workflow Outputs",
+ p("The specific outputs to the entire workflow itself are listed here only upon request and only if they are all available. "),
+ actionButton(
+ inputId = "getOutputData",
+ label = "Get/Refresh Workflow Output Metadata",
+ icon = icon("refresh"),
+ width = "350px"
+ ),
+ downloadButton(
+ outputId = "downloadOutputs",
+ label = "Download Workflow Output Data",
+ style = "width:350px;"
+ ),
+ uiOutput("outputslistBatch")
+)
+
tab_workflow_details <- card(
id = "workflow_details",
card_header(
@@ -7,61 +103,14 @@ tab_workflow_details <- card(
class = "d-flex gap-1 justify-content-between"
),
navset_underline(
- nav_panel(
- title = "Job List",
- downloadButton("downloadJobs", "Download Workflow Jobs Data", style = "width:20%"),
- DTOutput("tasklistBatch")
- ),
- nav_panel(
- title = "Workflow Description",
- card_body(
- uiOutput("workflowDescribe")
- )
- ),
- nav_panel(
- title = "Diagram",
- uiOutput("mermaid_diagram")
- ),
- nav_panel(
- title = "Job Failures",
- p("Specific information for jobs with a status of 'Failed', only available upon request."),
- actionButton(
- inputId = "getFailedData",
- label = "Get/Refresh Failed Job Metadata",
- icon("refresh")
- ),
- downloadButton("downloadFails", "Download Call Failure Data"),
- DTOutput("failurelistBatch")
- ),
- nav_panel(
- title = "Call Caching ",
- p("Only available upon request. Note: this can be slow for very complex workflows. "),
- actionButton(
- inputId = "getCacheData",
- label = "Get/Refresh Call Caching Metadata",
- icon("refresh")
- ),
- downloadButton("downloadCache", "Download Call Caching Data"),
- DTOutput("cachingListBatch")
- ),
- nav_panel(
- title = "Workflow Options",
- DTOutput("workflowOpt")
- ),
- nav_panel(
- title = "Workflow Inputs",
- reactjsonOutput("workflowInp", height = "100%")
- ),
- nav_panel(
- title = "Workflow Outputs",
- p("The specific outputs to the entire workflow itself are listed here only upon request and only if they are all available. "),
- actionButton(
- inputId = "getOutputData",
- label = "Get/Refresh Workflow Output Metadata",
- icon("refresh")
- ),
- downloadButton("downloadOutputs", "Download Workflow Output Data"),
- DTOutput("outputslistBatch")
- )
+ panel_job_list,
+ panel_workflow_description,
+ panel_diagram,
+ panel_job_failures,
+ panel_call_caching,
+ panel_options,
+ panel_inputs,
+ panel_outputs,
+ panel_troublehsoot
)
)
diff --git a/app/ui.R b/app/ui.R
index 666aaf3..f8ea8d0 100644
--- a/app/ui.R
+++ b/app/ui.R
@@ -24,31 +24,54 @@ source("tab-validate.R")
source("tab-submission.R")
source("tab-tracking.R")
source("tab-workflow_details.R")
-source("tab-troubleshoot.R")
-source("tab-details.R")
ui <- cookies::add_cookie_handlers(
page_navbar(
id = "proof",
- title = "PROOF",
- bg = "#0062cc",
+ title = tags$span(
+ tags$a(
+ tags$img(
+ src = "fred-hutch.png",
+ width = "96px",
+ height = "auto",
+ class = "me-3",
+ alt = "Fred Hutch logo"
+ ),
+ href = "https://www.fredhutch.org"
+ ),
+ ""
+ ),
+ bg = "#000000",
underline = TRUE,
tab_welcome,
- nav_panel(title = "Resources",
- card(
- shiny::includeMarkdown("about.md")
- )
- ),
nav_panel(title = "Server", tab_servers),
nav_panel(title = "Validate", tab_validate, shinyjs::useShinyjs()),
- nav_panel(title = "Submit", tab_submission, shinyjs::useShinyjs()),
- nav_panel(title = "Track workflows", tab_tracking, rclipboard::rclipboardSetup()),
+ nav_panel(title = "Submit", tab_submission, shinyjs::useShinyjs(),
+ tags$style("
+ .btn.btn-success:disabled {
+ background-color: #d0d0d0;
+ opacity: 1.0;
+ }"
+ ),
+ ),
+ nav_panel(title = "Track workflows", tab_tracking,
+ rclipboard::rclipboardSetup()
+ ),
nav_panel(title = "Workflow Details", tab_workflow_details,
+ rclipboard::rclipboardSetup(),
tags$head(
- tags$script(src = "https://cdn.jsdelivr.net/npm/mermaid@10.9.1/dist/mermaid.min.js")
+ tags$script(src = "https://cdn.jsdelivr.net/npm/mermaid@11.4.0/dist/mermaid.min.js")
+ )
+ ),
+ nav_panel(title = "Help",
+ card(
+ shiny::includeMarkdown("about.md"),
+ card_body(
+ h1("App details"),
+ htmlOutput("gitHtml")
+ )
)
),
- nav_panel(title = "Troubleshoot", tab_troublehsoot, shinyjs::useShinyjs()),
nav_spacer(),
nav_item(
uiOutput("userName")
diff --git a/app/utils.R b/app/utils.R
index 3d634e3..aa44f9a 100644
--- a/app/utils.R
+++ b/app/utils.R
@@ -3,6 +3,64 @@ library(bsicons)
library(parsedate)
library(uuid)
library(rclipboard)
+library(shinyFeedback)
+library(shinycssloaders)
+
+# Wrapped in a function so we can change options in one place
+load_spinner <- function(...) {
+ shinycssloaders::withSpinner(...)
+}
+
+# exact copy from shiny:::validateIcon
+proofValidateIcon <- function (icon) {
+ if (is.null(icon) || identical(icon, character(0))) {
+ return(icon)
+ } else if (inherits(icon, "shiny.tag") && icon$name == "i") {
+ return(icon)
+ } else {
+ stop("Invalid icon. Use Shiny's 'icon()' function to generate a valid icon")
+ }
+}
+
+# copy from shinyFeedback::loadingButton adding ability to pass in:
+# - onclick (most importantly)
+# - icon (less important)
+proofLoadingButton <- function(inputId, label,
+ class = "btn btn-primary", style = "width: 150px;",
+ loadingLabel = "Loading...", loadingSpinner = "spinner",
+ loadingClass = NULL, loadingStyle = NULL, icon = NULL, ...) {
+
+ shiny::addResourcePath("shinyfeedback", system.file("assets",
+ package = "shinyFeedback"))
+ if (is.null(loadingClass)) {
+ loadingClass <- class
+ }
+ if (is.null(loadingStyle)) {
+ loadingStyle <- style
+ }
+ rOptions <- list(label = label, class = class, style = style,
+ loadingLabel = loadingLabel, loadingSpinner = loadingSpinner,
+ loadingClass = loadingClass, loadingStyle = loadingStyle)
+ jsonOptions <- jsonlite::toJSON(rOptions, auto_unbox = TRUE)
+ htmltools::span(
+ class = "sf-loading-button",
+ id = paste0("sf-loading-button-", inputId),
+ tags$button(
+ id = inputId,
+ class = class,
+ style = style,
+ list(proofValidateIcon(icon), label),
+ ...
+ ),
+ tags$head(
+ htmltools::singleton(fontawesome::fa_html_dependency()),
+ htmltools::singleton(
+ tags$script(src = "shinyfeedback/js/loadingbutton.js?version=1"),
+ ),
+ tags$script(sprintf("loadingButtons.create('%s', %s)", inputId, jsonOptions))
+ )
+ )
+}
# coerce dates to PT from UTC
as_pt <- function(x) {
@@ -21,20 +79,18 @@ validate_workflowid <- function(x) {
# get lastet commit - memoised so after first call its cached
git_last <- memoise(
function(branch = "dev", fallback = "") {
- ## FIXME: remove below comments and dummy list when internet back
- # last <- tryCatch(
- # {
- # resp <- httr::GET(
- # url = "https://api.github.com",
- # path = glue("repos/FredHutch/shiny-cromwell/commits/{branch}"),
- # query = list(per_page = 1)
- # )
- # httr::content(resp)
- # },
- # error = function(e) e
- # )
- # if (rlang::is_error(last)) fallback else last
- list(sha = "adsfadf", commit = list(commmitter = list(date = "asdafd")))
+ last <- tryCatch(
+ {
+ resp <- httr::GET(
+ url = "https://api.github.com",
+ path = glue("repos/FredHutch/shiny-cromwell/commits/{branch}"),
+ query = list(per_page = 1)
+ )
+ httr::content(resp)
+ },
+ error = function(e) e
+ )
+ if (rlang::is_error(last)) fallback else last
}
)
@@ -129,3 +185,11 @@ card_header_color <- function(status) {
parse_date_tz <- function(x, tz = "America/Los_Angeles") {
parsedate::parse_date(x, default_tz = tz)
}
+
+alert <- function(..., class = "alert alert-primary") {
+ div(
+ ...,
+ class = class,
+ role = "alert"
+ )
+}
diff --git a/app/www/fred-hutch.png b/app/www/fred-hutch.png
new file mode 100644
index 0000000..70a53bb
Binary files /dev/null and b/app/www/fred-hutch.png differ