diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 97bb98d..d6cdf48 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -18,13 +18,14 @@ stages: - build - test - deploy + build: stage: build script: | python3 build_helper.py docker-compose.yml --fluentd-logging > /dev/null echo $DB_CONFIG | base64 -d > .my.cnf - docker build --no-cache \ + docker build \ -t sc-registry.fredhutch.org/shiny-cromwell:test \ --build-arg CI_COMMIT_BRANCH=${CI_COMMIT_BRANCH} \ --build-arg CI_COMMIT_SHA=${CI_COMMIT_SHA} \ @@ -48,18 +49,8 @@ test: # env # curl -si http://shiny-cromwell:3838/ # docker logs $CONTAINER_ID - curl -sI http://shiny-cromwell:3838 | head -1 | grep -q "200 OK" docker run -w /srv/shiny-server --rm sc-registry.fredhutch.org/shiny-cromwell:test R -q -e 'testthat::test_dir("tests")' - -deploy_review_image: - stage: deploy - except: - refs: - - main - - dev - script: - - docker tag sc-registry.fredhutch.org/shiny-cromwell:test nexus-registry.fredhutch.org/scicomp-nexus/${CI_PROJECT_NAME}:${CI_COMMIT_BRANCH} - - docker push nexus-registry.fredhutch.org/scicomp-nexus/${CI_PROJECT_NAME}:${CI_COMMIT_BRANCH} + curl -sI http://shiny-cromwell:3838 | head -1 | grep -q "200 OK" deploy_review_image: stage: deploy diff --git a/Dockerfile b/Dockerfile index 50154f5..e9e0390 100644 --- a/Dockerfile +++ b/Dockerfile @@ -1,15 +1,17 @@ -FROM fredhutch/r-shiny-server-base:4.3.2 +FROM fredhutch/r-shiny-server-base:4.4.1 RUN apt-get update -y && apt-get install -y libssh-dev python3-pip git libmariadb-dev 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", "cookies", "RMariaDB", "DBI"), 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')" RUN R -q -e "remotes::install_github('getwilds/rcromwell@v3.3.0')" +RUN R -q -e "remotes::install_github('rstudio/bslib')" + ADD .my.cnf /root/ # python wdl2mermaid setup: diff --git a/Makefile b/Makefile index 4133ccb..e069ebd 100644 --- a/Makefile +++ b/Makefile @@ -4,7 +4,7 @@ DEPS := $(shell ${RSCRIPT} -e 'invisible(lapply(c("glue", "cli"), require, chara run: ${RSCRIPT} -e "options(shiny.autoreload = TRUE)" \ - -e "shiny::runApp(\"app\", launch.browser = TRUE)" + -e "shiny::runApp(\"app\", launch.browser = TRUE, port = 4026)" run_docker: docker build --platform linux/amd64 -t shiny-cromwell:app . diff --git a/app/about.md b/app/about.md index 6b68c0b..d464fd8 100644 --- a/app/about.md +++ b/app/about.md @@ -1,21 +1,18 @@ -This is a [Shiny](https://shiny.posit.co/) app being developed by the [Fred Hutch Data Science Lab, DaSL](https://hutchdatascience.org/) that simplifies user interactions with a [Cromwell](https://cromwell.readthedocs.io/en/stable/) server, an open source [WDL](https://openwdl.org/) workflow engine that can be used with a range of HPC backends. We are developing this application alongside Fred Hutch oriented infrastructure with the intention to develop open source resources to enable others to do the same. - -## Fred Hutch Users -At Fred Hutch, we offer a service for supporting the use of our on-premise HPC cluster to run WDL workflows called PROOF. To use this app at Fred Hutch, choose the "PROOF Login" button at the top of the page and enter your Fred Hutch credentials to get started. - -### 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/). - Join the community in the [#workflow-managers FH-Data Slack channel](https://fhdata.slack.com/archives/CJFP1NYSZ), (open to all Fred Hutch, UW and Seattle Children's staff using their work emails). -- Get Help from Fred Hutch DaSL staff through [Data House Calls](https://hutchdatascience.org/datahousecalls/). +- Get Help from Fred Hutch DaSL staff through [Data House Calls](https://calendly.com/data-house-calls/resources). ## 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 6ea9be4..19bef6c 100644 --- a/app/buttons.R +++ b/app/buttons.R @@ -2,6 +2,8 @@ logInButton <- actionButton( inputId = "proofAuth", label = "PROOF Login", + class = "btn-success btn-sm", + style = "color: white;", icon = icon("truck-fast") ) @@ -9,7 +11,7 @@ logOutButton <- actionButton( inputId = "proofAuthLogout", label = "PROOF Logout", - class = "btn-danger", + class = "btn-danger btn-sm", style = "color: white;", icon = icon("arrow-right-to-bracket") ) @@ -18,13 +20,15 @@ logInCromwellButton <- actionButton( inputId = "ownCrom", label = "DIY Cromwell", + class = "btn-sm", + style = "color: white;", icon = icon("plug-circle-xmark") ) logOutCromwellButton <- actionButton( inputId = "proofCromwellLogout", label = " Exit", - class = "btn-danger", + class = "btn-danger btn-sm", style = "color: white;", icon = icon("arrow-right-to-bracket") ) diff --git a/app/constants.R b/app/constants.R new file mode 100644 index 0000000..f40afa5 --- /dev/null +++ b/app/constants.R @@ -0,0 +1 @@ +DAYS_WORKFLOW_HISTORY <- 120 diff --git a/app/modals.R b/app/modals.R index 464e939..c33d4e2 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 ) @@ -67,21 +71,15 @@ verifyCromwellDeleteModal <- function(failed = FALSE, error = "Woops, an error! "Stop your PROOF server. Although you can't undo this action, you can start up another one anytime!", br(), br(), - textInput( - inputId = "stopCromwell", - label = div(HTML("To stop your server, confirm by typing
delete me into the field.")) - ), if (failed) { div(tags$b(error, style = "color: red;")) }, footer = tagList( modalButton("Cancel"), - shinyjs::disabled( - shinyFeedback::loadingButton( - inputId = "deleteCromwell", - label = "Stop Server", - class = "btn btn-warning" - ) + shinyFeedback::loadingButton( + inputId = "deleteCromwell", + label = "Stop Server", + class = "btn btn-warning" ) ), easyClose = TRUE diff --git a/app/server.R b/app/server.R index 58d439c..fe7e26c 100644 --- a/app/server.R +++ b/app/server.R @@ -5,7 +5,6 @@ library(shinydashboard) library(shinydashboardPlus) library(shinyFeedback) library(shinyWidgets) -library(shinyvalidate) library(shinylogs) library(DT) @@ -20,18 +19,17 @@ library(dplyr) library(tibble) library(magrittr) -library(uuid) library(httr) library(proofr) library(rcromwell) -library(rclipboard) - library(cookies) library(listviewer) +library(rclipboard) + +library(ids) -source("sidebar.R") source("modals.R") source("proof.R") source("buttons.R") @@ -41,33 +39,54 @@ source("tab-welcome.R") source("validators.R") source("inputs_utils.R") source("cookies-db.R") +source("constants.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 -proof_timeout(sec = PROOF_TIMEOUT) +proofr::proof_timeout(sec = PROOF_TIMEOUT) # sanitize errors - note that some actual errors will still happen options(shiny.sanitize.errors = SANITIZE_ERRORS) -myCols <- brewer.pal(6, "RdYlBu") +myCols <- RColorBrewer::brewer.pal(6, "RdYlBu") server <- function(input, output, session) { - if (SHINY_LOGGING) track_usage(storage_mode = store_null()) + if (SHINY_LOGGING) shinylogs::track_usage(storage_mode = shinylogs::store_null()) 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 = "") @@ -79,8 +98,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 @@ -105,12 +123,17 @@ server <- function(input, output, session) { } }) - output$userName <- renderText({ - if (is.null(input$username)) { + output$userName <- renderUI({ + the_name <- if (is.null(input$username)) { rv$user } else { input$username } + if (nzchar(the_name)) { + span(icon("user"), the_name) + } else { + span() + } }) observe({ @@ -124,22 +147,6 @@ server <- function(input, output, session) { } }) - output$uiSideBar <- renderMenu({ - if (nzchar(rv$token)) { - proofSidebar() - } else { - nonProofSidebar() - } - }) - - output$toggleServersBox <- renderUI({ - if (nzchar(rv$token)) { - welcome_servers_box - } else { - NULL - } - }) - observeEvent(input$submit, { if (!is.null(input$username) && !is.null(input$password)) { try_auth <- tryCatch( @@ -178,6 +185,9 @@ server <- function(input, output, session) { same_site = "strict" ) + # reset loading spinner + shinyFeedback::resetLoadingButton("submit") + removeModal() } } else { @@ -226,6 +236,7 @@ server <- function(input, output, session) { observe({ if (proof_loggedin(rv$token)) { shinyjs::hide("ownCrom") + shinyjs::hide("ownCromwell") } }) @@ -278,6 +289,14 @@ server <- function(input, output, session) { ) ) + # update records in cookies DB + user_to_db( + user = rv$user, + token = to_base64(rv$token), + url = to_base64(rv$url), + drop_existing = TRUE + ) + # reset loading spinner shinyFeedback::resetLoadingButton("beginCromwell") @@ -291,36 +310,43 @@ 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()) }) - # For the button WITHIN the Delete modal - observe({ - shinyjs::toggleState("deleteCromwell", input$stopCromwell == "delete me") - }) - observeEvent(input$deleteCromwell, { if (proof_loggedin(rv$token)) { - if (input$stopCromwell == "delete me") { - try_delete <- tryCatch(proof_cancel(token = rv$token), error = function(e) e) - if (rlang::is_error(try_delete)) { - showModal(verifyCromwellDeleteModal(failed = TRUE, error = try_delete$message)) - } + try_delete <- tryCatch(proof_cancel(token = rv$token), error = function(e) e) + if (rlang::is_error(try_delete)) { + showModal(verifyCromwellDeleteModal(failed = TRUE, error = try_delete$message)) + } - # wait for server to go down - proof_wait_for_down(rv$token) + # wait for server to go down + proof_wait_for_down(rv$token) - # reset loading spinner - shinyFeedback::resetLoadingButton("deleteCromwell") + # update records in cookies DB + user_to_db( + user = rv$user, + token = to_base64(rv$token), + url = "", + drop_existing = TRUE + ) - removeModal() - shinyjs::disable(id = "cromwellDelete") - shinyjs::enable(id = "cromwellStart") - } else { - showModal(verifyCromwellDeleteModal(failed = TRUE)) - } + # reset loading spinner + shinyFeedback::resetLoadingButton("deleteCromwell") + + removeModal() + shinyjs::disable(id = "cromwellDelete") + shinyjs::enable(id = "cromwellStart") } else { showModal(verifyCromwellDeleteModal(failed = TRUE, error = "You're not logged in")) } @@ -331,7 +357,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) @@ -348,17 +374,28 @@ server <- function(input, output, session) { proofStatusTextGenerator <- function(name, list_index, tip = "", value_if_null = NULL) { renderUI({ if (proof_loggedin(rv$token)) { - tags$span( - shinyBS::tipify( + dat <- cromwellProofStatusData() + if (nzchar(tip)) { + tags$span( + bslib::tooltip( + icon("question-circle"), + tip, + placement = "right" + ), + HTML(paste0( + strong(glue("{name}: ")), + purrr::flatten(dat)[[list_index]] %||% value_if_null + )) + ) + } else { + tags$span( icon("question-circle"), - tip, - placement = "right" - ), - HTML(paste0( - strong(glue("{name}: ")), - purrr::flatten(cromwellProofStatusData())[[list_index]] %||% value_if_null - )) - ) + HTML(paste0( + strong(glue("{name}: ")), + purrr::flatten(dat)[[list_index]] %||% value_if_null + )) + ) + } } }) } @@ -409,7 +446,7 @@ server <- function(input, output, session) { ) }) }) - + # reset observeEvent(input$resetValidate, { reset_inputs(c("validatewdlFile", "validateinputFile")) @@ -450,24 +487,38 @@ server <- function(input, output, session) { }) observeEvent(input$submitWorkflow, { - output$submissionResult <- renderPrint({ + output$submissionResult <- renderUI({ stop_safe_loggedin_serverup(rv$url, rv$token, rv$own) - cromwell_submit_batch( + df <- cromwell_submit_batch( wdl = isolate(file_wdlFile()), params = isolate(file_inputJSON()), batch = isolate(file_input2JSON()), options = isolate(file_workOptions()), labels = data.frame( "workflowType" = "AppSubmission", - "Label" = isolate(input$labelValue), - "secondaryLabel" = isolate(input$seclabelValue) + "Label" = ifelse(nzchar(isolate(input$labelValue)), isolate(input$labelValue), ids::adjective_animal(style = "Pascal")), + "secondaryLabel" = ifelse(nzchar(isolate(input$seclabelValue)), isolate(input$seclabelValue), ids::adjective_animal(style = "Pascal")) ), url = rv$url, token = rv$token ) + shinyjs::disable("submitWorkflow") + HTML(glue(' +
+ + ')) }) }) + observe({ + shinyjs::toggleState("submitWorkflow", + !rlang::is_empty(input$wdlFile$datapath) + ) + }) + # reset observeEvent(input$resetSubmission, { reset_inputs(c( @@ -479,88 +530,31 @@ server <- function(input, output, session) { rv_file$input2JSON_state <- 'reset' rv_file$workOptions_state <- 'reset' output$submissionResult <- renderText({}) + shinyjs::disable("submitWorkflow") }) - - ###### Troubleshoot tab ###### - ## Abort a workflow - input_abortWorkflowID <- reactive({ - reactiveInput(rv_file$abortWorkflowID_state, input$abortWorkflowID) - }) - observeEvent(input$abortWorkflowID, { - rv_file$abortWorkflowID_state <- 'loaded' - }) - - observeEvent(input$abortWorkflow, { - output$abortResult <- renderPrint({ - validate_workflowid(isolate(input$abortWorkflowID)) - stop_safe_loggedin_serverup(rv$url, rv$token, rv$own) - cromwell_abort( - workflow_id = isolate(input_abortWorkflowID()), - url = rv$url, - token = rv$token - ) - }) - }) - - ## reset abort - observeEvent(input$resetAbort, { - reset_inputs("abortWorkflowID") - rv_file$abortWorkflowID_state <- 'reset' - output$abortResult <- renderText({}) - }) - - - ## 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, { stop_safe_loggedin_serverup(rv$url, rv$token, rv$own) - if (input$workName == "") { - cromTable <- cromwell_jobs( - days = input$daysToShow, - workflow_status = input$workStatus, - url = rv$url, - token = rv$token - ) - } else { - cromTable <- cromwell_jobs( - days = input$daysToShow, - workflow_status = input$workStatus, - workflow_name = input$workName, - url = rv$url, - token = rv$token - ) - } + + cromTable <- cromwell_jobs( + days = DAYS_WORKFLOW_HISTORY, + url = rv$url, + token = rv$token + ) if ("workflow_id" %in% colnames(cromTable)) { workflowDat <- cromTable %>% select(one_of( @@ -616,13 +610,16 @@ server <- function(input, output, session) { } workflowDat - }, - ignoreNULL = TRUE + }, + # ignoreNULL = FALSE so that data for the tracking page loads when the user logs in + # ignoreNULL = TRUE would mean the data will only load after user first clicks + # the "Refresh data button" + ignoreNULL = FALSE ) - observeEvent(input$wdlview_btn, { + observeEvent(input$selectedWorkflowId, { mermaid_file <- wdl_to_file( - workflow_id = strsplit(input$wdlview_btn, "_")[[1]][2], + workflow_id = input$selectedWorkflowId, url = rv$url, token = rv$token ) @@ -630,29 +627,35 @@ server <- function(input, output, session) { output$mermaid_diagram <- renderUI({ mermaid_container(mermaid_str) }) - updateTabItems(session, "tabs", "wdl") }) - ### go back to tracking tab from wdl tab - observeEvent(input$linkToTrackingTab, { - updateTabsetPanel(session, "tabs", "tracking") + ### Links to various tabs from the welcome page + observeEvent(input$linkToServerTab, { + nav_select("proof", "Server") + }) + observeEvent(input$linkToValidateTab, { + nav_select("proof", "Validate") + }) + observeEvent(input$linkToSubmitTab, { + nav_select("proof", "Submit") + }) + observeEvent(input$linkTrackingTab, { + nav_select("proof", "Track workflows") + }) + observeEvent(input$linkToWorkflowDetailsTab, { + nav_select("proof", "Workflow Details") + }) + observeEvent(input$linkToHelpTab, { + nav_select("proof", "Help") }) - callDurationUpdate <- eventReactive(input$trackingUpdate, - { - stop_safe_loggedin_serverup(rv$url, rv$token, rv$own) - if (nrow(workflowUpdate()) == 1 & is.na(workflowUpdate()$workflow_id[1])) { - callDuration <- data.frame("noCalls" = "No workflows with calls were submitted, please choose a different time period. ") - } else { - callDuration <- purrr::map_dfr(workflowUpdate()$workflow_id, cromwell_call) %>% - dplyr::select(workflow_id, callName, executionStatus, callDuration, jobId) - } - - callDuration - }, - ignoreNULL = TRUE - ) - + ### go back to tracking tab from details tab + observeEvent(input$linkToTrackingTab_from_workflow_inputs, { + nav_select("proof", "Track workflows") + }) + observeEvent(input$linkToTrackingTab_from_mermaid, { + nav_select("proof", "Track workflows") + }) output$workflowDuration <- renderPlot({ if ("workflow_name" %in% colnames(workflowUpdate())) { @@ -660,7 +663,7 @@ server <- function(input, output, session) { ggplot(workflowUpdate(), aes(x = as.factor(workflow_name), y = as.numeric(workflowDuration))) + geom_point(aes(color = status), width = 0.05, size = 4) + coord_flip() + - theme_minimal() + + theme_minimal(base_size=16) + theme(axis.text.x = element_text(angle = 45, hjust = 1)) + scale_color_manual(values = myCols) + ylab("Workflow Duration (mins)") + @@ -671,63 +674,242 @@ server <- function(input, output, session) { } }) - ## Render some info boxes - output$submittedBox <- renderInfoBox({ - infoBox( - "Total \nSubmitted", - workflowUpdate() %>% - filter(!is.na(workflow_id)) %>% - summarize(n_distinct(workflow_id)), - icon = icon("list"), - color = "purple", width = 3 - ) - }) - output$successBox <- renderInfoBox({ - infoBox( - "Successful", if (is.na(workflowUpdate()$workflow_id[1])) { - 0 + ## Compute totals for each Cromwell status + is_workflow_empty <- function() { + NROW(workflowUpdate()) == 0 || NCOL(workflowUpdate()) == 1 + } + status_text <- function(status) { + if (is_workflow_empty()) { + 0 + } else { + df <- workflowUpdate() + if (status == "Submitted") { + df <- filter(df, !is.na(workflow_id)) } else { - workflowUpdate() %>% - filter(status == "Succeeded") %>% - summarise(n_distinct(workflow_id)) - }, - icon = icon("grin"), - color = "yellow", width = 3 + # !! needed to get the value of the variable + df <- filter(df, status == !!status) + } + df %>% + summarize(n_distinct(workflow_id)) %>% + pull(1) + } + } + submittedText <- reactive({ status_text(status = "Submitted") }) + succeededText <- reactive({ status_text(status = "Succeeded") }) + pendingText <- reactive({ status_text(status = "Pending") }) + failedText <- reactive({ status_text(status = "Failed") }) + runningText <- reactive({ status_text(status = "Running") }) + abortedText <- reactive({ status_text(status = "Aborted") }) + + output$trackingSummaryStats <- renderUI({ + tagList( + tags$span(paste("Submitted: ", submittedText()), class = "text-primary fw-bold", style = "display:inline"), + HTML(" - "), + tags$span(paste("Pending: ", pendingText()), class = "text-info fw-bold", style = "display:inline"), + HTML(" - "), + tags$span(paste("Running: ", runningText()), class = "text-warning fw-bold", style = "display:inline"), + HTML(" - "), + tags$span(paste("Succeeded: ", succeededText()), class = "text-success fw-bold", style = "display:inline"), + HTML(" - "), + tags$span(paste("Failed: ", failedText()), class = "text-danger fw-bold", style = "display:inline"), + HTML(" - "), + tags$span(paste("Aborted: ", abortedText()), class = "text-secondary fw-bold", style = "display:inline") ) }) - output$failBox <- renderInfoBox({ - infoBox( - "Failed", if (is.na(workflowUpdate()$workflow_id[1])) { - 0 - } else { - workflowUpdate() %>% - filter(status == "Failed") %>% - summarise(n_distinct(workflow_id)) + + # Data for cards out of workflowUpdate data + workflowDetailsId <- function(workflow_id) { + paste0("goToWorkflowDetails-", workflow_id) + } + + workflowCards <- reactive({ + dflst <- apply(workflowUpdate(), 1, as.list) + lapply(dflst, function(w) { + list( + data = w, + card = card( + id = glue("job_card_{w$workflow_id}"), + class = "border border-secondary", + card_header( + 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", + 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}\") + ') + ), + class = "d-flex justify-content-between gap-1", + ), + card_body( + class = "d-flex align-items-left justify-content-between gap-1", + fillable = FALSE, + tags$span( + w$status, + class = glue("text-{card_header_color(w$status)} fw-bold") + ), + span(bsicons::bs_icon("send"), w$submission), + span(bsicons::bs_icon("clock-history"), w$workflowDuration, "min") + ), + card_body( + class = "d-flex justify-content-between gap-1", + fillable = FALSE, + w$workflow_id, + actionButton( + inputId = "abortWorkflow", + label = "Abort Workflow", + icon = icon("eject"), + class = "btn-sm", + onclick = glue('Shiny.setInputValue(\"selectedWorkflowId\", \"{w$workflow_id}\")'), + disabled = !w$status %in% c("Submitted", "Running") + ) + ) + ) + ) + }) + }) + + workflowCardsFiltered <- reactive({ + dat <- workflowCards() + # Filter by date + dat <- Filter(\(w) { + parse_date_tz(w$data$submission) >= parse_date_tz(paste(input$runs_date[1], "00:00:00")) && + parse_date_tz(w$data$submission) <= parse_date_tz(paste(input$runs_date[2], "23:59:00")) + }, dat) + # Filter by status + if (!rlang::is_empty(input$workStatus)) { + dat <- Filter(\(w) { + w$data$status %in% input$workStatus + }, dat) + } + # Filter by workflow name + if (nzchar(input$workName)) { + dat <- Filter(\(w) { + w$data$workflow_name %in% input$workName + }, dat) + } + sort_dates <- purrr::map_vec(dat, \(card) + parse_date_tz(card$data$submission)) + if (!rlang::is_empty(sort_dates)) { + # skip sorting if sort_dates is empty for whatever reason + dat <- switch(input$sortTracking, + "Newest to oldest" = dat[order(sort_dates, decreasing = TRUE)], + "Oldest to newest" = dat[order(sort_dates)] + ) + } + return(dat) + }) + + output$workflows_cards <- renderUI({ + purrr::map(workflowCardsFiltered(), "card") + }) + + ## Abort a workflow with the abort button on each card + observeEvent(input$abortWorkflow, { + validate_workflowid(isolate(input$selectedWorkflowId)) + stop_safe_loggedin_serverup(rv$url, rv$token, rv$own) + aborted <- tryCatch( + { + cromwell_abort( + workflow_id = isolate(input$selectedWorkflowId), + url = rv$url, + token = rv$token + ) }, - icon = icon("sad-tear"), - color = "red", width = 3 + error = function(e) e ) - }) - output$inprogressBox <- renderInfoBox({ - infoBox( - "In Progress", if (is.na(workflowUpdate()$workflow_id[1])) { - 0 + if (rlang::is_error(aborted)) { + print(glue("In Abort Workflow button: {aborted$message}")) + default_abort_msg <- "Try refreshing data" + msg <- aborted$message + if (grepl("404", msg)) { + msg <- "Not found" } else { - workflowUpdate() %>% - filter(status == "Running") %>% - summarise(n_distinct(workflow_id)) - }, - icon = icon("sync"), - color = "green", width = 3 + msg <- default_abort_msg + } + } else { + msg <- "Workflow aborted!" + } + updateActionButton( + inputId = "abortWorkflow", + label = msg, + icon = icon("eject") ) }) + 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) + }) + }) + }) + + observe({ + matching_ids <- reactive_buttons() + lapply(matching_ids, function(id) { + observeEvent(input[[id]], { + nav_select("proof", "Workflow Details") + shinyFeedback::resetLoadingButton(id) + }) + }) + }) + + ## reset tracking workflows filters + observeEvent(input$resetTrackingFilters, { + reset_inputs(c("workName", "workStatus", "runs_date")) + }) + + output$selectedWorkflowUI <- renderUI({ + if (!is.null(input$selectedWorkflowId)) { + htmltools::tagList( + htmltools::tags$span( + 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( + 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 + ) + ) + } + }) + ## Get a table of workflow labels - workflowLabels <- eventReactive(input$joblistCromwell_rows_selected, { + workflowLabels <- eventReactive(input$selectedWorkflowId, { print("find Labels") - data <- workflowUpdate() - FOCUS_ID <- data[input$joblistCromwell_rows_selected, ]$workflow_id - workflow <- cromwell_workflow(FOCUS_ID, + workflow <- cromwell_workflow( + workflow_id = input$selectedWorkflowId, url = rv$url, token = rv$token ) @@ -766,45 +948,51 @@ server <- function(input, output, session) { ) ) }) - output$workflowDescribe <- renderDT({ - datatable( - workflowLabels(), - escape = FALSE, - selection = "single", - rownames = FALSE, - filter = "top", - options = list(scrollX = TRUE) + + output$workflowDescribe <- renderUI({ + wl <- purrr::discard_at(workflowLabels(), c("workflow", "inputs")) + workflowLabelsLst <- lapply(wl, as.list) + tags$ul( + Map(function(x, y) { + # print(y[[1]]) + tags$li( + span( + strong(x) + ), + ifelse(grepl("clipbtn", as.character(y[[1]])), HTML(y[[1]]), y) + ) + }, 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(), + expr = workflowOptions(), class = "compact", filter = "top", - options = list(scrollX = TRUE), selection = "single", rownames = FALSE + options = list(scrollX = TRUE), + selection = "single", + rownames = FALSE ) - ## Get a table of workflow inputs - workflowInputs <- eventReactive(input$joblistCromwell_rows_selected, { - print("find inputs") - data <- workflowUpdate() - - FOCUS_ID <- data[input$joblistCromwell_rows_selected, ]$workflow_id - output$currentWorkflowId <- renderText({ - paste("Workflow ID: ", FOCUS_ID) - }) + output$workflowOptAlert <- renderUI({ + if (NROW(workflowOptions()) == 0) { + alert("No options data found") + } + }) - 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 @@ -817,19 +1005,6 @@ server <- function(input, output, session) { observeEvent(input$workflowInp_edit, { str(input$workflowInp_edit, max.level=2) }) - ### go to viewer tab when clicked from Tracking tab - observeEvent(input$linkToViewerTab, { - updateTabItems(session, "tabs", "viewer") - }) - ### go back to tracking tab from viewer tab - observeEvent(input$linkToTrackingTab, { - updateTabsetPanel(session, "tabs", "tracking") - }) - ### 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({ @@ -845,13 +1020,13 @@ server <- function(input, output, session) { #### Call Data - callsUpdate <- eventReactive( - input$joblistCromwell_rows_selected, + callsUpdate <- eventReactive(c( + input$selectedWorkflowId, + input$refreshJobList + ), { - data <- workflowUpdate() - FOCUS_ID <<- data[input$joblistCromwell_rows_selected, ]$workflow_id - 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 ) @@ -860,60 +1035,19 @@ 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 ) - output$workflowTiming <- renderPlot({ - if ("callName" %in% colnames(callsUpdate())) { - print("in render plot ...") - ggplot(callsUpdate(), aes(x = as.factor(callName), y = callDuration)) + - geom_point(aes(color = executionStatus), size = 3) + # coord_flip() + - theme_minimal() + - theme(axis.text.x = element_text(hjust = 1, angle = 25)) + - scale_color_manual(values = myCols) + - ylab("Call Duration (mins)") + - xlab("Call Name") - } else { - ggplot() + - geom_blank() - } - }) - - ## Render some info boxes - output$pendingBatch <- renderValueBox({ - infoBox( - "Pending", - value = nrow(callsUpdate() %>% filter(executionStatus %in% c("Starting", "QueuedInCromwell"))), - icon = icon("clock"), - color = "yellow", width = 6 - ) - }) - output$runningBatch <- renderInfoBox({ - infoBox( - "Running", - value = nrow(callsUpdate() %>% filter(executionStatus == "Running")), - icon = icon("sync"), - color = "teal", width = 6 - ) - }) - output$failedBatch <- renderInfoBox({ - infoBox( - "Failed", - value = nrow(callsUpdate() %>% filter(executionStatus == "Failed")), - icon = icon("thumbs-down"), - color = "maroon", width = 6 - ) - }) - output$succeededBatch <- renderInfoBox({ - infoBox( - "Succeeded", - value = nrow(callsUpdate() %>% filter(executionStatus == "Done")), - icon = icon("thumbs-up"), - color = "green", width = 6 - ) - }) ## Jobs Lists output$tasklistBatch <- renderDT({ datatable( @@ -922,7 +1056,7 @@ server <- function(input, output, session) { dplyr::mutate(dplyr::across(matches(c("start", "end")), as_pt)) }, escape = FALSE, - selection = "single", + selection = "none", rownames = FALSE, filter = "top", options = list( @@ -956,31 +1090,37 @@ server <- function(input, output, session) { ) ## Failure data - failsUpdate <- eventReactive(input$getFailedData, + failsUpdate <- eventReactive(c( + input$selectedWorkflowId, + input$getFailedData + ), { - data <- workflowUpdate() - FOCUS_ID <- data[input$joblistCromwell_rows_selected, ]$workflow_id - 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$failuresAlert <- renderUI({ + if (NROW(failsUpdate()) == 0) { + alert("No failures data found") + } + }) output$downloadFails <- downloadHandler( filename = function() { @@ -992,30 +1132,32 @@ server <- function(input, output, session) { ) ### Call Caching data - cacheUpdate <- eventReactive(input$getCacheData, + cacheUpdate <- eventReactive(c( + input$selectedWorkflowId, + input$getCacheData + ), { - data <- workflowUpdate() - FOCUS_ID <<- data[input$joblistCromwell_rows_selected, ]$workflow_id - 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() %>% + expr = cacheUpdate() %>% select( any_of( - c("workflow_name", "workflow_id", "callName", "shardIndex", "executionStatus")), + c("workflow_name", "workflow_id", "callName", + "shardIndex", "executionStatus")), everything() ) %>% unique(), @@ -1024,7 +1166,11 @@ server <- function(input, output, session) { options = list(scrollX = TRUE), rownames = FALSE ) - + output$cachingAlert <- renderUI({ + if (NROW(cacheUpdate()) == 0) { + alert("No call caching data found") + } + }) output$downloadCache <- downloadHandler( filename = function() { @@ -1034,58 +1180,35 @@ server <- function(input, output, session) { write.csv(cacheUpdate(), file, row.names = FALSE) } ) - ## Render some info boxes - output$cacheHits <- renderInfoBox({ - infoBox( - "Cache Hits", - value = if ("callCaching.hit" %in% colnames(cacheUpdate())) { - nrow(cacheUpdate() %>% filter(as.logical(callCaching.hit))) - } else { - 0 - }, - icon = icon("grin-tongue"), - color = "aqua", width = 6 - ) - }) - output$cacheMisses <- renderInfoBox({ - infoBox( - "Cache Misses", - value = if ("callCaching.hit" %in% colnames(cacheUpdate())) { - nrow(cacheUpdate() %>% filter(!as.logical(callCaching.hit))) - } else { - 0 - }, - icon = icon("meh"), - color = "orange", width = 6 - ) - }) ## Outputs Data ### Go get the output data for the selected workflow - outputsUpdate <- eventReactive(input$getOutputData, + outputsUpdate <- eventReactive(c( + input$selectedWorkflowId, + input$getOutputData + ), { - data <- workflowUpdate() - FOCUS_ID <<- data[input$joblistCromwell_rows_selected, ]$workflow_id - 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(), + expr = outputsUpdate(), class = "compact", filter = "top", options = list(scrollX = TRUE), rownames = FALSE ) + output$outputsAlert <- renderUI({ + if (NROW(outputsUpdate()) == 0) { + alert("No output data found") + } + }) ## Prep outputs table for download output$downloadOutputs <- downloadHandler( filename = function() { diff --git a/app/sidebar.R b/app/sidebar.R deleted file mode 100644 index 562298b..0000000 --- a/app/sidebar.R +++ /dev/null @@ -1,60 +0,0 @@ -menu_item_welcome <- menuItem("Welcome", - tabName = "welcome", icon = icon("book-open"), - badgeLabel = "info", badgeColor = "black", - selected = TRUE, startExpanded = TRUE -) -menu_item_servers <- menuItem("PROOF Server", - tabName = "cromwell", icon = icon("truck-fast"), - badgeLabel = "proof", badgeColor = "yellow" -) -menu_item_validate <- menuItem("Validate", - tabName = "validate", icon = icon("stethoscope"), - badgeLabel = "check", badgeColor = "blue" -) -menu_item_submit <- menuItem("Submit Jobs", - tabName = "submission", icon = icon("paper-plane"), - badgeLabel = "compute", badgeColor = "green" -) -menu_item_track <- menuItem("Track Jobs", - tabName = "tracking", icon = icon("binoculars"), - badgeLabel = "monitor", badgeColor = "aqua" -) -menu_item_trouble <- menuItem("Troubleshoot", - tabName = "troubleshoot", icon = icon("wrench"), - badgeLabel = "troubleshoot", badgeColor = "red" -) -menu_item_viewer <- menuItem("Viewer", - tabName = "viewer", icon = icon("wrench"), - badgeLabel = "viewer", badgeColor = "purple" -) -menu_item_wdl <- menuItem("WDL", - tabName = "wdl", icon = icon("wrench"), - badgeLabel = "wdl", badgeColor = "light-blue" -) - -proofSidebar <- function() { - sidebarMenu( - id = "tabs", - menu_item_welcome, - menu_item_servers, - menu_item_validate, - menu_item_submit, - menu_item_track, - menu_item_trouble, - menu_item_viewer, - menu_item_wdl - ) -} - -nonProofSidebar <- function() { - sidebarMenu( - id = "tabs", - menu_item_welcome, - menu_item_validate, - menu_item_submit, - menu_item_track, - menu_item_trouble, - menu_item_viewer, - menu_item_wdl - ) -} diff --git a/app/tab-servers.R b/app/tab-servers.R index b504199..81df152 100644 --- a/app/tab-servers.R +++ b/app/tab-servers.R @@ -1,51 +1,62 @@ -tab_servers <- tabItem( - tabName = "cromwell", - #fluidRow(h2("Manage Your PROOF Server"), align = "center"), - fluidRow( - align = "left", - box( - width = 12, solidHeader = FALSE, status = "warning", - collapsed = FALSE, - title = "Manage your PROOF Server", - p("Note: 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"), - actionButton( - inputId = "cromwellStart", - label = "Start a PROOF Server", - icon = icon("play"), - class = "btn-success" - ), - - br(), - br(), - h5("Current PROOF server information (if live)"), - uiOutput("proofStatusServerStartTime"), - uiOutput("proofStatusWorkflowLogDir"), - uiOutput("proofStatusScratchDir"), - uiOutput("proofStatusServerTime"), - uiOutput("proofStatusSlurmJobAccount"), - br(), - br(), - h4("Stop your PROOF Server"), - p(strong("Note"), " stopping your server cannot be undone, but you can always make another one!"), - actionButton( - inputId = "cromwellDelete", - label = "Stop a PROOF Server", - icon = icon("stop"), - class = "btn-danger" - ), - br(), - br(), - h4("Troubleshoot Your PROOF Server"), - p(strong("Note"), "If you're having trouble using your PROOF server, this information can be useful in getting help."), - uiOutput("proofStatusSlurmJobId"), - uiOutput("proofStatusCromwellDir"), - uiOutput("proofStatusServerLogDir"), - uiOutput("proofStatusSingularityCacheDir"), - uiOutput("proofStatusUseAWS"), - uiOutput("proofStatusUrlStr") - ), +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")), + 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"), + actionButton( + inputId = "cromwellStart", + label = "Start a PROOF Server", + icon = icon("play"), + class = "btn-success", + width = "250px" ), + h5("Current PROOF server information (if live)"), + uiOutput("proofStatusServerStartTime"), + uiOutput("proofStatusWorkflowLogDir"), + uiOutput("proofStatusScratchDir"), + uiOutput("proofStatusServerTime"), + uiOutput("proofStatusSlurmJobAccount"), + h4("Stop your PROOF Server"), + 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", + icon = icon("stop"), + class = "btn-danger", + width = "250px" + ) +) + +card2 <- card( + id = "cromwell_troubleshoot", + class = "border border-warning", + card_header(h2("Troubleshoot Your PROOF Server")), + 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"), + uiOutput("proofStatusSingularityCacheDir"), + uiOutput("proofStatusUseAWS"), + uiOutput("proofStatusUrlStr") +) + +tab_servers <- layout_column_wrap( + width = 1/2, + card1, + card2 ) diff --git a/app/tab-submission.R b/app/tab-submission.R index 5c26b81..ac3412c 100644 --- a/app/tab-submission.R +++ b/app/tab-submission.R @@ -1,54 +1,61 @@ -tab_submission <- tabItem( - tabName = "submission", - fluidRow( - box( - title = "Submit a Workflow", - width = 12, solidHeader = FALSE, status = "success", - collapsible = FALSE, collapsed = FALSE, - #title = "Submit a Workflow", - p("Submit your validated workflow to your PROOF server for execution by uploading your files and clicking `Submit Workflow`. - Only a WDL is required, and up to two optional input JSONs - can be uploaded (if identical variables are specified in both, the second input's variable value will overwrite the first). A json describing workflow options - can be provided if desired. Workflow labels are user-defined values you'd like to use to describe your workflows in the job tracking tab of this app. - Note: to submit new workflows, simply upload your new files and hit `Submit Workflow` again. You can use the `Reset Form` button if you need to clear files before uploading new ones. "), - column( - width = 6, - fileInput( - inputId = "wdlFile", "Upload WDL (required):", - accept = ".wdl" - ), +tab_submission <- card( + id = "submission", + card_header(h2("Submit a Workflow")), + class = "border border-success", + tags$ul( + tags$li("Only a WDL is required for submission (requires v1.0)"), + tags$li("Label your WDL workflow to aid in tracking it after submission (we use random strings if these are missing)"), + tags$li("If two input JSON files are uploaded with identical variables, the second input's variable value will overwrite the first") + ), + layout_columns( + col_widths = 6, + fillable = FALSE, + card( + fileInput( + inputId = "wdlFile", "Upload WDL (required):", + accept = ".wdl" + ), + textInput( + inputId = "labelValue", "Workflow Label (optional)", + value = "", + placeholder = "e.g., First Try" + ), + textInput( + inputId = "seclabelValue", "Secondary Workflow Label (optional)", + value = "", + placeholder = "e.g., Cohort 2" + ), + shinyjs::disabled(actionButton( + inputId = "submitWorkflow", + label = "Submit Workflow", + icon = icon("paper-plane"), + width = "250px", + class = "btn-success" + )), + card( + uiOutput(outputId = "submissionResult") + ), + actionButton( + inputId = "resetSubmission", + label = "Reset Form", + width = "250px" + ) + ), + layout_columns( + col_widths = 12, + fillable = FALSE, + card( fileInput( - inputId = "inputJSON", "Upload First Input JSON (optional):", + inputId = "inputJSON", "First Input JSON (optional):", accept = ".json" ), fileInput( - inputId = "input2JSON", "Upload Second Input JSON (optional):", + inputId = "input2JSON", "Second Input JSON (optional):", accept = ".json" ), - actionButton( - inputId = "submitWorkflow", - label = "Submit Workflow", - icon = icon("paper-plane") - ), - actionButton("resetSubmission", "Reset Form"), - verbatimTextOutput(outputId = "submissionResult") - - ), - column( - width = 6, fileInput( - inputId = "workOptions", "Upload Workflow Options JSON (optional):", + inputId = "workOptions", "Workflow Options JSON (optional):", accept = ".json" - ), - textInput( - inputId = "labelValue", "Workflow Label (optional)", - value = "", - placeholder = "e.g., First Try" - ), - textInput( - inputId = "seclabelValue", "Secondary Workflow Label (optional)", - value = "", - placeholder = "e.g., Cohort 2" ) ) ) diff --git a/app/tab-tracking.R b/app/tab-tracking.R index 60e8be8..a74d3fa 100644 --- a/app/tab-tracking.R +++ b/app/tab-tracking.R @@ -1,170 +1,111 @@ -source("ui_components.R") library(bsicons) +library(htmltools) +library(glue) +library(bslib) +library(shinycssloaders) -tab_tracking <- tabItem( - tabName = "tracking", - fluidRow( - box( - title = "Track your Workflows", - width = 12, solidHeader = FALSE, status = "info", - collapsible = FALSE, collapsed = FALSE, - p("Once you've submitted workflows, you can track the status of all the workflows you've submitted - in the specified time range by clicking `Update View`. If you use PROOF a lot, - this and the filtering tools below can help you return only the workflows you're interested in monitoring, - making tracking and the application itself much faster. "), - - numericInput("daysToShow", "Days of History to Display:", - min = 1, max = 21, value = 1, step = 1, width = "35%"), - - textInput("workName", "Filter for workflows with name:", - value = "", - placeholder = "myCustomWorkflow", - width = "35%" - ), - selectInput("workStatus", - label = "Filter for Workflows with Status(es):", - choices = c( - "Submitted", "Running", - "Succeeded", "Failed", "Aborting", - "Aborted" - ), - multiple = TRUE, - width = "35%" - ), - actionButton( - inputId = "trackingUpdate", - label = "Update View", - icon = icon("refresh") - ) - ) - ), - fluidRow( - box( - width = 12, - infoBoxOutput("submittedBox", width = 6), - infoBoxOutput("inprogressBox", width = 6), - infoBoxOutput("successBox", width = 6), - infoBoxOutput("failBox", width = 6) - ) - ), - fluidRow( - box( - width = 12, - title = "Workflow Timing", - collapsible = TRUE, solidHeader = TRUE, - plotOutput("workflowDuration") - ) - ), - fluidRow( - box( - width = 12, - title = "Workflows Run", - collapsible = TRUE, - solidHeader = TRUE, - footer = table_footer(), - DTOutput("joblistCromwell") - ) +source("ui_components.R") +source("constants.R") + +sidebar_tracking <- sidebar( + actionButton( + inputId = "trackingUpdate", + label = "Refresh data", + icon = icon("refresh") ), - fluidRow(h3("Workflow Specific Job Information"), - align = "center", - p("Select a row in the above table for a specific workflow id in order to populate the tables below. "), - valueBoxOutput("pendingBatch", width = 3), - infoBoxOutput("runningBatch", width = 3), - infoBoxOutput("succeededBatch", width = 3), - infoBoxOutput("failedBatch", width = 3) + popover( + bsicons::bs_icon("question-circle"), + p("Data for the past 60 days"), + title = "Help", + placement = "bottom" ), - fluidRow( - box( - width = 12, - title = "Workflow Description", - footer = table_footer(), - DTOutput("workflowDescribe") - ) + hr(), + textInput( + inputId = "workName", + label = "Workflow name", + value = "", + placeholder = "myCustomWorkflow", ), - fluidRow( - box( - width = 6, - title = "Workflow Options", - actionButton(inputId = "wdlview", - label = bsicons::bs_icon("search"), - class = "btn-sm"), - DTOutput("workflowOpt") + selectInput( + inputId = "workStatus", + label = "Status", + choices = c( + "Submitted", "Running", + "Succeeded", "Failed", "Aborting", + "Aborted" ), - box( - width = 6, - title = "Workflow Inputs", - actionButton("linkToViewerTab", "View list") - ) - ), - fluidRow( - align = "center", - box( - width = 12, - title = "Workflow Call Duration", - collapsible = TRUE, solidHeader = TRUE, - plotOutput("workflowTiming") - ) - ), - fluidRow( - box( - width = 12, - title = "Job List", - collapsible = TRUE, - solidHeader = TRUE, - collapsed = FALSE, - footer = table_footer(copy = FALSE), - downloadButton("downloadJobs", "Download Workflow Jobs Data"), - DTOutput("tasklistBatch") - ) + multiple = TRUE, ), - fluidRow( - box( - width = 12, - title = "Job Failures", - p("Specific information for jobs with a status of 'Failed', only available upon request."), - collapsible = TRUE, solidHeader = TRUE, collapsed = FALSE, - actionButton( - inputId = "getFailedData", - label = "Get/Refresh Failed Job Metadata", - icon("refresh") - ), - downloadButton("downloadFails", "Download Call Failure Data"), - DTOutput("failurelistBatch") - ) + dateRangeInput( + inputId = "runs_date", + label = "Date Range", + start = lubridate::today() - DAYS_WORKFLOW_HISTORY, + min = lubridate::today() - DAYS_WORKFLOW_HISTORY, + end = lubridate::today(), + max = lubridate::today(), + format = "m/d/yy" ), - fluidRow( - align = "center", - infoBoxOutput("cacheHits", width = 6), - infoBoxOutput("cacheMisses", width = 6) + selectInput( + inputId = "sortTracking", + label = "Sort", + choices = c( + "Newest to oldest", + "Oldest to newest" + ), + selected = "Newest to oldest", + multiple = FALSE ), - fluidRow( - box( - width = 12, - title = "Call Caching ", - p("Only available upon request. Note: this can be slow for very complex workflows. "), - collapsible = TRUE, solidHeader = TRUE, collapsed = FALSE, - actionButton( - inputId = "getCacheData", - label = "Get/Refresh Call Caching Metadata", - icon("refresh") - ), - downloadButton("downloadCache", "Download Call Caching Data"), - DTOutput("cachingListBatch") - ) + actionButton( + inputId = "resetTrackingFilters", + label = "Reset all filters", + class = "btn-sm" + ) +) + +card_tracking_intro <- card( + fill = FALSE, + card_header( + h3("Track your Workflows"), + popover( + bsicons::bs_icon("question-circle"), + p("Click", strong("Refresh data"), " to update data on this page. + Use the filtering tools in the sidebar to help you return only + the workflows you're interested in monitoring."), + title = "Help", + placement = "left" + ), + class = "d-flex align-items-center justify-content-between gap-1" ), - fluidRow( - box( - width = 12, - title = "Get Workflow Outputs", - p("The specific outputs to the entire workflow itself are listed here only upon request and only if they are all available. "), - collapsible = TRUE, solidHeader = TRUE, collapsed = FALSE, - actionButton( - inputId = "getOutputData", - label = "Get/Refresh Workflow Output Metadata", - icon("refresh") - ), - downloadButton("downloadOutputs", "Download Workflow Output Data"), - DTOutput("outputslistBatch") + card_body( + fillable = FALSE, + uiOutput("trackingSummaryStats") + ) +) + +card_timing <- card( + plotOutput("workflowDuration") +) + +workflow_cards <- layout_column_wrap( + width = 1/1, + fillable = FALSE, + shinycssloaders::withSpinner( + uiOutput("workflows_cards") + ) +) + +tab_tracking <- page_sidebar( + fillable = FALSE, + sidebar = sidebar_tracking, + card_tracking_intro, + navset_card_underline( + nav_panel( + title = "Workflow Runs", + workflow_cards + ), + nav_panel( + title = "Workflow Timing", + card_timing ) ) ) diff --git a/app/tab-troubleshoot.R b/app/tab-troubleshoot.R index 275d2fb..d5811bc 100644 --- a/app/tab-troubleshoot.R +++ b/app/tab-troubleshoot.R @@ -1,50 +1,22 @@ -tab_troublehsoot <- tabItem( - tabName = "troubleshoot", - fluidRow( - align = "left", - box( - title = "Abort a Workflow", - p("Aborting a workflow cannot be undone and can take some time to fully stop all jobs submitted in complex or highly parallelized workflows."), - collapsible = TRUE, collapsed = FALSE, - width = 12, solidHeader = FALSE, status = "danger", - textInput( - inputId = "abortWorkflowID", - label = "Workflow id to abort:", - value = "", - placeholder = "577b9aa4-b26b-4fd6-9f17-7fb33780bbd0", - width = "30%" - ), - actionButton( - inputId = "abortWorkflow", - label = "Abort Workflow", - icon = icon("thumbs-down") - ), - actionButton("resetAbort", "Reset"), - verbatimTextOutput(outputId = "abortResult") - ) - ), - fluidRow( - align = "left", - ## Troubleshoot a workflow via Glob - box( - width = 12, solidHeader = FALSE, status = "danger", - collapsible = TRUE, collapsed = FALSE, - title = "Troubleshoot a Workflow", +library(shinyjs) + +source("utils.R") + +panel_troublehsoot <- nav_panel( + title = "Troubleshoot", + id = "detailsTroubleshoot", + card( + class = "border border-primary", + full_screen = TRUE, + card_header(h2("Troubleshoot a Workflow")), + 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 = "30%" - ), - actionButton( - inputId = "troubleWorkflow", - label = "Get Complete Workflow Metadata", - icon = icon("wrench") - ), - actionButton("resetTrouble", "Reset"), - verbatimTextOutput(outputId = "troubleResult") + br(), + load_spinner( + verbatimTextOutput(outputId = "troubleResult") + ) ) - ) + ), + shinyjs::useShinyjs() ) diff --git a/app/tab-validate.R b/app/tab-validate.R index 259abf5..f895725 100644 --- a/app/tab-validate.R +++ b/app/tab-validate.R @@ -1,34 +1,22 @@ -tab_validate <- tabItem( - tabName = "validate", - fluidRow( - align = "left", - ## Validate a Workflow - box( - width = 12, solidHeader = FALSE, status = "primary", - collapsible = FALSE, collapsed = FALSE, - title = "Validate a Workflow", - p("Before running a WDL, you'll want to check to see if the WDL (and its input JSON, if you choose to upload it) - are in the correct format required. If they are not, the app will give you some - hints as to what might be wrong. - Tip: If your workflow does not validate, the feedback often hints - at a problem just below where your error actually is. "), - fileInput( - inputId = "validatewdlFile", "Upload WDL File (required):", - accept = ".wdl" - ), - fileInput( - inputId = "validateinputFile", "Upload Consolidated Input JSON (optional):", - accept = ".json" - ), - actionButton( - inputId = "validateWorkflow", - label = "Validate Workflow", - icon = icon("stethoscope") - ), - #br(), - #br(), - actionButton("resetValidate", "Reset"), - verbatimTextOutput(outputId = "validationResult") - ) - ) +tab_validate <- card( + id = "validate", + class = "border border-primary", + card_header(h2("Validate a Workflow")), + p("Note: Your WDL may validate but still fail; for instance if you lack permissions for files or directories that the workflow needs to execute its tasks"), + fileInput( + inputId = "validatewdlFile", "Upload WDL File (required):", + accept = ".wdl" + ), + fileInput( + inputId = "validateinputFile", "Upload Consolidated Input JSON (optional):", + accept = ".json" + ), + actionButton( + inputId = "validateWorkflow", + label = "Validate Workflow", + icon = icon("stethoscope"), + width = "250px" + ), + actionButton("resetValidate", "Reset", width = "250px"), + verbatimTextOutput(outputId = "validationResult") ) diff --git a/app/tab-viewer.R b/app/tab-viewer.R deleted file mode 100644 index e3c1f48..0000000 --- a/app/tab-viewer.R +++ /dev/null @@ -1,16 +0,0 @@ -library(listviewer) - -tab_viewer <- tabItem( - tabName = "viewer", - fluidRow( - box( - title = "View Workflow Inputs", - width = 12, - textOutput("currentWorkflowId"), - p(""), - actionButton("linkToTrackingTab", "Back to Track Jobs Tab"), - p(""), - reactjsonOutput("workflowInp", height = "100%") - ) - ) -) diff --git a/app/tab-wdl.R b/app/tab-wdl.R deleted file mode 100644 index 88b968b..0000000 --- a/app/tab-wdl.R +++ /dev/null @@ -1,7 +0,0 @@ -tab_wdl <- tabItem( - tabName = "wdl", - fluidPage( - actionButton("linkToTrackingTab", "Back to Track Jobs Tab"), - uiOutput("mermaid_diagram") - ) -) diff --git a/app/tab-welcome.R b/app/tab-welcome.R index 8d173bf..ea453a9 100644 --- a/app/tab-welcome.R +++ b/app/tab-welcome.R @@ -1,54 +1,49 @@ -welcome_servers_box <- box( - id = "boxServers", title = "PROOF Server", width = 4, solidHeader = TRUE, status = "warning", icon = icon("truck-fast"), - shiny::markdown("This tab allows you to: - - Start or delete your PROOF server - - Get metadata for your PROOF server"), - align = "left" -) +ablank <- function(...) { + htmltools::a(..., target = "_blank") +} -tab_welcome <- tabItem( - tabName = "welcome", - fluidRow( - column( - width = 12, - h2("What is this app?"), - shiny::includeMarkdown("about.md") - ) - ), - fluidRow( - align = "left", - h2("Dashboard Tabs"), - uiOutput("toggleServersBox"), - box( - id = "boxValidate", title = "Validate", width = 6, solidHeader = TRUE, status = "primary", icon = icon("stethoscope"), - shiny::markdown("This tab allows you to: - - Validate a workflow you'd like to run"), - align = "left" - ), - box( - id = "boxSubmit", title = "Submit Jobs", width = 6, solidHeader = TRUE, status = "success", icon = icon("paper-plane"), - shiny::markdown("This tab allows you to: - - Run a workflow"), - align = "left" - ) - ), - fluidRow( - align = "center", - box( - id = "boxTrack", title = "Track Jobs", width = 6, solidHeader = TRUE, status = "info", icon = icon("binoculars"), - shiny::markdown("This tab allows you to: - - Query your server database for the jobs run the most recent days (your choice how far back to go) - - See statuses of all your workflows - - Look within a workflow at the individual calls, failures and call caching results - - Download a list of the final workflow outputs for further processing"), - align = "left" - ), - box( - id = "boxTrouble", title = "Troubleshoot", width = 6, solidHeader = TRUE, status = "danger", icon = icon("wrench"), - shiny::markdown("This tab allows you to: - - Abort a workflow - - Troubleshoot the workflow itself by looking at the entire raw json of workflow metadata (it's especially helpful for complex workflows)"), - align = "left" +tab_welcome <- nav_panel( + title = "PROOF", + card( + card_body( + div( + h1("PROOF"), + h4("Run WDL workflows on the Fred Hutch cluster") + ), + 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/"), + "that simplifies user interactions with a", + ablank("Cromwell", href="https://cromwell.readthedocs.io/en/stable/"), + "server, an open source", + ablank("WDL", href="https://openwdl.org/"), + "workflow engine that can be used with the Fred Hutch scientific computing cluster. We are developing this + application alongside Fred Hutch oriented infrastructure with the intention to develop + open source resources to enable others to do the same."), + h3("To get started"), + tags$ol( + tags$li( + actionLink("proofAuth", "Log in to PROOF"), + "with your Fred Hutch credentials" + ), + tags$li(actionLink("linkToServerTab", "Start your PROOF/Cromwell server")), + tags$li("(optional)", actionLink("linkToValidateTab", "Validate your WDL")), + tags$li( + actionLink("linkToSubmitTab", "Submit your WDL"), + "and 1-2 optional json input and parameter files" + ), + tags$li( + actionLink("linkTrackingTab", "Track your workflow"), + "to see how long it takes and if it succeeds or fails" + ), + tags$li("Check", + actionLink("linkToWorkflowDetailsTab", "workflow details") + ) + ), + h4("To learn more about PROOF and WDL head over to the ", + actionLink("linkToHelpTab", "Help page") + ) ) ) ) diff --git a/app/tab-workflow_details.R b/app/tab-workflow_details.R new file mode 100644 index 0000000..f1087cd --- /dev/null +++ b/app/tab-workflow_details.R @@ -0,0 +1,141 @@ +library(listviewer) + +source("tab-troubleshoot.R") +source("utils.R") + +panel_job_list <- nav_panel( + title = "Job List", + id = "detailsJobs", + card_header( + downloadButton( + outputId = "downloadJobs", + label = "Download Workflow Jobs Data", + style = "width:20%" + ), + actionButton( + inputId = "refreshJobList", + label = "Refresh data", + icon = icon("refresh") + ) + ), + card_body( + load_spinner( + DTOutput("tasklistBatch") + ) + ), + card_footer(table_footer(copy = FALSE)) +) + +panel_workflow_description <- nav_panel( + title = "Workflow Description", + id = "detailsWorkflowDesc", + card_body( + load_spinner( + uiOutput("workflowDescribe") + ) + ) +) + +panel_diagram <- nav_panel( + title = "Diagram", + id = "detailsDiagram", + load_spinner( + uiOutput("mermaid_diagram") + ) +) + +panel_job_failures <- nav_panel( + title = "Job Failures", + id = "detailsJobFailures", + 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("failuresAlert"), + DTOutput("failurelistBatch") +) + +panel_call_caching <- nav_panel( + title = "Call Caching ", + id = "detailsCallCaching", + 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;" + ), + uiOutput("cachingAlert"), + load_spinner( + DTOutput("cachingListBatch") + ) +) + +panel_options <- nav_panel( + title = "Workflow Options", + id = "detailsWorkflowOptions", + br(), + uiOutput("workflowOptAlert"), + load_spinner( + DTOutput("workflowOpt") + ) +) + +panel_inputs <- nav_panel( + title = "Workflow Inputs", + id = "detailsWorkflowInputs", + load_spinner( + reactjsonOutput("workflowInp", height = "100%") + ) +) + +panel_outputs <- nav_panel( + title = "Workflow Outputs", + id = "detailsWorkflowOutputs", + 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("outputsAlert"), + DTOutput("outputslistBatch") +) + +tab_workflow_details <- card( + id = "workflow_details", + card_header( + uiOutput("selectedWorkflowUI"), + class = "d-flex gap-1 justify-content-between" + ), + navset_underline( + 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 936537c..bf517f6 100644 --- a/app/ui.R +++ b/app/ui.R @@ -1,3 +1,5 @@ +library(bslib) + library(shiny) library(shinyBS) library(shinyjs) @@ -21,49 +23,75 @@ source("tab-servers.R") source("tab-validate.R") source("tab-submission.R") source("tab-tracking.R") -source("tab-troubleshoot.R") -source("tab-viewer.R") -source("tab-wdl.R") -source("sidebar.R") +source("tab-workflow_details.R") + +contact_github <- tags$a(shiny::icon("github"), "Open Ticket", href = "https://github.com/getwilds/proof/issues/new?template=Blank+issue", target = "_blank") +contact_email <- tags$a(shiny::icon("paper-plane"), "Email", href = "mailto:wilds@fredhutch.org", target = "_blank") ui <- cookies::add_cookie_handlers( - dashboardPage( - skin = "black", - dashboardHeader( - title = tagList( - span(class = "logo-lg", h4(HTML("Fred Hutch
PROOF Dashboard"))), - img(src = "fred-hutch.svg") + page_navbar( + id = "proof", + 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" ), - dropdown_user_name, - dropdown_own_cromwell, - dropdown_loginout, - dropdown_help, - dropdown_src + "" ), - dashboardSidebar( - sidebarMenuOutput("uiSideBar") + bg = "#000000", + underline = TRUE, + header = tagList(google_analytics, enter_to_click), + tab_welcome, + nav_panel(title = "Server", tab_servers, tooltip_style), + nav_panel(title = "Validate", tab_validate, shinyjs::useShinyjs()), + 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(), + tooltip_style ), - dashboardBody( - tags$head(tags$title("PROOF")), - tags$script("document.title = 'PROOF';"), - shinyjs::useShinyjs(), + 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") ), - enter_to_click, - tooltip_style, - google_analytics, - tabItems( - tab_welcome, - tab_servers, - tab_validate, - tab_submission, - tab_tracking, - tab_troublehsoot, - tab_viewer, - tab_wdl + tooltip_style + ), + nav_panel(title = "Help", + card( + shiny::includeMarkdown("about.md"), + card_body( + h1("App details"), + htmlOutput("gitHtml") + ) ) + ), + nav_menu( + title = "Contact", + nav_item(contact_github), + nav_item(contact_email) + ), + nav_spacer(), + nav_item( + uiOutput("userName") + ), + nav_item( + uiOutput("ownCromwell") + ), + nav_item( + uiOutput("loggedInOut") ) ) -) \ No newline at end of file +) diff --git a/app/ui_components.R b/app/ui_components.R index 0bfcc81..5b66e93 100644 --- a/app/ui_components.R +++ b/app/ui_components.R @@ -1,52 +1,7 @@ -help_html <- helpText( - HTML('Need Help? -

-
- Problem? Bug? Open an issue -

-
-

- Discussion/Questions
- Slack #workflow-managers channel -
- Email wilds@fredhutch.org -

-

-

') -) - -dropdown_user_name <- tags$li( - class = "dropdown", - style = "padding: 12px;", - textOutput("userName") -) -dropdown_own_cromwell <- tags$li( - class = "dropdown", - style = "padding: 8px;", - uiOutput("ownCromwell") -) -dropdown_loginout <- tags$li( - class = "dropdown", - style = "padding: 8px;", - uiOutput("loggedInOut") -) -dropdown_help <- dropdownMenu( - type = "notifications", - badgeStatus = NULL, - icon = icon("circle-question", "fa-solid fa-lg"), - headerText = help_html -) -dropdown_src <- dropdownMenu( - type = "notifications", - badgeStatus = NULL, - icon = icon("github", "fa-solid fa-lg"), - headerText = helpText(htmlOutput("gitHtml")) -) - tooltip_style <- tags$style( HTML(" .tooltip{ - font-size: 1.5rem; + font-size: 1.1rem; } ") ) diff --git a/app/utils.R b/app/utils.R index 2f762fb..aa44f9a 100644 --- a/app/utils.R +++ b/app/utils.R @@ -1,5 +1,66 @@ library(memoise) 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) { @@ -78,11 +139,6 @@ make_wdlbtn <- function(workflow_id) { ) } -abbreviate <- function(x, last = 100) { - if (nchar(x) < 100) return(x) - paste0(substring(x, 1, last), " ...") -} - wdl_to_file <- function(workflow_id, url, token) { glob <- cromwell_glob(workflow_id, url = url, token = token) wdl_str <- glob$submittedFiles$workflow @@ -113,3 +169,27 @@ mermaid_container <- function(code) { ")) ) } + +card_header_color <- function(status) { + switch(status, + Submitted = "primary", + Pending = "info", + Running = "warning", + Succeeded = "success", + Failed = "danger", + Aborted = "secondary", + "secondary" + ) +} + +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/validators.R b/app/validators.R index 438c0ea..5232696 100644 --- a/app/validators.R +++ b/app/validators.R @@ -1,3 +1,5 @@ +library(shinyvalidate) + check_url <- function(x) { tmp <- tryCatch(cromwell_version(x), error = function(e) e) !rlang::is_error(tmp) 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 diff --git a/app/www/js/keyup.js b/app/www/js/keyup.js index 7ae0bee..8bab35f 100644 --- a/app/www/js/keyup.js +++ b/app/www/js/keyup.js @@ -11,7 +11,7 @@ $(document).keyup(function(event) { }); $(document).keyup(function(event) { - if ($("#stopCromwell").is(":focus") && (event.key == "Enter")) { + if (event.key == "Enter") { $("#deleteCromwell").click(); } });