Nothing
R/darwin_report_ui.R
In Certara.DarwinReporter: Data Visualization Utilities for 'pyDarwin' Machine Learning Pharmacometric Model Development
Defines functions
.run_shinyResults
update_tagged
darwinReportUI
Documented in
darwinReportUI
#' Generate and Report Model Diagnostics from NLME or NONMEM runs
#'
#' Shiny application to generate, customize, and report diagnostic plots and tables from NLME or
#' NONMEM output files. Create an Rmarkdown file of tagged model diagnostics and render into
#' submission ready report.
#'
#'
#' @param darwin_data Object of class \code{darwin_data}. Note, key_models xpose_data must be available.
#' @param tagged List of tagged objects returned from previous \code{tagged <- darwinReportUI()} session.
#' @param settings List of settings (e.g., settings.Rds) returned from previous Shiny session.
#' @param ... Additional arguments for Pirana integration.
#'
#'
#' @examples
#' if (interactive()) {
#' ddb <- darwin_data("./darwin_search_09") |>
#' import_key_models("./darwin_search_09/key_models")
#'
#' darwinReportUI(ddb)
#' }
#'
#' @return If \code{interactive()}, returns a list of tagged diagnostics from the Shiny application, otherwise returns \code{TRUE}.
#' @export
#'
darwinReportUI <- function(darwin_data, tagged = NULL, settings = NULL, ...) {
stopifnot(inherits(darwin_data, "darwin_data"))
arg_list <- list(...)
pirana <-
!is.null(arg_list$pirana) && isTRUE(arg_list$pirana)
if (pirana) {
pirana_dir <- dirname(darwin_data$project_dir)
} else {
pirana_dir <- NULL
}
model_name <- NULL
darwin_data_name <- deparse(substitute(darwin_data))
xpdb_name <- paste0(deparse(substitute(darwin_data)), "$key_models$xpose_data")
stopifnot(any(lapply(darwin_data[["key_models"]][["xpose_data"]], function(x)
is.xpdb(x)) == TRUE))
software <-
unique(unlist(lapply(darwin_data[["key_models"]][["xpose_data"]], function(x)
x$summary[x$summary$label == "software", "value"][[1]])))
if (length(software) > 1) {
stop(
"xpdb elements in list provided to `xpdb` arg x must be either 'nonmem' or 'nlme', but cannot be a combination of both."
)
}
if (!(software %in% c("nonmem", "phx/nlme"))) {
stop("software must be one of 'nonmem' or 'phx/nlme', please check xbdb$summary")
}
init_arg_type <- "xpdb_multiple"
hasResetInfo <- TRUE
if(software == "nonmem"){
software <- "NONMEM"
} else {
software <- "NLME"
}
if (is.null(settings) || settings == "") {
settings <- initialize_settings
} else {
if (is.character(settings)) {
stopifnot(file.exists(settings))
settings <- readRDS(settings)
}
settings <- modifyList(initialize_settings, settings)
}
tagged_diagnostics <- .run_shinyResults(darwin_data = darwin_data, tagged = tagged, software = software,
model_name = model_name, xpdb_name = xpdb_name, darwin_data_name = darwin_data_name,
init_arg_type = init_arg_type, hasResetInfo = hasResetInfo,
settings = settings, pirana = pirana, pirana_dir = pirana_dir)
if (interactive()) {
return(invisible(tagged_diagnostics))
} else {
return(TRUE)
}
}
update_tagged <- function(object, xpdb, obj, type, code, run, name){
if (name %in% c("Fitness vs Iteration", "Penalties vs Iteration", "Key Models")) {
xpdb <- NA
run <- NA
code <- sub("xpobj .*\\]\\n", "", code) #remove xpobj assignment
}
object$xpdb <- xpdb
object$obj <- obj
object$type <- type
object$code <- code
object$run <- run
object$name <- name
return(object)
}
#' @rawNamespace import(shiny, except = c(runExample, dataTableOutput, renderDataTable))
#' @rawNamespace import(dplyr, except = c(between, first, last))
#' @import ggplot2
#' @import flextable
#' @import shinyTree
#' @importFrom tidyr separate pivot_wider
#' @importFrom plotly renderPlotly plotlyOutput ggplotly
#' @import sortable
#' @rawNamespace import(colourpicker, except = c(runExample))
#' @import shinymeta
#' @import Certara.Xpose.NLME
#' @import xpose
#' @rawNamespace import(shinyjs, except = c(colourInput, updateColourInput, colourPicker))
#' @importFrom scales trans_breaks trans_format
#' @importFrom shinyWidgets chooseSliderSkin setSliderColor addSpinner
#' @import bslib
#'
.run_shinyResults <- function(darwin_data, tagged = NULL, software = NULL, model_name = NULL, xpdb_name = NULL, darwin_data_name = NULL, init_arg_type = NULL, hasResetInfo = FALSE, settings = NULL, pirana = FALSE, pirana_dir = NULL) {
xpdb <- darwin_data[["key_models"]][["xpose_data"]]
# Setup tree
if(software == "NLME"){
resultsTreeList <- resultsTreeListNLME
} else {
resultsTreeList <- resultsTreeListNONMEM
}
plot_desc_location <- system.file("extdata","plot_desc.csv",package="Certara.DarwinReporter")
plot_desc <- read.csv(plot_desc_location)
fitness_penalties_key_models_df <-
summarise_fitness_penalties_by_key_models(darwin_data)
fitness_penalties_key_models_df$model_file <-
sprintf('<button id="btn_%s" class="action-button"><i class="fas fa-file"></i></button>',
fitness_penalties_key_models_df$model_iteration)
fitness_penalties_key_models_df$plot <-
sprintf('<button id="btn_plot_%s" class="action-button"><i class="fas fa-chart-line"></i></button>',
fitness_penalties_key_models_df$model_iteration)
fitness_penalties_key_models_df <- fitness_penalties_key_models_df %>%
dplyr::relocate(model_file, plot, .before = iteration) %>%
dplyr::select(-run_dir, -iteration) %>%
dplyr::rename(model_name = model_iteration)
server <- function(input, output, session) {
output$runInfoCards <- renderUI({
search_overview_cards(darwin_data$search_overview)
})
output$fitnessVsIteration <- plotly::renderPlotly({
fitness_vs_iteration(darwin_data) %>%
plotly::ggplotly()
})
output$fitnessPenaltiesVsIteration <- plotly::renderPlotly({
fitness_penalties_vs_iteration(darwin_data, group_penalties = FALSE, scale_ofv = TRUE) %>%
plotly::ggplotly()
})
output$fitnessSummaryTable <- DT::renderDT({
DT::datatable(fitness_penalties_key_models_df, escape = FALSE,
selection = list(mode = 'single'),
options = list(
preDrawCallback = DT::JS("function() { Shiny.unbindAll(this.api().table().node()); }"),
drawCallback = DT::JS(
"function() { Shiny.bindAll(this.api().table().node()); }"
),
scroll_x = TRUE,
dom = "t",
pageLength = 100,
select = list(style = 'single')
)
)
})
key_models <- names(darwin_data$key_models$code)
observe({
lapply(key_models, function(x) {
#Open Control File Modal
observeEvent(input[[paste0("btn_", x)]], {
code <- darwin_data$key_models$code[[x]]
showModal(
modalDialog(
title = NULL,
shinyAce::aceEditor(
outputId = "key_model_code",
minLines = 5,
maxLines = 200,
value = NULL,
readOnly = TRUE,
height = "1000px",
autoScrollEditorIntoView = TRUE
),
easyClose = TRUE,
footer = NULL
)
)
shinyAce::updateAceEditor(
session,
"key_model_code",
mode = "text",
tabSize = 4,
useSoftTabs = FALSE,
showInvisibles = FALSE,
showLineNumbers = TRUE,
value = paste0(c(code, ""), collapse = "\n")
)
})
# Redirect to Diagnostics Plots/Tables for Key Model
observeEvent(input[[paste0("btn_plot_", x)]], {
session$sendCustomMessage(type = "shinymaterialJS", js$select_sidenav_tab("side_nav_tab_diagnostics"))
updateSelectInput(session = session, inputId = "selectedModel", selected = x)
if (length(reactiveSelections$value$tree) == 0) {
showModal(
modalDialog(
title = "Welcome",
p("Select a model diagnostic from the available options on the left."),
easyClose = TRUE,
footer = NULL
)
)
Sys.sleep(3)
}
#shinyTree::updateTree(session, "treeModelDiagnostics", data = list(`DV vs PRED` = "DV vs PRED"))
})
})
})
observeEvent(input$backToSearchOverview, {
session$sendCustomMessage(type = "shinymaterialJS", js$select_sidenav_tab("side_nav_tab_search_overview"))
})
# Create reactive selections ----
reactiveSelections <- reactiveValues(value = list(tree = NULL,
col_names = "",
cat_cov = "",
cont_cov = "",
covariates = "",
selected_cov = "",
selected_facet = "",
selected_page = 1,
type = ""))
observe({
req(xpdbSelected())
if (!is.null(xpdbSelected()$data)) {
reactiveSelections$value$col_names <-
xpdbSelected()$data$index[[1]]$col
reactiveSelections$value$cat_cov <-
Certara.Xpose.NLME:::.get_cat_cov(xpdbSelected()$data$index[[1]])
reactiveSelections$value$cont_cov <-
Certara.Xpose.NLME:::.get_cont_cov(xpdbSelected()$data$index[[1]])
reactiveSelections$value$covariates <-
c(reactiveSelections$value$cat_cov,
reactiveSelections$value$cont_cov)
reactiveSelections$value$selected_cov <-
ifelse(is.null(input$selectedCovariate),
"",
input$selectedCovariate)
reactiveSelections$value$selected_facet <- input$selectedFacet
reactiveSelections$value$selected_page <- input$selectedPage
reactiveSelections$value$has_eta <- has_type(xpdbSelected()$data$index[[1]], type = "eta")
reactiveSelections$value$has_param <- has_type(xpdbSelected()$data$index[[1]], type = "param")
}
}, suspended = FALSE, priority = 3)
# Disabling UI Inputs ----
observe({
toggleVisibility(selector = '.custom_plot_theme_inputs', condition = !input$isCertaraTheme)
toggleVisibility(selector = '.custom_text_inputs', condition = !input$isDefaultText)
toggleVisibility(selector = '.custom_facet_arrangement', condition = !input$isDefaultArrangement)
toggleVisibility(selector = '.custom_style_point', condition = input$displayPoints)
toggleVisibility(selector = '.custom_style_lines', condition = input$displayLines)
toggleVisibility(selector = '.custom_style_ref_line', condition = input$displayRefLine)
toggleVisibility(selector = '.custom_style_smoothing_line', condition = input$displaySmoothing)
toggleVisibility(selector = '.custom_style_histogram', condition = input$displayHistogram)
toggleVisibility(selector = '.custom_style_density', condition = input$displayDensity)
toggleVisibility(selector = '.custom_style_rug', condition = input$displayRug)
toggleVisibility(selector = '.custom_style_outliers', condition = input$displayOutliers)
toggleVisibility(selector = '.custom_hlines', condition = input$isExtraHlines)
toggleVisibility(selector = '.custom_legend', condition = input$displayLegend)
})
if(pirana){
shinyjs::hide("generateReport")
shinyjs::show("generateReportPirana")
}
# Span validation ----
observeEvent(input$smoothingType,{
if(input$smoothingType == "loess"){
shinyjs::enable("spanSmooth")
} else {
shinyjs::disable("spanSmooth")
}
})
spanValidation <- reactive({
validate(
need(input$spanSmooth <= 1 && input$spanSmooth > 0, "Error: Span value must be between 0-1")
)
})
output$spanRangeValidation <- renderPrint({
spanValidation()
})
# Updating inputs based on tree defaults
observe({
tree <- reactiveSelections$value$tree
if(length(tree) == 0) return()
if(tree %in% qq_trees){
updateCheckboxInput(session = session, inputId = "displayLines", value = FALSE)
updateCheckboxInput(session = session, inputId = "displaySmoothing", value = FALSE)
updateCheckboxInput(session = session, inputId = "displayText", value = FALSE)
disable("displayLines")
disable("displaySmoothing")
disable("displayText")
} else {
enable("displayLines")
enable("displaySmoothing")
if(tree %in% covariate_trees){
updateCheckboxInput(session = session, inputId = "displayText", value = FALSE)
disable("displayText")
} else {
enable("displayText")
}
}
})
# Update plot type
checkPlotTypes <- reactive({
list(input$treeModelDiagnostics,
input$selectedCovariate)
})
observeEvent(checkPlotTypes(), {
tree <- shinyTree::get_selected(input$treeModelDiagnostics)
reactiveSelections$value$tree <- tree
if(length(tree) == 0){
return()
} else if(tree %in% distribution_trees){
updateSelectInput(session = session, inputId = "selectedPlotType", selected = "distribution")
updateCheckboxInput(session = session, inputId = "isDefaultArrangement", value = TRUE)
} else if(tree %in% c("Individual Plots (IVAR)", "Individual Plots (TAD)")){
updateSelectInput(session = session, inputId = "selectedPlotType", selected = "ind_plots")
updateCheckboxInput(session = session, inputId = "isDefaultArrangement", value = FALSE)
} else if(tree %in% covariate_trees){
if(length(reactiveSelections$value$covariates) == 0){
return()
} else if(reactiveSelections$value$selected_cov %in% reactiveSelections$value$cat_cov ){
updateSelectInput(session = session, inputId = "selectedPlotType", selected = "covariate_box")
} else {
updateSelectInput(session = session, inputId = "selectedPlotType", selected = "covariate_scatter")
}
updateCheckboxInput(session = session, inputId = "isDefaultArrangement", value = TRUE)
} else if (!tree %in% branches_trees) {
updateSelectInput(session = session, inputId = "selectedPlotType", selected = "scatter")
updateCheckboxInput(session = session, inputId = "isDefaultArrangement", value = TRUE)
}
updateNumericInput(session = session, inputId = "selectedPage", value = 1)
}, suspended = FALSE, priority = 2)
# Observe Tree Input ----
observeEvent(input$treeModelDiagnostics,{
if(length(reactiveSelections$value$tree) == 0) {
shinyjs::hide("main_plot_preview")
shinyjs::hide("plottabs")
shinyjs::hide("main_table_preview")
return()
}
if(reactiveSelections$value$tree %in% branches_trees) {
return()
}
session$sendCustomMessage("switchTab", "tab_preview")
if (reactiveSelections$value$tree %in% c(darwin_trees, "Darwin Search")) {
shinyjs::hide("darwin_key_models_selection")
} else {
shinyjs::show("darwin_key_models_selection")
}
if(reactiveSelections$value$tree %in% table_trees){
shinyjs::hide("plotly_switch")
shinyjs::hide("main_plot_preview")
shinyjs::hide("plottabs")
shinyjs::show("main_table_preview")
} else {
shinyjs::show("plotly_switch")
shinyjs::hide("main_table_preview")
shinyjs::show("main_plot_preview")
shinyjs::show("plottabs")
if (reactiveSelections$value$tree %in% darwin_trees) {
shinyjs::hideElement(selector = "li.tab a[href$=\"#tab_layout\"]", asis = FALSE)
shinyjs::hide("gofStyleInputs")
shinyjs::hide("gofLayoutInputs")
shinyjs::show("darwinStyleInputs")
if (reactiveSelections$value$tree == "Fitness vs Iteration") {
shinyjs::hide("darwinStylePenaltyInputs")
shinyjs::show("darwinStyleFitnessInputs")
shinyjs::hide("xposeTextInputs")
shinyjs::show("darwinTextInputs")
}
if (reactiveSelections$value$tree == "Penalties vs Iteration") {
shinyjs::hide("darwinStyleFitnessInputs")
shinyjs::show("darwinStylePenaltyInputs")
shinyjs::hide("xposeTextInputs")
shinyjs::show("darwinTextInputs")
}
} else {
shinyjs::showElement(selector = "li.tab a[href$=\"#tab_layout\"]", asis = FALSE)
shinyjs::show("gofLayoutInputs")
shinyjs::show("gofStyleInputs")
shinyjs::hide("darwinStyleInputs")
shinyjs::hide("darwinTextInputs")
shinyjs::show("xposeTextInputs")
}
}
if(reactiveSelections$value$tree %in% no_refline_trees){
updateCheckboxInput(session = session, inputId = "displayRefLine", value = FALSE)
shinyjs::disable("displayRefLine")
} else {
shinyjs::enable("displayRefLine")
updateCheckboxInput(session = session, inputId = "displayRefLine", value = TRUE)
}
shinyjs::reset("spanSmooth")
updateCheckboxInput(session = session, inputId = "displaySmoothing", value = TRUE)
updateCheckboxInput(session = session, inputId = "isExtraHlines", value = FALSE)
updateCheckboxInput(session = session, inputId = "isLogX", value = FALSE)
updateCheckboxInput(session = session, inputId = "isLogY", value = FALSE)
updateSelectInput(session = session, inputId = "selectedFacet", selected = "none", choices = c("none", xpdbSelected()$data$index[[1]]$col))
reactiveTblCols$order <- NULL
}, priority = 1)
observeEvent(input$selectedModel,{
updateSelectInput(session = session, inputId = "selectedFacet", selected = "none", choices = c("none", xpdbSelected()$data$index[[1]]$col))
})
# UI: Covariate Selection ----
output$covSelection <- renderUI({ #try rendering in UI, then update selections
if(length(reactiveSelections$value$covariates) == 0) return()
tagList(
selectInput(inputId = "selectedCovariate", label = "Select Covariate", choices = reactiveSelections$value$covariates, selected = reactiveSelections$value$selected_cov)
)
})
# UI: Save Plot Name ----
output$userPlotName <- renderUI({
# req(input$treeModelDiagnostics)
if (length(reactiveSelections$value$tree) > 0 &&
reactiveSelections$value$tree %in% darwin_trees) {
plot_name <- reactiveSelections$value$tree
} else if (length(reactiveSelections$value$tree) > 0 &&
reactiveSelections$value$tree %in% covariate_trees) {
plot_name <-
paste(input$selectedModel, reactiveSelections$value$tree, input$selectedCovariate, sep = " - ")
} else {
plot_name <-
paste(input$selectedModel, reactiveSelections$value$tree, sep = " - ")
}
textInput("plotName", label = "Name", value = plot_name)
})
outputOptions(output, "userPlotName", suspendWhenHidden = FALSE)
# UI: Plot Page ----
# UI: Plot Name and Description ----
output$selectedPlotName <- renderText(
plot_desc[plot_desc$name == reactiveSelections$value$tree,][[1]]
)
output$selectedPlotDesc <- renderText(
plot_desc[plot_desc$name == reactiveSelections$value$tree,][[2]]
)
# View Xpose Modal
observeEvent(input$linkModalTags,{
showModal(
modalDialog(
size = "m",
easyClose = TRUE,
title = "xpose Tags",
div(style='height:500px; overflow-y: scroll', #Add vertical scroll bar to tree
shiny::tags$p(
tableOutput('tableXposeTags')
)
),
h5("See ?xpose::template_titles"),
footer = NULL
)
)
})
output$tableXposeTags <- renderTable({
templates_titles_df
})
# View Table Glossary Modal
observeEvent(input$linkModalTableGlossary,{
showModal(
modalDialog(
size = "m",
easyClose = TRUE,
title = "Table Glossary",
div(
style='height:500px;',
shiny::tags$p(
tableOutput('tableTableGlossary')
)
),
footer = NULL
)
)
})
output$tableTableGlossary <- renderTable({
table_glossary_df
})
reactiveModelName <- reactiveValues(name = "")
observeEvent(input$selectedModel,{
reactiveModelName$name <- input$selectedModel
})
xpdbSelected <- metaReactive2(varname = "xpobj",{
xpdbUser <- metaExpr({
xpdb[[..(input$selectedModel)]]
})
xpdbUser
})
# Preview Plot ----
mainPlotWrapper <- reactive({
mainPlotResult <- mainPlot() # Assume mainPlot is your metaReactive2 expression
if (is.null(mainPlotResult)) {
return(lastValidPlot())
} else {
lastValidPlot(mainPlotResult)
return(mainPlotResult)
}
})
lastValidPlot <- reactiveVal()
mainPlot <- metaReactive2(varname = "plot",{
req(xpdbSelected(), input$treeModelDiagnostics)
treeSelected <- reactiveSelections$value$tree
if(length(treeSelected) == 0){
treeSelected <- ""
}
if (treeSelected %in% branches_trees) {
return()
}
userPlot <- get_diagnostic(xpdb = xpdbSelected(),
treeSelected = treeSelected,
software = software,
input = input,
isCertaraTheme = input$isCertaraTheme,
isDefaultText = input$isDefaultText,
isDefaultArrangement = input$isDefaultArrangement,
isExtraHlines = input$isExtraHlines,
isShowLegend = input$displayLegend,
selectedCovariate = input$selectedCovariate,
selectedFacet = input$selectedFacet,
cols = reactiveSelections$value$col_names,
covCols = reactiveSelections$value$covariates,
catCov = reactiveSelections$value$cat_cov,
contCov = reactiveSelections$value$cont_cov,
covTrees = covariate_trees,
pageNumber = reactiveSelections$value$selected_page,
hasResetInfo = hasResetInfo,
darwin_data = darwin_data,
hasEta = reactiveSelections$value$has_eta,
hasParam = reactiveSelections$value$has_param)
lastValidPlot(userPlot)
userPlot
})
output$previewPlotly <- plotly::renderPlotly({
req(mainPlotWrapper(), input$treeModelDiagnostics)
treeSelected <- reactiveSelections$value$tree
if(input$isDynamic == FALSE) return(NULL)
if(length(treeSelected) == 0) return(NULL)
if(treeSelected %in% table_trees) return(NULL)
mainPlotWrapper() %>%
plotly::ggplotly()
})
output$previewPlot <- renderPlot({
req(mainPlotWrapper(), input$treeModelDiagnostics)
treeSelected <- reactiveSelections$value$tree
if(input$isDynamic == TRUE) return(NULL)
if(length(treeSelected) == 0) return(NULL)
if(treeSelected %in% table_trees) return(NULL)
mainPlotWrapper()
})
# Preview Table ----
output$selectTableCols <- renderUI({
req(input$treeModelDiagnostics)
treeSelected <- reactiveSelections$value$tree
if(length(treeSelected) == 0) return(NULL)
if(!(treeSelected %in% table_trees)) return(NULL)
if(software == "NONMEM"){
if(treeSelected == "Key Models"){
cols <- colsOverallDarwinNONMEM[!colsOverallDarwinNONMEM %in% "run_dir"]
penalty_cols <- colnames(fitness_penalties_key_models_df)[grepl("penalty", colnames(fitness_penalties_key_models_df))]
penalty_indices <- grep("^penalty_", cols)
# Extract those elements
penalty_elements <- cols[penalty_indices]
# Check which elements exist in 'penalty_cols'
valid_penalty_elements <- penalty_elements %in% penalty_cols
# Remove invalid elements from 'cols'
cols <- cols[-penalty_indices[!valid_penalty_elements]]
} else if(treeSelected == "Overall"){
cols <- colsOverallNONMEM
} else if (treeSelected %in% c("Theta", "Secondary")){
cols <- colsPrmNONMEM[-c(8,10,11, 12)]
} else {
cols <- colsPrmNONMEM
}
} else {
if(treeSelected == "Key Models"){
cols <- colsOverallDarwinNLME[!colsOverallDarwinNLME %in% "run_dir"]
penalty_cols <- colnames(fitness_penalties_key_models_df)[grepl("penalty", colnames(fitness_penalties_key_models_df))]
penalty_indices <- grep("^penalty_", cols)
# Extract those elements
penalty_elements <- cols[penalty_indices]
# Check which elements exist in 'penalty_cols'
valid_penalty_elements <- penalty_elements %in% penalty_cols
# Remove invalid elements from 'cols'
cols <- cols[-penalty_indices[!valid_penalty_elements]]
} else if(treeSelected == "Overall"){
cols <- colsOverallNLME
} else if (treeSelected %in% c("Theta", "Secondary")){
cols <- colsPrmNLME[-c(8,10,13, 14)]
} else {
cols <- colsPrmNLME
}
}
if(treeSelected %in% c("Theta", "Secondary")){
selected <- setdiff(cols, c("m", "rse"))
} else if(treeSelected == "Omega") {
selected <- setdiff(cols, c("m", "n", "rse", "shrinkage"))
} else if(treeSelected == "Sigma") {
if(software == "NONMEM"){
selected <- setdiff(cols, c("m", "n", "rse", "shrinkage"))
} else {
selected <- setdiff(cols, c("m", "n", "rse", "diagonal", "shrinkage"))
}
} else {
selected <- cols
}
tagList(
div(style = "position: reltaive; z-index: 99",
selectInput(inputId = "selectionTableCols", label = "Select Columns",
choices = cols, multiple = TRUE, selected = selected)
)
)
})
output$selectTableCaption <- renderUI({
req(input$treeModelDiagnostics)
treeSelected <- reactiveSelections$value$tree
if(length(treeSelected) == 0) return(NULL)
if(!(treeSelected %in% table_trees)) return(NULL)
textInput("tableCaption", label = "Caption Text", value = paste("Table", treeSelected, sep = " "), width = "125%")
})
# Order Table Columns ----
reactiveTblCols <- reactiveValues(
col.names = NULL,
order = NULL)
tblCols <- reactive({
cols <- c(input$RetCode, input$Condition, input$logLik,input$`-2LL`,input$AIC,
input$BIC,input$nParm,input$nObs,input$nSub, input$ofv,
input$nobs, input$nind, input$nparm, input$name, input$label,
input$value, input$se, input$rse, input$`rse%`, input$fixed, input$diagonal,
input$m, input$n, input$`2.5% CI`, input$`97.5% CI`, input$`shrinkage%`, input$shrinkage,
input$iteration, input$model_name, input$run_dir, input$fitness,
input$penalty_ntheta, input$penalty_nomega, input$penalty_nsigma, input$penalty_corr,
input$penalty_condition, input$penalty_success, input$penalty_r, input$penalty_python
)
cols
})
observeEvent(tblCols(),{
#NLME Overall
isolate({reactiveTblCols$col.names$RetCode <- input$RetCode})
isolate({reactiveTblCols$col.names$Condition <- input$Condition})
isolate({reactiveTblCols$col.names$logLik <- input$logLik})
isolate({reactiveTblCols$col.names$`-2LL` <- input$`-2LL`})
isolate({reactiveTblCols$col.names$AIC <- input$AIC})
isolate({reactiveTblCols$col.names$BIC <- input$BIC})
isolate({reactiveTblCols$col.names$nParm <- input$nParm})
isolate({reactiveTblCols$col.names$nObs <- input$nObs})
isolate({reactiveTblCols$col.names$nSub <- input$nSub})
isolate({reactiveTblCols$col.names$ofv <- input$ofv})
isolate({reactiveTblCols$col.names$nobs <- input$nobs})
isolate({reactiveTblCols$col.names$nind <- input$nind})
isolate({reactiveTblCols$col.names$nparm <- input$nparm})
isolate({reactiveTblCols$col.names$name <- input$name})
isolate({reactiveTblCols$col.names$label <- input$label})
isolate({reactiveTblCols$col.names$value <- input$value})
isolate({reactiveTblCols$col.names$se <- input$se})
isolate({reactiveTblCols$col.names$rse <- input$rse})
isolate({reactiveTblCols$col.names$`rse%` <- input$`rse%`})
isolate({reactiveTblCols$col.names$fixed <- input$fixed})
isolate({reactiveTblCols$col.names$diagonal <- input$diagonal})
isolate({reactiveTblCols$col.names$m <- input$m})
isolate({reactiveTblCols$col.names$n <- input$n})
isolate({reactiveTblCols$col.names$`2.5% CI` <- input$`2.5% CI`})
isolate({reactiveTblCols$col.names$`97.5% CI` <- input$`97.5% CI`})
isolate({reactiveTblCols$col.names$shrinkage <- input$shrinkage})
isolate({reactiveTblCols$col.names$`shrinkage%` <- input$`shrinkage%`})
#Darwin cols
isolate({reactiveTblCols$col.names$model_name <- input$model_name})
isolate({reactiveTblCols$col.names$iteration <- input$iteration})
isolate({reactiveTblCols$col.names$run_dir <- input$run_dir})
isolate({reactiveTblCols$col.names$fitness <- input$fitness})
isolate({reactiveTblCols$col.names$ofv <- input$ofv})
isolate({reactiveTblCols$col.names$penalty_ntheta <- input$penalty_ntheta})
isolate({reactiveTblCols$col.names$penalty_nomega <- input$penalty_nomega})
isolate({reactiveTblCols$col.names$penalty_nsigma <- input$penalty_nsigma})
isolate({reactiveTblCols$col.names$penalty_corr <- input$penalty_corr})
isolate({reactiveTblCols$col.names$penalty_condition <- input$penalty_condition})
isolate({reactiveTblCols$col.names$penalty_success <- input$penalty_success})
isolate({reactiveTblCols$col.names$penalty_r <- input$penalty_r})
isolate({reactiveTblCols$col.names$penalty_python <- input$penalty_python})
})
observeEvent(input$arrangementTblCols,{
isolate({reactiveTblCols$order <- input$arrangementTblCols})
})
output$selectTableArrangement <- renderUI({
req(input$treeModelDiagnostics)
treeSelected <- reactiveSelections$value$tree
if(length(treeSelected) == 0) return(NULL)
if(!(treeSelected %in% table_trees)) return(NULL)
if(length(input$selectionTableCols) > length(reactiveTblCols$order)){
add_col <- setdiff(input$selectionTableCols, reactiveTblCols$order)
cols <- c(reactiveTblCols$order, add_col)
} else {
pos <- reactiveTblCols$order %in% input$selectionTableCols
cols <- reactiveTblCols$order[pos]
}
ui <- tagList(
fluidRow(
div(style = "padding-left: 25px;, padding-bottom: 20px; padding-right: 25px;",
h4("Rename/Reorder Columns"),
h6("Drag below inputs to reorder table columns", style = "padding-bottom: 1rem; padding-top: 0.5rem;"),
div(
id = "sortable",
create_col_labels(cols, isolate({reactiveTblCols$col.names}))
)
),
sortable_js(
css_id = "sortable",
options = sortable_options(
direction = "horizontal",
onSort = sortable_js_capture_input(input_id = "arrangementTblCols")
)
)
)
)
ui
})
observeEvent(input$isTableCaption,{
if(input$isTableCaption){
shinyjs::enable("tableCaption")
} else {
shinyjs::disable("tableCaption")
}
})
observeEvent(input$isTableFooter,{
if(input$isTableFooter){
shinyjs::enable("tableFooter")
} else {
shinyjs::disable("tableFooter")
}
})
# Table ----
# Initialize a reactive value to store the last valid table
lastValidTable <- reactiveVal()
# Wrap the metaReactive2 expression in a standard Shiny reactive expression
mainTableWrapper <- reactive({
mainTableResult <- mainTable() # Assume mainPlot is your metaReactive2 expression
if (is.null(mainTableResult)) {
return(lastValidTable())
} else {
lastValidTable(mainTableResult)
return(mainTableResult)
}
})
mainTable <- metaReactive2(varname = "table", {
req(xpdbSelected(),
input$treeModelDiagnostics,
input$selectionTableCols)
treeSelected <-
shinyTree::get_selected(input$treeModelDiagnostics)
if (length(treeSelected) == 0) {
userTable <- NULL
} else if (treeSelected %in% table_trees) {
if (is.null(reactiveTblCols$order)) {
col_keys <- input$selectionTableCols
} else {
col_keys <- reactiveTblCols$order
}
if (length(input$selectionTableCols) > length(col_keys)) {
add_col <- setdiff(input$selectionTableCols, col_keys)
col_keys <- c(col_keys, add_col)
} else {
pos <- col_keys %in% input$selectionTableCols
col_keys <- col_keys[pos]
}
values <- reactiveTblCols$col.names[col_keys]
if (treeSelected == "Key Models") {
userTable <- get_darwin_table(
darwin_data = darwin_data,
treeSelected = treeSelected,
software = software,
col_keys = col_keys,
values = values,
isTableCaption = input$isTableCaption,
tableCaption = input$tableCaption,
isTableFooter = input$isTableFooter,
tableFooter = input$tableFooter,
digits = input$tableDigits,
align = input$tableAlign
)
} else {
userTable <- get_table(
xpdb = xpdbSelected(),
treeSelected = treeSelected,
software = software,
col_keys = col_keys,
values = values,
isTableCaption = input$isTableCaption,
tableCaption = input$tableCaption,
isTableFooter = input$isTableFooter,
tableFooter = input$tableFooter,
digits = input$tableDigits,
align = input$tableAlign
)
}
} else {
userTable <- NULL
}
userTable
})
output$previewTable <- renderUI({
req(mainTableWrapper())
mainTableWrapper() %>%
autofit() %>%
htmltools_value()
})
# Save Plot ----
if(!is.null(tagged)){
taggedDiagnostics <- reactiveValues(values = tagged)
} else {
taggedDiagnostics <- reactiveValues(values = list())
}
# Code generation ----
observeEvent(input$savePlot,{
treeSelected <- shinyTree::get_selected(input$treeModelDiagnostics)
if(treeSelected %in% table_trees){
code <- expandChain(mainTable())
code <- c(formatCode(code), "\n")
if(init_arg_type != "xpdb_multiple"){
code <- gsub("NULL\\[\\[", "xpdb\\[\\[", code)
} else {
code <- gsub(pattern = "xpdb", replacement = xpdb_name, x = code)
code <- gsub(pattern = "darwin_data", replacement = darwin_data_name, x = code)
}
taggedDiagnostics$values[[trimws(paste0(input$plotName))]] <- taggedDiagnostics$values[[trimws(paste0(input$plotName))]] %>%
update_tagged(xpdb = xpdbSelected(),
obj = mainTable(),
type = "table",
code = code,
run = input$selectedModel,
name = treeSelected[[1]])
} else {
code <- expandChain(mainPlot())
code <- add_gg_line_break(formatCode(code))
if(init_arg_type != "xpdb_multiple"){
code <- gsub("NULL\\[\\[", "xpdb\\[\\[", code)
} else {
code <- gsub(pattern = "xpdb", replacement = xpdb_name, x = code)
code <- gsub(pattern = "darwin_data", replacement = darwin_data_name, x = code)
}
taggedDiagnostics$values[[trimws(paste0(input$plotName))]] <- taggedDiagnostics$values[[trimws(paste0(input$plotName))]] %>%
update_tagged(xpdb = xpdbSelected(),
obj = mainPlot(),
type = "plot",
code = code,
run = input$selectedModel,
name = paste0(treeSelected))
}
removeModal()
}, suspended = FALSE)
observeEvent(input$selectDiagnostic, {
if(taggedDiagnostics$values[[paste0(input$selectDiagnostic)]]$type == "plot"){
shinyjs::hide("my_tagged_tables_out")
shinyjs::show("my_tagged_plots_out")
} else {
shinyjs::hide("my_tagged_plots_out")
shinyjs::show("my_tagged_tables_out")
}
shinyAce::updateAceEditor(
session,
"md_code",
mode = "r",
tabSize = 4,
useSoftTabs = FALSE,
showInvisibles = FALSE,
showLineNumbers = TRUE,
value = paste0(unlist(taggedDiagnostics$values[[paste0(input$selectDiagnostic)]][["code"]]), collapse = "\n")
)
})
# Preview Tagged Diagnostics ----
output$myTaggedDiagnostics <- renderUI({
if(length(names(taggedDiagnostics$values)) == 0){
selectDiagnostics <- tagList(
div(style = "padding-left: 15px",
h4("No Tagged Diagnostics")
)
)
} else {
selectDiagnostics <- tagList(
fluidRow(style = "align-items: flex-end",
column(
width = 5, style = "padding-left: 3rem; align-self: baseline;",
selectInput(inputId = "selectDiagnostic", label = "Tagged Model Diagnostics", choices = names(taggedDiagnostics$values),
width = "auto")
),
column(
width = 1, style = "padding-top: 0.7rem; align-self: center;",
actionLink(inputId = "removeTagged", icon = icon("trash"), label = "", style = "font-size: 22px;")
),
column(
width = 5, style = "align-self: baseline;",
textInput("nameTaggedScript", "R Script Name", value = "script", width = "125%")
),
column(
width = 1, style = "padding-top: 0.7rem; align-self: center;",
downloadLink(outputId = "saveTaggedScript", label = list(icon("download")), style = "font-size: 22px; color: rgba(var(--bs-link-color-rgb));")
)
)
)
}
selectDiagnostics
})
output$myTaggedPlots <- renderPlot({
req(input$selectDiagnostic)
if(length(taggedDiagnostics$values) == 0) return()
taggedDiagnostics$values[[input$selectDiagnostic]][[2]]
})
output$myTaggedTables <- renderUI({
req(input$selectDiagnostic)
if(length(taggedDiagnostics$values) == 0) return()
taggedDiagnostics$values[[input$selectDiagnostic]][[2]] %>%
autofit() %>%
htmltools_value()
})
# Show/Hide Tagged Diagnostics based on type
# Remove Tagged Diagnostics ----
# Add Confirmation Dialog
observeEvent(input$removeTagged, {
showModal(
modalDialog(
size = "m",
title = "Remove Tagged Diagnostic",
easyClose = TRUE,
div(
style = "padding-top: 10px;",
div(
style = "display: inline-block;",
actionButton("confirmRemoveTagged", label = "Confirm"),
),
div(
style = "display: inline-block;",
actionButton("cancelRemoveTagged", label = "Cancel"),
)
),
footer = NULL
)
)
})
observeEvent(input$confirmRemoveTagged, {
taggedDiagnostics$values[[input$selectDiagnostic]] <- NULL
removeModal()
})
observeEvent(input$cancelRemoveTagged, {
removeModal()
})
observe({
#TO DO, find out what tree structure is when only node is clicked...
if(length(names(taggedDiagnostics$values)) == 0){
shinyjs::hide("md_code")
} else {
shinyjs::show("md_code")
}
})
# Show/Hide Tagged Diagnostics ----
## Tag Diagnostics ----
observeEvent(input$open_savePlotModal, {
showModal(
modalDialog(
size = "m",
easyClose = TRUE,
fluidRow(
column(
width = 12,
uiOutput("userPlotName")
)
),
conditionalPanel("(!input.isDynamic && output.previewPlot) || (input.isDynamic && output.previewPlotly) || output.previewTable",
actionButton("savePlot", label = "Tag")
),
conditionalPanel("(!input.isDynamic && !output.previewPlot && !output.previewTable) || (input.isDynamic && !output.previewPlotly && !output.previewTable)",
actionButton("savePlot", label = "Tag") %>% shinyjs::disabled()
),
textOutput("userPlotDup"),
footer = NULL
)
)
})
## Validate Duplicated Tagged ----
dupTaggedValidation <- reactive({
validate(
need(!(input$plotName %in% names(taggedDiagnostics$values)), "Warning: Tagged diagnostic name already exists and will be overwritten")
)
})
output$userPlotDup <- renderPrint({
dupTaggedValidation()
})
outputOptions(output, "userPlotDup", suspendWhenHidden = FALSE)
# Save Script of Tagged Diagnostics ----
output$saveTaggedScript <- downloadHandler(
filename = function(){
paste(input$nameTaggedScript,"R", sep = ".")
},
content = function(file) {
# Copy the report file to a temporary directory before processing it
tagged <- taggedDiagnostics$values
libs <- c("library(Certara.DarwinReporter)",
"library(Certara.Xpose.NLME)",
"library(xpose)",
"library(ggplot2)",
"library(dplyr)",
"library(tidyr)",
"library(flextable)\n")
libs <- paste0(libs, collapse = "\n")
code <- lapply(tagged, function(x) x$code)
init <-
c(
paste0(
darwin_data_name,
" <- darwin_data(project_dir = '",
darwin_data$project_dir,
"',"
),
paste0("working_dir = '", darwin_data$working_dir, "',"),
paste0("output_dir = '", darwin_data$output_dir, "',"),
paste0("key_models_dir = '", darwin_data$key_models_dir, "')")
)
init <- gsub("\\\\", "\\\\\\\\", init)
init <- c(init, "\n\n")
if(pirana){
showModal(
modalDialog(
title = "File Saved",
p("File has been saved to your downloads folder and is additionally available in ./pirana_scripts"),
easyClose = TRUE,
footer = NULL
)
)
pirana_scripts <- file.path(pirana_dir, "pirana_scripts")
if(!dir.exists(pirana_scripts)){
dir.create(pirana_scripts)
}
print(paste0("saving pirana script to ", pirana_scripts))
writeLines(unlist(c(libs, init, code)), con = paste0(pirana_scripts, "/", input$nameTaggedScript,".R"))
}
writeLines(unlist(c(libs, init, code)), con = file)
}
)
observeEvent(input$isAutoFormat, {
if (!input$isAutoFormat) {
shinyjs::show(id = "customReportDraggable")
} else {
shinyjs::hide(id = "customReportDraggable")
}
})
#Generate Rmd ----
output$generateRmd <- downloadHandler(
filename = function(){
paste(input$reportName, "Rmd", sep = ".")
},
content = function(file) {
rmd <-
create_rmd(
darwin_data = darwin_data,
title = input$reportName,
objects = taggedDiagnostics$values,
orientation = input$pageLayout,
marginLeft = input$marginLeft,
marginRight = input$marginRight,
marginTop = input$marginTop,
marginBottom = input$marginBottom,
includeAppendix = input$includeAppendix,
autoFormat = input$isAutoFormat,
customOrder = input$rank_list_2,
raw = TRUE,
darwin_data_name = darwin_data_name
)
if(pirana){
showModal(
modalDialog(
title = "File Saved",
p("File has been saved to your downloads folder and is additionally available in ./pirana_scripts"),
easyClose = TRUE,
footer = NULL
)
)
pirana_scripts <- file.path(pirana_dir, "pirana_scripts")
if(!dir.exists(pirana_scripts)){
dir.create(pirana_scripts)
}
writeLines(unlist(c(rmd)), con = paste0(pirana_scripts, "/", gsub(":", "",input$reportName),".Rmd"))
}
writeLines(unlist(c(rmd)), con = file)
}
)
output$selectReport <- renderUI({
bucketReport <- tagList(
fluidRow(style = "padding-left:25px; padding-right:25px;",
bucket_list(
header = NULL,
group_name = "bucket_list_group",
orientation = "horizontal",
add_rank_list(
text = "Tagged",
labels = names(taggedDiagnostics$values),
input_id = "rank_list_1"
),
add_rank_list(
text = "Report Output",
labels = NULL,
input_id = "rank_list_2"
)
)
)
)
bucketReport
})
# Show modal if trying to generate a report and no tagged diagnostics
observeEvent(input$active_tab, {
active_tab <- input$active_tab
if (active_tab == "tab_report" && length(taggedDiagnostics$values) == 0) {
showModal(
modalDialog(
size = "m",
title = "No tagged plots or tables",
easyClose = TRUE,
p("Navigate to the 'Preview' tab and select a model diagnostic from the available options on the left, then click the 'Tag' button in the bottom right corner of the screen.")
)
)
}
})
output$generateReport <- downloadHandler(
filename = function(){
paste(input$reportName, input$fileType, sep = ".")
},
content = function(file) {
# Copy the report file to a temporary directory before processing it
create_rmd(
darwin_data = darwin_data,
title = input$reportName,
objects = taggedDiagnostics$values,
orientation = input$pageLayout,
marginLeft = input$marginLeft,
marginRight = input$marginRight,
marginTop = input$marginTop,
marginBottom = input$marginBottom,
includeAppendix = input$includeAppendix,
autoFormat = input$isAutoFormat,
customOrder = input$rank_list_2
)
tempReport <- file.path(tempdir(), "report_template.Rmd")
tempReportWord <- file.path(tempdir(), "report_template.docx")
wordTemplate <- system.file("extdata", "report_template.docx", package = "Certara.DarwinReporter", mustWork = TRUE)
file.copy("report_template.Rmd", tempReport, overwrite = TRUE)
file.copy(wordTemplate, tempReportWord, overwrite = TRUE)
if (input$isAutoFormat) {
params <- list(inputs = taggedDiagnostics$values,
darwin_data = darwin_data)
} else {
params <- list(inputs = taggedDiagnostics$values[input$rank_list_2],
darwin_data = darwin_data)
}
# Knit the document, passing in the `params` list, and eval it in a
# child of the global environment (this isolates the code in the document
# from the code in model results app).
shiny::withProgress(
message = paste0("Rendering ", input$reportName, ".", input$fileType),
value = 0,{
shiny::incProgress(3/10)
rmarkdown::render(tempReport, output_file = file,
output_format = report_render(input$fileType),
params = params,
envir = new.env(parent = globalenv()))
shiny::incProgress(7/10)
Sys.sleep(0.25)
shiny::incProgress(10/10)
})
file.remove("report_template.Rmd")
}
)
output$report_download_buttons <- renderUI({
if(pirana){
ui <- fluidRow(
column(
width = 4,
actionLink("generateReportPirana", label = list("Download Report", HTML(" "), icon("file-download")), style = "font-size: 18px; font-family:Segoe UI Light, Arial, sans-serif;")
),
column(
width = 4,
offset = 3,
downloadLink("generateRmd", label = list("Download RMarkdown", HTML(" "), icon("file-code")), style = "font-size: 18px; font-family:Segoe UI Light, Arial, sans-serif;")
)
)
} else {
ui <- fluidRow(
column(
width = 4,
downloadLink("generateReport", label = list("Download Report", HTML(" "), icon("file-download")), style = "font-size: 18px; font-family:Segoe UI Light, Arial, sans-serif; width: -webkit-fill-available;")
),
column(
width = 4,
offset = 3,
downloadLink("generateRmd", label = list("Download RMarkdown", HTML(" "), icon("file-code")), style = "font-size: 18px; font-family:Segoe UI Light, Arial, sans-serif; width: -webkit-fill-available;")
)
)
}
ui
})
observeEvent(input$generateReportPirana,{
filename <- paste(input$reportName, input$fileType, sep = ".")
filename <- gsub(":", "", filename)
create_rmd(
darwin_data = darwin_data,
title = input$reportName,
objects = taggedDiagnostics$values,
orientation = input$pageLayout,
marginLeft = input$marginLeft,
marginRight = input$marginRight,
marginTop = input$marginTop,
marginBottom = input$marginBottom,
includeAppendix = input$includeAppendix,
autoFormat = input$isAutoFormat,
customOrder = input$rank_list_2,
darwin_data_name= darwin_data_name
) #if missing directory argument uses wd
tempReport <- file.path(tempdir(), "report_template.Rmd")
tempReportWord <- file.path(tempdir(), "report_template.docx")
wordTemplate <- system.file("extdata", "report_template.docx", package = "Certara.DarwinReporter", mustWork = TRUE)
file.copy("report_template.Rmd", tempReport, overwrite = TRUE)
file.copy(wordTemplate, tempReportWord, overwrite = TRUE)
# Set up parameters to pass to Rmd document
if (input$isAutoFormat) {
params <- list(inputs = taggedDiagnostics$values,
darwin_data = darwin_data)
} else {
params <- list(inputs = taggedDiagnostics$values[input$rank_list_2],
darwin_data = darwin_data)
}
pirana_reports <- file.path(pirana_dir, "pirana_reports", "shiny")
if(!dir.exists(pirana_reports)){
dir.create(pirana_reports, recursive = TRUE)
}
# Knit the document, passing in the `params` list, and eval it in a
# child of the global environment (this isolates the code in the document
# from the code in model results app).
#NOTE Users should set this env variable from Windows if having issues with pandoc
#Sys.setenv(RSTUDIO_PANDOC = "C:/Program Files/RStudio/bin/pandoc")
shiny::withProgress(
message = paste0("Rendering ", input$reportName, ".", input$fileType),
value = 0,{
shiny::incProgress(3/10)
rmarkdown::render(tempReport, output_file = paste0(pirana_reports, "/", filename),
output_format = report_render(input$fileType),
params = params,
envir = new.env(parent = globalenv()))
shiny::incProgress(7/10)
Sys.sleep(0.25)
shiny::incProgress(10/10)
})
file.remove("report_template.Rmd")
showModal(
modalDialog(
title = "File Saved",
p("Report has been saved to ./pirana_reports/shiny"),
easyClose = TRUE,
footer = NULL
)
)
})
observeEvent(input$fileType, {
if (input$fileType == "pdf") {
shinyjs::show(id = "pdf_layout")
shinyjs::show(id = "pdf_options")
} else {
shinyjs::hide(id = "pdf_layout")
shinyjs::hide(id = "pdf_options")
}
})
# Model Diagnostics Tree Output ----
output$treeModelDiagnostics <- shinyTree::renderTree({
resultsTreeList
})
outputOptions(output, "treeModelDiagnostics", suspendWhenHidden = FALSE)
observeEvent(input$exitShiny, {
showModal(
modalDialog(
size = "m",
title = "Exit Darwin Reporter",
easyClose = TRUE,
fluidRow(
div(style = "padding-top: 10px;"),
column(
width = 4,
checkboxInput(inputId = "saveSettingsRds", label = "Save Settings", value = TRUE)
)
),
div(
style = "padding-top: 10px;",
div(
style = "display: inline-block;",
actionButton("exitConfirm", "Exit")
),
div(
style = "display: inline-block;",
actionButton("exitCancel", "Cancel")
)
),
footer = NULL
)
)
})
observeEvent(input$exitCancel, {
removeModal(session = session)
})
observeEvent(input$exitConfirm, {
# from the code in model results app).
shiny::withProgress(
message = paste0("Exiting Darwin Reporter"),
value = 0,
{
if(pirana){
dir_out <- file.path(pirana_dir, "pirana_shiny")
if(!dir.exists(dir_out)){
dir.create(dir_out)
}
} else {
dir_out <- "."
}
if (input$saveSettingsRds) {
settings_out <- update_settings(settings, input)
saveRDS(settings_out, file = paste0(dir_out, "/settings.Rds"))
shiny::incProgress(3 / 10, message = "Settings saved")
Sys.sleep(1)
}
# if (input$saveTaggedRds) {
# shiny::incProgress(7 / 10, message = "Saving tagged objects")
#
# tagged_out <- isolate({
# taggedDiagnostics$values
# })
#
# save_tagged_rds(parse_tagged(tagged_out), dir_out)
#
# }
}
)
removeModal()
message("Shiny session has ended")
# we can implement a try for above code, if FALSE, don't stop app.
session$sendCustomMessage(type = "shinymaterialJS", js$closewindow())
session$onSessionEnded(function() {
stopApp(isolate({
taggedDiagnostics$values
})
)
})
})
session$onSessionEnded(function() {
stopApp(isolate({taggedDiagnostics$values}))
}
)
}
ui <- tagList(
# 1.0 Shiny JS ----
shinyjs::useShinyjs(),
shinyjs::extendShinyjs(
text = jsFunctions2,
functions = c("closewindow", "select_sidenav_tab")
),
tags$head(tags$style(styleCSS)),
shinyWidgets::chooseSliderSkin("Modern", color = "#0a7bc1"),
tags$script(
'Shiny.addCustomMessageHandler("switchTab", function(tabName) {
var instance = M.Tabs.getInstance($(".tabs"));
instance.select(tabName);
});'
),
tags$script(
HTML(
"$(document).ready(function() {
$('ul.tabs').on('click', 'a', function() {
Shiny.setInputValue('active_tab', $(this).attr('href').substring(1));
});
});"
)
),
# 2.0 Header ----
certara_header("Darwin Reporter"),
# 3.0 Page ----
bslib::page_navbar(
title = NULL,
window_title = "Darwin Reporter",
## 3.1 Overview Page ----
bslib::nav_panel(
title = "Overview",
value = "side_nav_tab_search_overview",
bslib::card_body(
bslib::card(
fluidRow(
column(width = 2,
uiOutput("runInfoCards")),
column(
width = ifelse(is.null(darwin_data$search_overview), 12, 10),
fluidRow(
column(
width = 6,
bslib::card(
height = "400px",
full_screen = TRUE,
shinyWidgets::addSpinner(
plotly::plotlyOutput("fitnessVsIteration", height = "100%"),
spin = "circle",
color = "#0a7bc1"
)
)
),
column(
width = 6,
bslib::card(
height = "400px",
full_screen = TRUE,
shinyWidgets::addSpinner(
plotly::plotlyOutput("fitnessPenaltiesVsIteration", height = "100%"),
spin = "circle",
color = "#0a7bc1"
)
)
)
),
div(style = "padding-left: 15px",
h4("Key Models")),
div(
style = "overflow-x: auto;",
DT::DTOutput("fitnessSummaryTable")
)
)
)
)
)
),
## 3.2 Diagnostics Page ----
bslib::nav_panel(
title = "Diagnostics",
value = "side_nav_tab_diagnostics",
## 3.3 Sidebar ----
bslib::layout_sidebar(
sidebar = bslib::sidebar(
width = 350,
open = TRUE,
actionLink(inputId = "backToSearchOverview", icon = icon("arrow-left"), label = "Back to Search Overview", style = "font-size: 14px;"),
div(id ="darwin_key_models_selection", style = "padding-top: 5px;",
selectInput(inputId = "selectedModel", label = "Key Model", choices = names(xpdb)),
conditionalPanel("input.selectedPlotType == 'covariate_scatter' || input.selectedPlotType == 'covariate_box'",
uiOutput("covSelection")
)
) %>% shinyjs::hidden(),
div(style = "padding: 10px;"),
div(style="height:25rem; overflow-y: scroll;", #Add vertical scroll bar to tree
h5("Search"),
shinyTree::shinyTree("treeModelDiagnostics",
search = TRUE,
theme = "proton",
multiple = FALSE,
themeIcons = FALSE,
themeDots = TRUE
)
),
div(style = "padding: 10px;"),
bslib::card(
class = "sidebar-card",
h6("Currently Selected:"),
textOutput("selectedPlotName"),
div(style = "padding: 10px;"),
h6("Description:"),
textOutput("selectedPlotDesc")
),
div(id = "selected_plot_type", #Create hidden input for plot cusomtization conditional panel
selectInput(inputId = "selectedPlotType", label = "", choices = c("scatter", "distribution", "covariate_scatter", "covariate_box", "ind_plots", "none"), selected = "none")
) %>% shinyjs::hidden()
),
### 4.0 Main Body Card ----
bslib::navset_card_underline(
id = "maincard",
title = NULL,
#### 4.1 Preview Tab ----
bslib::nav_panel(
title = "Preview",
value = "tab_preview",
bslib::card_body(
height = "100%",
class = "preview-tab",
##### 4.1a Plot Display ----
div(
id = "main_plot_preview",
div(id = "plotly_switch", style = "padding-left: 15px; padding-bottom: 10px;",
checkboxInput(inputId = "isDynamic", label = "Interactive", value = FALSE)
) %>% shinyjs::hidden(),
div(id = "diagnostics-page-plot",
style = "padding-left: 25px; margin-left: 25px; padding-right: 25px; padding-bottom: 15px;",
conditionalPanel(
"input.isDynamic == false",
bslib::card(
style = "border: none;",
full_screen = TRUE,
shinyjqui::jqui_resizable(
plotOutput("previewPlot")
)
)
),
conditionalPanel(
"input.isDynamic == true",
bslib::card(
style = "border: none;",
full_screen = TRUE,
shinyjqui::jqui_resizable(
plotly::plotlyOutput("previewPlotly")
)
)
)
)
) %>% shinyjs::hidden(),
##### 4.1b Table Display ----
div(
id = "main_table_preview", # style = "overflow-x: scroll",
fluidRow(
div(style = "padding-left: 25px; padding-right: 25px;",
uiOutput("previewTable")
)
),
fluidRow(style = "padding-bottom: 1rem;",
column(
width = 6,
div(style = "padding-left: 1rem; padding-right: 1rem;",
h4("Select Columns"),
uiOutput("selectTableCols", style = "width: 100rem; padding-right: 15px;")
)
)
),
uiOutput("selectTableArrangement"),
div(style = "padding-top: 1rem; padding-left: 1rem; padding-right: 1rem;",
fluidRow(
column(width = 4,
h4("Format Columns")
),
column(width = 4,
h4("Caption")
),
column(width = 4,
h4("Footer")
)
),
fluidRow(class = "multi-input-with-checkbox",
column(width = 4,
selectInput(inputId = "tableAlign", label = "Column Alignment", selected = "left", choices = c("left", "right", "center"))
),
column(width = 4, class = "col-checkbox",
checkboxInput(inputId = "isTableCaption", label = "", value = TRUE)
),
column(width = 4, class = "col-checkbox",
checkboxInput(inputId = "isTableFooter", label = "", value = TRUE)
)
),
fluidRow(
column(width = 4,
numericInput(inputId = "tableDigits", label = "Number of Digits", value = 4, min = 0, max = 10, width = "125%")
),
column(width = 4,
uiOutput("selectTableCaption")
),
column(width = 4,
textInput("tableFooter", label = "Footer Text", value = "Source: script.R", width = "125%")
)
)
),
fluidRow(
div(style = "padding-left: 30px; padding-top: 20px;",
actionLink("linkModalTableGlossary", label = "View Table Glossary")
)
)
) %>% shinyjs::hidden(),
br(),
##### 4.1c Plot Options ----
conditionalPanel("input.selectedPlotType != 'none'",
div(id = "plottabs", # class = "ptab",
bslib::navset_card_underline(
###### 4.2 Style Sub-Tab ----
bslib::nav_panel(
title = shiny::HTML(paste0('<i class="fa-solid fa-paint-roller"></i>  Style')),
value = "style",
bslib::card_body(
class = "style-subtab",
####### 4.2a GOF Inputs ----
div(id = "gofStyleInputs",
######## Scatter / Cov-Scatter ----
conditionalPanel("input.selectedPlotType == 'scatter' || input.selectedPlotType == 'covariate_scatter'",
fluidRow(style = "padding-top :10px;",
column(
width = 2,
offset = 1,
checkboxInput(inputId = "displayPoints", label = "Points", value = TRUE),
div(class = "custom_style_point",
selectInput(inputId = "shapePoint", "Point Shape", choices = c("circle-fill", "circle", "square-fill", "square", "triangle-fill", "triangle"), selected = settings$point.shape),
numericInput(inputId = "sizePoint", label = "Point Size", min = 0, max = 10, step = .1, value = settings$point.size),
colourInput("colorPoint", "Point Color", value = settings$point.color),
sliderInput("alphaPoint", "Point Transparency", min = 0, max = 100, value = settings$point.alpha, post = "%", ticks = FALSE)
)
),
column(
width = 2,
checkboxInput(inputId = "displayLines", label = "Lines", value = FALSE),
div(class = "custom_style_lines",
selectInput(inputId = "typeLine", "Line Type", choices = c("blank", "solid", "dashed", "dotted", "dotdash", "longdash", "twodash"), selected = settings$line.type),
numericInput(inputId = "sizeLine", label = "Line Size", min = 0, max = 5, step = .1, value = settings$line.size),
colourInput("colorLine", "Line Color", value = settings$line.color),
sliderInput("alphaLine", "Line Transparency", min = 0, max = 100, value = settings$line.alpha, post = "%", ticks = FALSE)
)
),
column(
width = 2,
checkboxInput(inputId = "displayRefLine", label = "Reference Line", value = TRUE),
div(class = "custom_style_ref_line",
selectInput(inputId = "typeLineGuide", "Reference Line Type", choices = c("blank", "solid", "dashed", "dotted", "dotdash", "longdash", "twodash"), selected = settings$guide.line.type),
numericInput(inputId = "sizeLineGuide", label = "Reference Line Size", min = 0, max = 10, step = .1, value = settings$guide.line.size),
colourInput("colorLineGuide", "Reference Line Color", value = settings$guide.line.color),
sliderInput("alphaLineGuide", "Reference Line Transparency", min = 0, max = 100, value = settings$guide.line.alpha, post = "%", ticks = FALSE)
)
),
column(
width = 2,
checkboxInput(inputId = "displaySmoothing", label = "Smoothing", value = TRUE),
div(class = "custom_style_smoothing_line",
selectInput(inputId = "typeLineSmooth", "Smoothing Line Type", choices = c("blank", "solid", "dashed", "dotted", "dotdash", "longdash", "twodash"), selected = settings$smooth.line.type),
numericInput(inputId = "sizeLineSmooth", label = "Smoothing Line Size", min = 0, max = 10, step = .1, value = settings$smooth.line.size),
colourInput("colorLineSmooth", "Smoothing Line Color", value = settings$smooth.line.color),
numericInput("spanSmooth", "Span", min = 0, max = 1, step = .05, value = 0.75),
uiOutput("spanRangeValidation"),
selectInput(inputId = "smoothingType", label = "Smoothing Method", choices = c("loess", "lm", "glm", "gam"), selected = settings$plot.scatter.smoothing)
#Note: Cannot change alpha line transparency of smoothing line via xpose - we need ggplot2::stat_smooth()
)
),
column(
width = 2,
checkboxInput(inputId = "displayText", label = "Text", value = FALSE),
)
)
),
######## Ind. Plots ----
conditionalPanel("input.selectedPlotType == 'ind_plots'",
fluidRow(style = "padding-bottom: 10px;",
column(
width = 2,
offset = 2,
h5("DV")
),
column(
width = 2,
h5("IPRED")
),
column(
width = 2,
h5("PRED")
),
column(
width = 2,
h5("Legend")
)
),
fluidRow(class = "multi-input-with-checkbox",
column(
width = 2,
offset = 2,
selectInput(inputId = "shapePointDV", "Point Shape", choices = c("circle-fill", "circle", "square-fill", "square", "triangle-fill", "triangle"), selected = settings$indplots.point.shape.DV)
),
column(
width = 2,
selectInput(inputId = "typeLineIPRED", "Line Type", choices = c("blank", "solid", "dashed", "dotted", "dotdash", "longdash", "twodash"), selected = settings$indplots.line.type.IPRED)
),
column(
width = 2,
selectInput(inputId = "typeLinePRED", "Line Type", choices = c("blank", "solid", "dashed", "dotted", "dotdash", "longdash", "twodash"), selected = settings$indplots.line.type.PRED)
),
column(class = "col-checkbox",
width = 2,
checkboxInput(inputId = "displayLegend", label = "Show Legend", value = TRUE)
)
),
fluidRow(
column(
width = 2,
offset = 2,
colourInput("colorPointDV", "Point Color", value = settings$indplots.point.color.DV),
numericInput(inputId = "sizePointDV", "Point Size", min = 0, max = 10, step = .1, value = settings$indplots.point.size.DV),
sliderInput("alphaPointDV", "Point Transparency", min = 0, max = 100, value = settings$indplots.point.alpha.DV, post = "%", ticks = FALSE)
),
column(
width = 2,
colourInput("colorLineIPRED", "Line Color", value = settings$indplots.line.color.IPRED)
),
column(
width = 2,
colourInput("colorLinePRED", "Line Color", value = settings$indplots.line.color.PRED)
),
column(
width = 2,
div(class = "custom_legend",
selectInput(inputId = "legendPosition", "Legend Position", choices = c("bottom", "top", "left", "right"), selected = settings$indplots.legend.position)
)
)
)
),
######## Distr. Plots ----
conditionalPanel("input.selectedPlotType == 'distribution'",
fluidRow(style = "padding-top: 10px;",
column(
width = 2,
offset = 3,
checkboxInput(inputId = "displayHistogram", label = "Histogram", value = TRUE),
div(class = "custom_style_histogram",
numericInput(inputId = "nbinsHistogram", label = "Histogram N Bins", min = 1, max = 100, value = settings$hist.nbins, step = 1),
selectInput(inputId = "typeLineHistogram", label = "Histogram Line Type", choices = c("blank", "solid", "dashed", "dotted", "dotdash", "longdash", "twodash"), selected = settings$hist.line.type),
numericInput(inputId = "sizeHistogram", label = "Histogram Line Size", min = 0, max = 100, value = settings$hist.size, step = 1),
colourInput("colorHistogram", "Histogram Line Color", value = settings$hist.line.color),
colourInput("fillHistogram", "Histogram Fill Color", value = settings$hist.fill.color),
sliderInput("alphaHistogram", "Histogram Transparency", min = 0, max = 100, value = settings$hist.alpha, post = "%", ticks = FALSE)
)
),
column(
width = 2,
checkboxInput(inputId = "displayDensity", label = "Density", value = FALSE),
div(class = "custom_style_density",
selectInput(inputId = "typeLineDensity", label = "Density Line Type", choices = c("blank", "solid", "dashed", "dotted", "dotdash", "longdash", "twodash"), selected = settings$density.line.type),
numericInput(inputId = "sizeDensity", label = "Density Line Size", min = 0, max = 100, value = settings$density.size, step = 1),
colourInput("colorDensity", "Density Line Color", value = settings$density.line.color),
colourInput("fillDensity", "Density Fill Color", value = settings$density.fill.color),
sliderInput("alphaDensity", "Density Transparency", min = 0, max = 100, value = settings$density.alpha, post = "%", ticks = FALSE)
)
),
column(
width = 2,
checkboxInput(inputId = "displayRug", label = "Rug", value = TRUE),
div(class = "custom_style_rug",
selectInput(inputId = "positionRug", label = "Rug Sides", choices = c("bottom", "top", "both"), selected = settings$rug.sides),
numericInput(inputId = "sizeLineRug", label = "Rug Line Size", min = 0, max = 100, value = settings$rug.line.size, step = 1),
colourInput("colorRug", "Rug Color", value = settings$rug.color)
)
)
)
),
######## Cov. Box Plot ----
conditionalPanel("input.selectedPlotType == 'covariate_box'",
fluidRow(style = "display: flex; padding-top: 10px;",
column(
width = 3,
offset = 2,
colourInput("colorBoxPlot", "Box Plot Line Color", value = settings$boxplot.line.color),
colourInput("fillBoxPlot", "Box Plot Fill Color", value = settings$boxplot.fill.color),
sliderInput("alphaBoxPlot", "Box Plot Transparency", min = 0, max = 100, value = settings$boxplot.alpha, post = "%", ticks = FALSE)
),
column(
style = "padding-top: 2rem;",
width = 2,
checkboxInput(inputId = "displayOutliers", "Display Outliers", value = TRUE)
),
column(
width = 3,
div(class = "custom_style_outliers",
selectInput(inputId = "shapeOutlier", label = "Outlier Shape", choices = c("circle-fill", "circle", "square-fill", "square", "triangle-fill", "triangle"), selected = settings$outlier.shape),
numericInput(inputId = "sizeOutlier", label = "Outlier Size", min = 0, max = 100, value = 1, step = settings$outlier.size),
sliderInput("alphaOutlier", "Outlier Transparency", min = 0, max = 100, value = settings$outlier.alpha, post = "%", ticks = FALSE),
colourInput("colorOutlier", "Outlier Color", value = settings$outlier.color)
)
)
)
)
) %>% shinyjs::hidden(),
####### 4.2b Darwin Style Inputs ----
div(id = "darwinStyleInputs", style = "padding-left: 3rem;",
fluidRow(
column(
width = 2,
offset = 2,
selectInput(inputId = "legendPositionDarwin", label = "Legend Position", choices = c("top", "bottom", "left", "right"), selected = settings$darwinplots.legend.position),
selectInput(inputId = "legendDirectionDarwin", label = "Legend Direction", choices = c("vertical", "horizontal"), selected = settings$darwinplots.legend.direction),
),
######## Fitness ----
column(id = "darwinStyleFitnessInputs",
width = 6,
fluidRow(class = "multi-input-with-checkbox",
column(
width = 4,
selectInput(inputId = "typeLineMean", "Line Type (Mean)", choices = c("blank", "solid", "dashed", "dotted", "dotdash", "longdash", "twodash"), selected = settings$darwinplots.line.type.mean)
),
column(
width = 4,
selectInput(inputId = "typeLineMin", label = "Line Type (Min)", choices = c("blank", "solid", "dashed", "dotted", "dotdash", "longdash", "twodash"), selected = settings$darwinplots.line.type.min)
),
column(class = "col-checkbox",
width = 4,
checkboxInput(inputId = "annotateBestFitness", label = "Annotate Best Fitness", value = TRUE)
)
),
fluidRow(
column(
width = 4,
colourInput("colorLineMean", "Line Color (Mean)", value = settings$darwinplots.line.color.mean)
),
column(
width = 4,
colourInput("colorLineMin", "Line Color (Min)", value = settings$darwinplots.line.color.min)
),
column(
width = 4,
conditionalPanel("input.annotateBestFitness == true",
sliderInput("sizeAnnotate", "Annotation Size", min = 0, max = 10, value = 5, step = 0.25, ticks = FALSE)
)
)
),
fluidRow(
column(
width = 4,
sliderInput("widthLineMean", "Line Width (Mean)", min = 0, max = 5, value = settings$darwinplots.line.width.mean, ticks = FALSE, step = 0.1)
),
column(
width = 4,
sliderInput("widthLineMin", "Line Width (Min)", min = 0, max = 5, value = settings$darwinplots.line.width.min, ticks = FALSE, step = 0.1)
)
)
) %>% shinyjs::hidden(),
# material_column(width = 2,
# material_dropdown("legendPositionDarwin", "Legend Position", choices = c("top", "bottom", "left", "right"), selected = settings$darwinplots.legend.position),
# div(style = "padding:5px;"),
# material_dropdown("legendDirectionDarwin", "Legend Direction", choices = c("vertical", "horizontal"), selected = settings$darwinplots.legend.direction),
# ),
# material_column(width = 3,
# material_checkbox("annotateBestFitness", label = "Annotate Best Fitness", initial_value = TRUE)
# )
#
# )
#)#,
######## Penalty ----
column(id = "darwinStylePenaltyInputs", # style = "padding-left: 3rem;",
width = 4,
fluidRow(
column(
width = 6,
checkboxInput(inputId = "scaleOFV", label = "Scale OFV", value = TRUE)
),
column(
width = 6,
checkboxInput(inputId = "groupPenalties", label = "Group Penalties", value = FALSE)
)
)
) %>% shinyjs::hidden()
)
) %>% shinyjs::hidden()
)
),
###### 4.3 Layout Sub-Tab ----
bslib::nav_panel(# "tab_layout",
title = shiny::HTML(paste0('<i class="fa-solid fa-table-cells"></i>  Layout')),
bslib::card_body(
class = "layout-subtab",
min_height = "220px",
div(id = "gofLayoutInputs",
fluidRow(class = "multi-input-with-checkbox",
column(
width = 2,
selectInput(inputId = "selectedFacet", label = "Select Facet", choices = c("none"))
),
column(
width = 2,
selectInput(inputId = "selectedAxisScale", label = "Axis Scale", choices = c("free", "fixed"), selected = settings$axis.scale)
),
column(class = "col-checkbox",
width = 2,
checkboxInput(inputId = "isLogX", label = "x-axis log", value = FALSE)
),
column(class = "col-checkbox",
width = 2,
checkboxInput(inputId = "isLogY", label = "y-axis log", value = FALSE)
),
column(class = "col-checkbox",
width = 2,
checkboxInput(inputId = "isDefaultArrangement", label = "Default Arrangement", value = TRUE)
),
column(class = "col-checkbox",
width = 2,
checkboxInput(inputId = "isExtraHlines", label = "Additional Ref Lines", value = FALSE),
)
),
fluidRow(
column(class = "custom_facet_arrangement",
width = 2, offset = 8,
numericInput(inputId = "arrangeRowNum", label = "Number of Rows", value = settings$arrange.nrow, min = 1, max = 100),
numericInput(inputId = "arrangeColNum", label = "Number of Columns", value = settings$arrange.ncol, min = 1, max = 100),
numericInput(inputId = "selectedPage",label = "Page Number", min = 1, max = 100, step = 1, value = 1)
),
column(class = "custom_hlines",
style = "margin-left: auto;",
width = 2,
numericInput(inputId = "hLine1", label = "Line 1: Y = ", value = settings$guide.line.extra.y1, min = NA, max = NA),
numericInput(inputId = "hLine2", label = "Line 2: Y =", value = settings$guide.line.extra.y2, min = NA, max = NA)
)
)
)
)
),
###### 4.4 Display Sub-Tab ----
bslib::nav_panel(
title = shiny::HTML(paste0('<i class="fa-solid fa-eye-slash"></i>  Display')),
bslib::card_body(
class = "display-subtab",
div(style = "padding: 0.3rem"),
fluidRow(class = "multi-input-with-checkbox",
column(class = "col-checkbox",
width = 2,
offset = 1,
checkboxInput(inputId = "isDefaultText", label = "Default Text", value = TRUE)
),
column(class = "col-checkbox",
width = 2,
checkboxInput(inputId = "isCertaraTheme", label = "Certara Theme", value = settings$certara.theme)
),
column(class = "col-checkbox",
width = 2,
div(class = "custom_plot_theme_inputs",
checkboxInput(inputId = "isShowBorder", label = "Border", value = settings$background.border)
)
),
column(class = "col-checkbox",
width = 2,
div(class = "custom_plot_theme_inputs",
checkboxInput(inputId = "isShowGridLines", label = "Grid Lines", value = settings$background.gridlines)
)
),
column(
width = 2,
div(class = "custom_plot_theme_inputs",
colourInput("colorBackground", "Plot Background Color", value = settings$background.color)
)
)
),
fluidRow(
column(
width = 2,
offset = 1,
div(class = "custom_text_inputs",
div(id = "darwinTextInputs",
textInput(inputId = "textDarwinTitle", label = "Title", value = ""),
textInput(inputId = "textDarwinSubtitle", label = "Subtitle", value = ""),
textInput(inputId = "textDarwinCaption", label = "Caption", value = ""),
textInput(inputId = "xlabDarwin", label = "x-Label", value = ""),
textInput(inputId = "ylabDarwin", label = "y-Label", value = "")
) %>% shinyjs::hidden(),
div(id = "xposeTextInputs",
textInput(inputId = "textTitle", label = "Title", value = "@y vs. @x | @run"),
textInput(inputId = "textSubtitle", label = "Subtitle", value = "-2LL: @ofv"),
textInput(inputId = "textCaption", label = "Caption", value = "@dir"),
textInput(inputId = "xlab", label = "x-Label", value = "@x"),
textInput(inputId = "ylab", label = "y-Label", value = "@y"),
actionLink("linkModalTags", label = "View Plot Tags")
) %>% shinyjs::hidden()
)
),
column(class = "custom_plot_theme_inputs",
width = 2,
numericInput(inputId = "sizeTitle", label = "Title Size", min = 1, max = 30, value = settings$title.size, step = 1),
selectInput(inputId = "fontTitle", label = "Title Font", choices = c("Times New Roman", "Arial", "Courier New"), selected = settings$title.font),
colourInput("colorTitle", "Title Font Color", value = settings$title.color),
selectInput(inputId = "faceTitle", label = "Title Face", choices = c("plain", "bold", "italic", "bold.italic"), selected = settings$title.face),
),
column(class = "custom_plot_theme_inputs",
width = 2,
numericInput(inputId = "sizeSubtitle", label = "Subtitle Size", min = 1, max = 30, value = settings$subtitle.size, step = 1),
selectInput(inputId = "fontSubtitle", label = "Subtitle Font", choices = c("Times New Roman", "Arial", "Courier New"), selected = settings$subtitle.font),
colourInput("colorSubtitle", "Subtitle Font Color", value = settings$subtitle.color),
selectInput(inputId = "faceSubtitle", label = "Subtitle Face", choices = c("plain", "bold", "italic", "bold.italic"), selected = settings$subtitle.face)
),
column(class = "custom_plot_theme_inputs",
width = 2,
numericInput(inputId = "sizeCaption", label = "Caption Size", min = 1, max = 30, value = settings$caption.size, step = 1),
selectInput(inputId = "fontCaption", label = "Caption Font", choices = c("Times New Roman", "Arial", "Courier New"), selected = settings$caption.font),
colourInput("colorCaption", label = "Caption Font Color", value = settings$caption.color),
selectInput(inputId = "faceCaption", label = "Caption Face", choices = c("plain", "bold", "italic", "bold.italic"), selected = settings$caption.face)
),
column(class = "custom_plot_theme_inputs",
width = 2,
numericInput(inputId = "sizeAxis", label = "Axis Label Size", min = 1, max = 30, value = settings$axis.size, step = settings$axis.size),
selectInput(inputId = "fontAxis", label = "Axis Label Font", choices = c("Times New Roman", "Arial", "Courier New"), selected = settings$axis.font),
colourInput("colorAxis", label = "Axis Label Font Color", value = settings$axis.color),
selectInput(inputId = "faceAxis", label = "Axis Label Face", choices = c("plain", "bold", "italic", "bold.italic"), selected = settings$axis.face)
)
)
)
)
)
),
##### 4.5 Tag Button ----
fluidRow(
column(
width = 12,
conditionalPanel("input.selectedPlotType != 'none'",
actionButton(inputId = "open_savePlotModal", label = NULL, icon = icon("tag"))
)
)
)
)
)
),
#### 4.6 Tagged Tab ----
bslib:: nav_panel(
title = "Tagged",
bslib::card_body(
uiOutput("myTaggedDiagnostics"),
div(
id = "my_tagged_plots_out",
style = "padding-left: 25px; padding-right: 25px; padding-bottom: 15px;",
bslib::card(
style = "border: none;",
full_screen = TRUE,
plotOutput("myTaggedPlots")
)
),
div(id = "my_tagged_tables_out",
style = "padding-left: 25px; padding-right: 25px; padding-bottom: 15px;",
uiOutput("myTaggedTables")
),
shinyAce::aceEditor(
outputId = "md_code",
autoScrollEditorIntoView = TRUE,
minLines = 5,
maxLines = 35,
value = NULL,
readOnly = TRUE
)
)
),
#### 4.7 Report Tab ----
bslib::nav_panel(
title = "Report",
value = "tab_report",
bslib::card_body(
fluidRow(style = "padding-left:25px; padding-right:25px;",
column(
width = 12,
fluidRow(
column(width = 4,
textInput("reportName", "Report Title:", value = paste0("Report_", format(Sys.time(), "%Y-%m-%d_%H:%M:%S")), width = '125%')
),
column(
width = 2,
selectInput(inputId = "fileType", label = "File Type", choices = c("html", "pdf", "docx"))
),
column(id = "pdf_layout",
width = 2,
selectInput(inputId = "pageLayout", label = "Page Layout", choices = c("Portrait", "Landscape"))
) %>% shinyjs::hidden(),
column(
width = 2, style = "padding-left: 10px; padding-right: 10px;",
div(style = "padding-top: 2rem;",
checkboxInput(inputId = "isAutoFormat", label = "Auto Format", value = TRUE)
)
),
column(
width = 2,
div(style = "padding-top: 2rem;",
checkboxInput(inputId = "includeAppendix", label = "Appendix", value = TRUE)
)
)
),
fluidRow(id = "pdf_options",
column(
width = 2,
numericInput(inputId = "marginLeft", label = "Margin Left (unit: cm)", min = 1, max = 10, value = 3, step = 1)
),
column(
width = 2,
numericInput(inputId = "marginRight", label = "Margin Right (unit: cm)", min = 1, max = 10, value = 3, step = 1)
),
column(
width = 2,
numericInput(inputId = "marginTop", label = "Margin Top (unit: cm)", min = 1, max = 10, value = 2, step = 1)
),
column(
width = 2,
numericInput(inputId = "marginBottom", label = "Margin Bottom (unit: cm)", min = 1, max = 10, value = 2, step = 1)
)
) %>% shinyjs::hidden()
)
),
div(id = "customReportDraggable",
uiOutput("selectReport")
) %>% shinyjs::hidden(),
fluidRow(
column(
width = 10, offset = 2,
uiOutput("report_download_buttons")
)
)
)
)
)
)
)
),
# 5.0 Footer ----
certara_footer(url = 'https://certara.github.io/R-DarwinReporter/')
)
runApp(
shinyApp(ui = ui, server = server),
launch.browser = TRUE
)
}
Try the Certara.DarwinReporter package in your browser
Any scripts or data that you put into this service are public.
Certara.DarwinReporter documentation built on April 4, 2025, 2:22 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions .run_shinyResults update_tagged darwinReportUI
Documented in darwinReportUI
#' Generate and Report Model Diagnostics from NLME or NONMEM runs
#'
#' Shiny application to generate, customize, and report diagnostic plots and tables from NLME or
#' NONMEM output files. Create an Rmarkdown file of tagged model diagnostics and render into
#' submission ready report.
#'
#'
#' @param darwin_data Object of class \code{darwin_data}. Note, key_models xpose_data must be available.
#' @param tagged List of tagged objects returned from previous \code{tagged <- darwinReportUI()} session.
#' @param settings List of settings (e.g., settings.Rds) returned from previous Shiny session.
#' @param ... Additional arguments for Pirana integration.
#'
#'
#' @examples
#' if (interactive()) {
#' ddb <- darwin_data("./darwin_search_09") |>
#' import_key_models("./darwin_search_09/key_models")
#'
#' darwinReportUI(ddb)
#' }
#'
#' @return If \code{interactive()}, returns a list of tagged diagnostics from the Shiny application, otherwise returns \code{TRUE}.
#' @export
#'
darwinReportUI <- function(darwin_data, tagged = NULL, settings = NULL, ...) {
stopifnot(inherits(darwin_data, "darwin_data"))
arg_list <- list(...)
pirana <-
!is.null(arg_list$pirana) && isTRUE(arg_list$pirana)
if (pirana) {
pirana_dir <- dirname(darwin_data$project_dir)
} else {
pirana_dir <- NULL
}
model_name <- NULL
darwin_data_name <- deparse(substitute(darwin_data))
xpdb_name <- paste0(deparse(substitute(darwin_data)), "$key_models$xpose_data")
stopifnot(any(lapply(darwin_data[["key_models"]][["xpose_data"]], function(x)
is.xpdb(x)) == TRUE))
software <-
unique(unlist(lapply(darwin_data[["key_models"]][["xpose_data"]], function(x)
x$summary[x$summary$label == "software", "value"][[1]])))
if (length(software) > 1) {
stop(
"xpdb elements in list provided to `xpdb` arg x must be either 'nonmem' or 'nlme', but cannot be a combination of both."
)
}
if (!(software %in% c("nonmem", "phx/nlme"))) {
stop("software must be one of 'nonmem' or 'phx/nlme', please check xbdb$summary")
}
init_arg_type <- "xpdb_multiple"
hasResetInfo <- TRUE
if(software == "nonmem"){
software <- "NONMEM"
} else {
software <- "NLME"
}
if (is.null(settings) || settings == "") {
settings <- initialize_settings
} else {
if (is.character(settings)) {
stopifnot(file.exists(settings))
settings <- readRDS(settings)
}
settings <- modifyList(initialize_settings, settings)
}
tagged_diagnostics <- .run_shinyResults(darwin_data = darwin_data, tagged = tagged, software = software,
model_name = model_name, xpdb_name = xpdb_name, darwin_data_name = darwin_data_name,
init_arg_type = init_arg_type, hasResetInfo = hasResetInfo,
settings = settings, pirana = pirana, pirana_dir = pirana_dir)
if (interactive()) {
return(invisible(tagged_diagnostics))
} else {
return(TRUE)
}
}
update_tagged <- function(object, xpdb, obj, type, code, run, name){
if (name %in% c("Fitness vs Iteration", "Penalties vs Iteration", "Key Models")) {
xpdb <- NA
run <- NA
code <- sub("xpobj .*\\]\\n", "", code) #remove xpobj assignment
}
object$xpdb <- xpdb
object$obj <- obj
object$type <- type
object$code <- code
object$run <- run
object$name <- name
return(object)
}
#' @rawNamespace import(shiny, except = c(runExample, dataTableOutput, renderDataTable))
#' @rawNamespace import(dplyr, except = c(between, first, last))
#' @import ggplot2
#' @import flextable
#' @import shinyTree
#' @importFrom tidyr separate pivot_wider
#' @importFrom plotly renderPlotly plotlyOutput ggplotly
#' @import sortable
#' @rawNamespace import(colourpicker, except = c(runExample))
#' @import shinymeta
#' @import Certara.Xpose.NLME
#' @import xpose
#' @rawNamespace import(shinyjs, except = c(colourInput, updateColourInput, colourPicker))
#' @importFrom scales trans_breaks trans_format
#' @importFrom shinyWidgets chooseSliderSkin setSliderColor addSpinner
#' @import bslib
#'
.run_shinyResults <- function(darwin_data, tagged = NULL, software = NULL, model_name = NULL, xpdb_name = NULL, darwin_data_name = NULL, init_arg_type = NULL, hasResetInfo = FALSE, settings = NULL, pirana = FALSE, pirana_dir = NULL) {
xpdb <- darwin_data[["key_models"]][["xpose_data"]]
# Setup tree
if(software == "NLME"){
resultsTreeList <- resultsTreeListNLME
} else {
resultsTreeList <- resultsTreeListNONMEM
}
plot_desc_location <- system.file("extdata","plot_desc.csv",package="Certara.DarwinReporter")
plot_desc <- read.csv(plot_desc_location)
fitness_penalties_key_models_df <-
summarise_fitness_penalties_by_key_models(darwin_data)
fitness_penalties_key_models_df$model_file <-
sprintf('<button id="btn_%s" class="action-button"><i class="fas fa-file"></i></button>',
fitness_penalties_key_models_df$model_iteration)
fitness_penalties_key_models_df$plot <-
sprintf('<button id="btn_plot_%s" class="action-button"><i class="fas fa-chart-line"></i></button>',
fitness_penalties_key_models_df$model_iteration)
fitness_penalties_key_models_df <- fitness_penalties_key_models_df %>%
dplyr::relocate(model_file, plot, .before = iteration) %>%
dplyr::select(-run_dir, -iteration) %>%
dplyr::rename(model_name = model_iteration)
server <- function(input, output, session) {
output$runInfoCards <- renderUI({
search_overview_cards(darwin_data$search_overview)
})
output$fitnessVsIteration <- plotly::renderPlotly({
fitness_vs_iteration(darwin_data) %>%
plotly::ggplotly()
})
output$fitnessPenaltiesVsIteration <- plotly::renderPlotly({
fitness_penalties_vs_iteration(darwin_data, group_penalties = FALSE, scale_ofv = TRUE) %>%
plotly::ggplotly()
})
output$fitnessSummaryTable <- DT::renderDT({
DT::datatable(fitness_penalties_key_models_df, escape = FALSE,
selection = list(mode = 'single'),
options = list(
preDrawCallback = DT::JS("function() { Shiny.unbindAll(this.api().table().node()); }"),
drawCallback = DT::JS(
"function() { Shiny.bindAll(this.api().table().node()); }"
),
scroll_x = TRUE,
dom = "t",
pageLength = 100,
select = list(style = 'single')
)
)
})
key_models <- names(darwin_data$key_models$code)
observe({
lapply(key_models, function(x) {
#Open Control File Modal
observeEvent(input[[paste0("btn_", x)]], {
code <- darwin_data$key_models$code[[x]]
showModal(
modalDialog(
title = NULL,
shinyAce::aceEditor(
outputId = "key_model_code",
minLines = 5,
maxLines = 200,
value = NULL,
readOnly = TRUE,
height = "1000px",
autoScrollEditorIntoView = TRUE
),
easyClose = TRUE,
footer = NULL
)
)
shinyAce::updateAceEditor(
session,
"key_model_code",
mode = "text",
tabSize = 4,
useSoftTabs = FALSE,
showInvisibles = FALSE,
showLineNumbers = TRUE,
value = paste0(c(code, ""), collapse = "\n")
)
})
# Redirect to Diagnostics Plots/Tables for Key Model
observeEvent(input[[paste0("btn_plot_", x)]], {
session$sendCustomMessage(type = "shinymaterialJS", js$select_sidenav_tab("side_nav_tab_diagnostics"))
updateSelectInput(session = session, inputId = "selectedModel", selected = x)
if (length(reactiveSelections$value$tree) == 0) {
showModal(
modalDialog(
title = "Welcome",
p("Select a model diagnostic from the available options on the left."),
easyClose = TRUE,
footer = NULL
)
)
Sys.sleep(3)
}
#shinyTree::updateTree(session, "treeModelDiagnostics", data = list(`DV vs PRED` = "DV vs PRED"))
})
})
})
observeEvent(input$backToSearchOverview, {
session$sendCustomMessage(type = "shinymaterialJS", js$select_sidenav_tab("side_nav_tab_search_overview"))
})
# Create reactive selections ----
reactiveSelections <- reactiveValues(value = list(tree = NULL,
col_names = "",
cat_cov = "",
cont_cov = "",
covariates = "",
selected_cov = "",
selected_facet = "",
selected_page = 1,
type = ""))
observe({
req(xpdbSelected())
if (!is.null(xpdbSelected()$data)) {
reactiveSelections$value$col_names <-
xpdbSelected()$data$index[[1]]$col
reactiveSelections$value$cat_cov <-
Certara.Xpose.NLME:::.get_cat_cov(xpdbSelected()$data$index[[1]])
reactiveSelections$value$cont_cov <-
Certara.Xpose.NLME:::.get_cont_cov(xpdbSelected()$data$index[[1]])
reactiveSelections$value$covariates <-
c(reactiveSelections$value$cat_cov,
reactiveSelections$value$cont_cov)
reactiveSelections$value$selected_cov <-
ifelse(is.null(input$selectedCovariate),
"",
input$selectedCovariate)
reactiveSelections$value$selected_facet <- input$selectedFacet
reactiveSelections$value$selected_page <- input$selectedPage
reactiveSelections$value$has_eta <- has_type(xpdbSelected()$data$index[[1]], type = "eta")
reactiveSelections$value$has_param <- has_type(xpdbSelected()$data$index[[1]], type = "param")
}
}, suspended = FALSE, priority = 3)
# Disabling UI Inputs ----
observe({
toggleVisibility(selector = '.custom_plot_theme_inputs', condition = !input$isCertaraTheme)
toggleVisibility(selector = '.custom_text_inputs', condition = !input$isDefaultText)
toggleVisibility(selector = '.custom_facet_arrangement', condition = !input$isDefaultArrangement)
toggleVisibility(selector = '.custom_style_point', condition = input$displayPoints)
toggleVisibility(selector = '.custom_style_lines', condition = input$displayLines)
toggleVisibility(selector = '.custom_style_ref_line', condition = input$displayRefLine)
toggleVisibility(selector = '.custom_style_smoothing_line', condition = input$displaySmoothing)
toggleVisibility(selector = '.custom_style_histogram', condition = input$displayHistogram)
toggleVisibility(selector = '.custom_style_density', condition = input$displayDensity)
toggleVisibility(selector = '.custom_style_rug', condition = input$displayRug)
toggleVisibility(selector = '.custom_style_outliers', condition = input$displayOutliers)
toggleVisibility(selector = '.custom_hlines', condition = input$isExtraHlines)
toggleVisibility(selector = '.custom_legend', condition = input$displayLegend)
})
if(pirana){
shinyjs::hide("generateReport")
shinyjs::show("generateReportPirana")
}
# Span validation ----
observeEvent(input$smoothingType,{
if(input$smoothingType == "loess"){
shinyjs::enable("spanSmooth")
} else {
shinyjs::disable("spanSmooth")
}
})
spanValidation <- reactive({
validate(
need(input$spanSmooth <= 1 && input$spanSmooth > 0, "Error: Span value must be between 0-1")
)
})
output$spanRangeValidation <- renderPrint({
spanValidation()
})
# Updating inputs based on tree defaults
observe({
tree <- reactiveSelections$value$tree
if(length(tree) == 0) return()
if(tree %in% qq_trees){
updateCheckboxInput(session = session, inputId = "displayLines", value = FALSE)
updateCheckboxInput(session = session, inputId = "displaySmoothing", value = FALSE)
updateCheckboxInput(session = session, inputId = "displayText", value = FALSE)
disable("displayLines")
disable("displaySmoothing")
disable("displayText")
} else {
enable("displayLines")
enable("displaySmoothing")
if(tree %in% covariate_trees){
updateCheckboxInput(session = session, inputId = "displayText", value = FALSE)
disable("displayText")
} else {
enable("displayText")
}
}
})
# Update plot type
checkPlotTypes <- reactive({
list(input$treeModelDiagnostics,
input$selectedCovariate)
})
observeEvent(checkPlotTypes(), {
tree <- shinyTree::get_selected(input$treeModelDiagnostics)
reactiveSelections$value$tree <- tree
if(length(tree) == 0){
return()
} else if(tree %in% distribution_trees){
updateSelectInput(session = session, inputId = "selectedPlotType", selected = "distribution")
updateCheckboxInput(session = session, inputId = "isDefaultArrangement", value = TRUE)
} else if(tree %in% c("Individual Plots (IVAR)", "Individual Plots (TAD)")){
updateSelectInput(session = session, inputId = "selectedPlotType", selected = "ind_plots")
updateCheckboxInput(session = session, inputId = "isDefaultArrangement", value = FALSE)
} else if(tree %in% covariate_trees){
if(length(reactiveSelections$value$covariates) == 0){
return()
} else if(reactiveSelections$value$selected_cov %in% reactiveSelections$value$cat_cov ){
updateSelectInput(session = session, inputId = "selectedPlotType", selected = "covariate_box")
} else {
updateSelectInput(session = session, inputId = "selectedPlotType", selected = "covariate_scatter")
}
updateCheckboxInput(session = session, inputId = "isDefaultArrangement", value = TRUE)
} else if (!tree %in% branches_trees) {
updateSelectInput(session = session, inputId = "selectedPlotType", selected = "scatter")
updateCheckboxInput(session = session, inputId = "isDefaultArrangement", value = TRUE)
}
updateNumericInput(session = session, inputId = "selectedPage", value = 1)
}, suspended = FALSE, priority = 2)
# Observe Tree Input ----
observeEvent(input$treeModelDiagnostics,{
if(length(reactiveSelections$value$tree) == 0) {
shinyjs::hide("main_plot_preview")
shinyjs::hide("plottabs")
shinyjs::hide("main_table_preview")
return()
}
if(reactiveSelections$value$tree %in% branches_trees) {
return()
}
session$sendCustomMessage("switchTab", "tab_preview")
if (reactiveSelections$value$tree %in% c(darwin_trees, "Darwin Search")) {
shinyjs::hide("darwin_key_models_selection")
} else {
shinyjs::show("darwin_key_models_selection")
}
if(reactiveSelections$value$tree %in% table_trees){
shinyjs::hide("plotly_switch")
shinyjs::hide("main_plot_preview")
shinyjs::hide("plottabs")
shinyjs::show("main_table_preview")
} else {
shinyjs::show("plotly_switch")
shinyjs::hide("main_table_preview")
shinyjs::show("main_plot_preview")
shinyjs::show("plottabs")
if (reactiveSelections$value$tree %in% darwin_trees) {
shinyjs::hideElement(selector = "li.tab a[href$=\"#tab_layout\"]", asis = FALSE)
shinyjs::hide("gofStyleInputs")
shinyjs::hide("gofLayoutInputs")
shinyjs::show("darwinStyleInputs")
if (reactiveSelections$value$tree == "Fitness vs Iteration") {
shinyjs::hide("darwinStylePenaltyInputs")
shinyjs::show("darwinStyleFitnessInputs")
shinyjs::hide("xposeTextInputs")
shinyjs::show("darwinTextInputs")
}
if (reactiveSelections$value$tree == "Penalties vs Iteration") {
shinyjs::hide("darwinStyleFitnessInputs")
shinyjs::show("darwinStylePenaltyInputs")
shinyjs::hide("xposeTextInputs")
shinyjs::show("darwinTextInputs")
}
} else {
shinyjs::showElement(selector = "li.tab a[href$=\"#tab_layout\"]", asis = FALSE)
shinyjs::show("gofLayoutInputs")
shinyjs::show("gofStyleInputs")
shinyjs::hide("darwinStyleInputs")
shinyjs::hide("darwinTextInputs")
shinyjs::show("xposeTextInputs")
}
}
if(reactiveSelections$value$tree %in% no_refline_trees){
updateCheckboxInput(session = session, inputId = "displayRefLine", value = FALSE)
shinyjs::disable("displayRefLine")
} else {
shinyjs::enable("displayRefLine")
updateCheckboxInput(session = session, inputId = "displayRefLine", value = TRUE)
}
shinyjs::reset("spanSmooth")
updateCheckboxInput(session = session, inputId = "displaySmoothing", value = TRUE)
updateCheckboxInput(session = session, inputId = "isExtraHlines", value = FALSE)
updateCheckboxInput(session = session, inputId = "isLogX", value = FALSE)
updateCheckboxInput(session = session, inputId = "isLogY", value = FALSE)
updateSelectInput(session = session, inputId = "selectedFacet", selected = "none", choices = c("none", xpdbSelected()$data$index[[1]]$col))
reactiveTblCols$order <- NULL
}, priority = 1)
observeEvent(input$selectedModel,{
updateSelectInput(session = session, inputId = "selectedFacet", selected = "none", choices = c("none", xpdbSelected()$data$index[[1]]$col))
})
# UI: Covariate Selection ----
output$covSelection <- renderUI({ #try rendering in UI, then update selections
if(length(reactiveSelections$value$covariates) == 0) return()
tagList(
selectInput(inputId = "selectedCovariate", label = "Select Covariate", choices = reactiveSelections$value$covariates, selected = reactiveSelections$value$selected_cov)
)
})
# UI: Save Plot Name ----
output$userPlotName <- renderUI({
# req(input$treeModelDiagnostics)
if (length(reactiveSelections$value$tree) > 0 &&
reactiveSelections$value$tree %in% darwin_trees) {
plot_name <- reactiveSelections$value$tree
} else if (length(reactiveSelections$value$tree) > 0 &&
reactiveSelections$value$tree %in% covariate_trees) {
plot_name <-
paste(input$selectedModel, reactiveSelections$value$tree, input$selectedCovariate, sep = " - ")
} else {
plot_name <-
paste(input$selectedModel, reactiveSelections$value$tree, sep = " - ")
}
textInput("plotName", label = "Name", value = plot_name)
})
outputOptions(output, "userPlotName", suspendWhenHidden = FALSE)
# UI: Plot Page ----
# UI: Plot Name and Description ----
output$selectedPlotName <- renderText(
plot_desc[plot_desc$name == reactiveSelections$value$tree,][[1]]
)
output$selectedPlotDesc <- renderText(
plot_desc[plot_desc$name == reactiveSelections$value$tree,][[2]]
)
# View Xpose Modal
observeEvent(input$linkModalTags,{
showModal(
modalDialog(
size = "m",
easyClose = TRUE,
title = "xpose Tags",
div(style='height:500px; overflow-y: scroll', #Add vertical scroll bar to tree
shiny::tags$p(
tableOutput('tableXposeTags')
)
),
h5("See ?xpose::template_titles"),
footer = NULL
)
)
})
output$tableXposeTags <- renderTable({
templates_titles_df
})
# View Table Glossary Modal
observeEvent(input$linkModalTableGlossary,{
showModal(
modalDialog(
size = "m",
easyClose = TRUE,
title = "Table Glossary",
div(
style='height:500px;',
shiny::tags$p(
tableOutput('tableTableGlossary')
)
),
footer = NULL
)
)
})
output$tableTableGlossary <- renderTable({
table_glossary_df
})
reactiveModelName <- reactiveValues(name = "")
observeEvent(input$selectedModel,{
reactiveModelName$name <- input$selectedModel
})
xpdbSelected <- metaReactive2(varname = "xpobj",{
xpdbUser <- metaExpr({
xpdb[[..(input$selectedModel)]]
})
xpdbUser
})
# Preview Plot ----
mainPlotWrapper <- reactive({
mainPlotResult <- mainPlot() # Assume mainPlot is your metaReactive2 expression
if (is.null(mainPlotResult)) {
return(lastValidPlot())
} else {
lastValidPlot(mainPlotResult)
return(mainPlotResult)
}
})
lastValidPlot <- reactiveVal()
mainPlot <- metaReactive2(varname = "plot",{
req(xpdbSelected(), input$treeModelDiagnostics)
treeSelected <- reactiveSelections$value$tree
if(length(treeSelected) == 0){
treeSelected <- ""
}
if (treeSelected %in% branches_trees) {
return()
}
userPlot <- get_diagnostic(xpdb = xpdbSelected(),
treeSelected = treeSelected,
software = software,
input = input,
isCertaraTheme = input$isCertaraTheme,
isDefaultText = input$isDefaultText,
isDefaultArrangement = input$isDefaultArrangement,
isExtraHlines = input$isExtraHlines,
isShowLegend = input$displayLegend,
selectedCovariate = input$selectedCovariate,
selectedFacet = input$selectedFacet,
cols = reactiveSelections$value$col_names,
covCols = reactiveSelections$value$covariates,
catCov = reactiveSelections$value$cat_cov,
contCov = reactiveSelections$value$cont_cov,
covTrees = covariate_trees,
pageNumber = reactiveSelections$value$selected_page,
hasResetInfo = hasResetInfo,
darwin_data = darwin_data,
hasEta = reactiveSelections$value$has_eta,
hasParam = reactiveSelections$value$has_param)
lastValidPlot(userPlot)
userPlot
})
output$previewPlotly <- plotly::renderPlotly({
req(mainPlotWrapper(), input$treeModelDiagnostics)
treeSelected <- reactiveSelections$value$tree
if(input$isDynamic == FALSE) return(NULL)
if(length(treeSelected) == 0) return(NULL)
if(treeSelected %in% table_trees) return(NULL)
mainPlotWrapper() %>%
plotly::ggplotly()
})
output$previewPlot <- renderPlot({
req(mainPlotWrapper(), input$treeModelDiagnostics)
treeSelected <- reactiveSelections$value$tree
if(input$isDynamic == TRUE) return(NULL)
if(length(treeSelected) == 0) return(NULL)
if(treeSelected %in% table_trees) return(NULL)
mainPlotWrapper()
})
# Preview Table ----
output$selectTableCols <- renderUI({
req(input$treeModelDiagnostics)
treeSelected <- reactiveSelections$value$tree
if(length(treeSelected) == 0) return(NULL)
if(!(treeSelected %in% table_trees)) return(NULL)
if(software == "NONMEM"){
if(treeSelected == "Key Models"){
cols <- colsOverallDarwinNONMEM[!colsOverallDarwinNONMEM %in% "run_dir"]
penalty_cols <- colnames(fitness_penalties_key_models_df)[grepl("penalty", colnames(fitness_penalties_key_models_df))]
penalty_indices <- grep("^penalty_", cols)
# Extract those elements
penalty_elements <- cols[penalty_indices]
# Check which elements exist in 'penalty_cols'
valid_penalty_elements <- penalty_elements %in% penalty_cols
# Remove invalid elements from 'cols'
cols <- cols[-penalty_indices[!valid_penalty_elements]]
} else if(treeSelected == "Overall"){
cols <- colsOverallNONMEM
} else if (treeSelected %in% c("Theta", "Secondary")){
cols <- colsPrmNONMEM[-c(8,10,11, 12)]
} else {
cols <- colsPrmNONMEM
}
} else {
if(treeSelected == "Key Models"){
cols <- colsOverallDarwinNLME[!colsOverallDarwinNLME %in% "run_dir"]
penalty_cols <- colnames(fitness_penalties_key_models_df)[grepl("penalty", colnames(fitness_penalties_key_models_df))]
penalty_indices <- grep("^penalty_", cols)
# Extract those elements
penalty_elements <- cols[penalty_indices]
# Check which elements exist in 'penalty_cols'
valid_penalty_elements <- penalty_elements %in% penalty_cols
# Remove invalid elements from 'cols'
cols <- cols[-penalty_indices[!valid_penalty_elements]]
} else if(treeSelected == "Overall"){
cols <- colsOverallNLME
} else if (treeSelected %in% c("Theta", "Secondary")){
cols <- colsPrmNLME[-c(8,10,13, 14)]
} else {
cols <- colsPrmNLME
}
}
if(treeSelected %in% c("Theta", "Secondary")){
selected <- setdiff(cols, c("m", "rse"))
} else if(treeSelected == "Omega") {
selected <- setdiff(cols, c("m", "n", "rse", "shrinkage"))
} else if(treeSelected == "Sigma") {
if(software == "NONMEM"){
selected <- setdiff(cols, c("m", "n", "rse", "shrinkage"))
} else {
selected <- setdiff(cols, c("m", "n", "rse", "diagonal", "shrinkage"))
}
} else {
selected <- cols
}
tagList(
div(style = "position: reltaive; z-index: 99",
selectInput(inputId = "selectionTableCols", label = "Select Columns",
choices = cols, multiple = TRUE, selected = selected)
)
)
})
output$selectTableCaption <- renderUI({
req(input$treeModelDiagnostics)
treeSelected <- reactiveSelections$value$tree
if(length(treeSelected) == 0) return(NULL)
if(!(treeSelected %in% table_trees)) return(NULL)
textInput("tableCaption", label = "Caption Text", value = paste("Table", treeSelected, sep = " "), width = "125%")
})
# Order Table Columns ----
reactiveTblCols <- reactiveValues(
col.names = NULL,
order = NULL)
tblCols <- reactive({
cols <- c(input$RetCode, input$Condition, input$logLik,input$`-2LL`,input$AIC,
input$BIC,input$nParm,input$nObs,input$nSub, input$ofv,
input$nobs, input$nind, input$nparm, input$name, input$label,
input$value, input$se, input$rse, input$`rse%`, input$fixed, input$diagonal,
input$m, input$n, input$`2.5% CI`, input$`97.5% CI`, input$`shrinkage%`, input$shrinkage,
input$iteration, input$model_name, input$run_dir, input$fitness,
input$penalty_ntheta, input$penalty_nomega, input$penalty_nsigma, input$penalty_corr,
input$penalty_condition, input$penalty_success, input$penalty_r, input$penalty_python
)
cols
})
observeEvent(tblCols(),{
#NLME Overall
isolate({reactiveTblCols$col.names$RetCode <- input$RetCode})
isolate({reactiveTblCols$col.names$Condition <- input$Condition})
isolate({reactiveTblCols$col.names$logLik <- input$logLik})
isolate({reactiveTblCols$col.names$`-2LL` <- input$`-2LL`})
isolate({reactiveTblCols$col.names$AIC <- input$AIC})
isolate({reactiveTblCols$col.names$BIC <- input$BIC})
isolate({reactiveTblCols$col.names$nParm <- input$nParm})
isolate({reactiveTblCols$col.names$nObs <- input$nObs})
isolate({reactiveTblCols$col.names$nSub <- input$nSub})
isolate({reactiveTblCols$col.names$ofv <- input$ofv})
isolate({reactiveTblCols$col.names$nobs <- input$nobs})
isolate({reactiveTblCols$col.names$nind <- input$nind})
isolate({reactiveTblCols$col.names$nparm <- input$nparm})
isolate({reactiveTblCols$col.names$name <- input$name})
isolate({reactiveTblCols$col.names$label <- input$label})
isolate({reactiveTblCols$col.names$value <- input$value})
isolate({reactiveTblCols$col.names$se <- input$se})
isolate({reactiveTblCols$col.names$rse <- input$rse})
isolate({reactiveTblCols$col.names$`rse%` <- input$`rse%`})
isolate({reactiveTblCols$col.names$fixed <- input$fixed})
isolate({reactiveTblCols$col.names$diagonal <- input$diagonal})
isolate({reactiveTblCols$col.names$m <- input$m})
isolate({reactiveTblCols$col.names$n <- input$n})
isolate({reactiveTblCols$col.names$`2.5% CI` <- input$`2.5% CI`})
isolate({reactiveTblCols$col.names$`97.5% CI` <- input$`97.5% CI`})
isolate({reactiveTblCols$col.names$shrinkage <- input$shrinkage})
isolate({reactiveTblCols$col.names$`shrinkage%` <- input$`shrinkage%`})
#Darwin cols
isolate({reactiveTblCols$col.names$model_name <- input$model_name})
isolate({reactiveTblCols$col.names$iteration <- input$iteration})
isolate({reactiveTblCols$col.names$run_dir <- input$run_dir})
isolate({reactiveTblCols$col.names$fitness <- input$fitness})
isolate({reactiveTblCols$col.names$ofv <- input$ofv})
isolate({reactiveTblCols$col.names$penalty_ntheta <- input$penalty_ntheta})
isolate({reactiveTblCols$col.names$penalty_nomega <- input$penalty_nomega})
isolate({reactiveTblCols$col.names$penalty_nsigma <- input$penalty_nsigma})
isolate({reactiveTblCols$col.names$penalty_corr <- input$penalty_corr})
isolate({reactiveTblCols$col.names$penalty_condition <- input$penalty_condition})
isolate({reactiveTblCols$col.names$penalty_success <- input$penalty_success})
isolate({reactiveTblCols$col.names$penalty_r <- input$penalty_r})
isolate({reactiveTblCols$col.names$penalty_python <- input$penalty_python})
})
observeEvent(input$arrangementTblCols,{
isolate({reactiveTblCols$order <- input$arrangementTblCols})
})
output$selectTableArrangement <- renderUI({
req(input$treeModelDiagnostics)
treeSelected <- reactiveSelections$value$tree
if(length(treeSelected) == 0) return(NULL)
if(!(treeSelected %in% table_trees)) return(NULL)
if(length(input$selectionTableCols) > length(reactiveTblCols$order)){
add_col <- setdiff(input$selectionTableCols, reactiveTblCols$order)
cols <- c(reactiveTblCols$order, add_col)
} else {
pos <- reactiveTblCols$order %in% input$selectionTableCols
cols <- reactiveTblCols$order[pos]
}
ui <- tagList(
fluidRow(
div(style = "padding-left: 25px;, padding-bottom: 20px; padding-right: 25px;",
h4("Rename/Reorder Columns"),
h6("Drag below inputs to reorder table columns", style = "padding-bottom: 1rem; padding-top: 0.5rem;"),
div(
id = "sortable",
create_col_labels(cols, isolate({reactiveTblCols$col.names}))
)
),
sortable_js(
css_id = "sortable",
options = sortable_options(
direction = "horizontal",
onSort = sortable_js_capture_input(input_id = "arrangementTblCols")
)
)
)
)
ui
})
observeEvent(input$isTableCaption,{
if(input$isTableCaption){
shinyjs::enable("tableCaption")
} else {
shinyjs::disable("tableCaption")
}
})
observeEvent(input$isTableFooter,{
if(input$isTableFooter){
shinyjs::enable("tableFooter")
} else {
shinyjs::disable("tableFooter")
}
})
# Table ----
# Initialize a reactive value to store the last valid table
lastValidTable <- reactiveVal()
# Wrap the metaReactive2 expression in a standard Shiny reactive expression
mainTableWrapper <- reactive({
mainTableResult <- mainTable() # Assume mainPlot is your metaReactive2 expression
if (is.null(mainTableResult)) {
return(lastValidTable())
} else {
lastValidTable(mainTableResult)
return(mainTableResult)
}
})
mainTable <- metaReactive2(varname = "table", {
req(xpdbSelected(),
input$treeModelDiagnostics,
input$selectionTableCols)
treeSelected <-
shinyTree::get_selected(input$treeModelDiagnostics)
if (length(treeSelected) == 0) {
userTable <- NULL
} else if (treeSelected %in% table_trees) {
if (is.null(reactiveTblCols$order)) {
col_keys <- input$selectionTableCols
} else {
col_keys <- reactiveTblCols$order
}
if (length(input$selectionTableCols) > length(col_keys)) {
add_col <- setdiff(input$selectionTableCols, col_keys)
col_keys <- c(col_keys, add_col)
} else {
pos <- col_keys %in% input$selectionTableCols
col_keys <- col_keys[pos]
}
values <- reactiveTblCols$col.names[col_keys]
if (treeSelected == "Key Models") {
userTable <- get_darwin_table(
darwin_data = darwin_data,
treeSelected = treeSelected,
software = software,
col_keys = col_keys,
values = values,
isTableCaption = input$isTableCaption,
tableCaption = input$tableCaption,
isTableFooter = input$isTableFooter,
tableFooter = input$tableFooter,
digits = input$tableDigits,
align = input$tableAlign
)
} else {
userTable <- get_table(
xpdb = xpdbSelected(),
treeSelected = treeSelected,
software = software,
col_keys = col_keys,
values = values,
isTableCaption = input$isTableCaption,
tableCaption = input$tableCaption,
isTableFooter = input$isTableFooter,
tableFooter = input$tableFooter,
digits = input$tableDigits,
align = input$tableAlign
)
}
} else {
userTable <- NULL
}
userTable
})
output$previewTable <- renderUI({
req(mainTableWrapper())
mainTableWrapper() %>%
autofit() %>%
htmltools_value()
})
# Save Plot ----
if(!is.null(tagged)){
taggedDiagnostics <- reactiveValues(values = tagged)
} else {
taggedDiagnostics <- reactiveValues(values = list())
}
# Code generation ----
observeEvent(input$savePlot,{
treeSelected <- shinyTree::get_selected(input$treeModelDiagnostics)
if(treeSelected %in% table_trees){
code <- expandChain(mainTable())
code <- c(formatCode(code), "\n")
if(init_arg_type != "xpdb_multiple"){
code <- gsub("NULL\\[\\[", "xpdb\\[\\[", code)
} else {
code <- gsub(pattern = "xpdb", replacement = xpdb_name, x = code)
code <- gsub(pattern = "darwin_data", replacement = darwin_data_name, x = code)
}
taggedDiagnostics$values[[trimws(paste0(input$plotName))]] <- taggedDiagnostics$values[[trimws(paste0(input$plotName))]] %>%
update_tagged(xpdb = xpdbSelected(),
obj = mainTable(),
type = "table",
code = code,
run = input$selectedModel,
name = treeSelected[[1]])
} else {
code <- expandChain(mainPlot())
code <- add_gg_line_break(formatCode(code))
if(init_arg_type != "xpdb_multiple"){
code <- gsub("NULL\\[\\[", "xpdb\\[\\[", code)
} else {
code <- gsub(pattern = "xpdb", replacement = xpdb_name, x = code)
code <- gsub(pattern = "darwin_data", replacement = darwin_data_name, x = code)
}
taggedDiagnostics$values[[trimws(paste0(input$plotName))]] <- taggedDiagnostics$values[[trimws(paste0(input$plotName))]] %>%
update_tagged(xpdb = xpdbSelected(),
obj = mainPlot(),
type = "plot",
code = code,
run = input$selectedModel,
name = paste0(treeSelected))
}
removeModal()
}, suspended = FALSE)
observeEvent(input$selectDiagnostic, {
if(taggedDiagnostics$values[[paste0(input$selectDiagnostic)]]$type == "plot"){
shinyjs::hide("my_tagged_tables_out")
shinyjs::show("my_tagged_plots_out")
} else {
shinyjs::hide("my_tagged_plots_out")
shinyjs::show("my_tagged_tables_out")
}
shinyAce::updateAceEditor(
session,
"md_code",
mode = "r",
tabSize = 4,
useSoftTabs = FALSE,
showInvisibles = FALSE,
showLineNumbers = TRUE,
value = paste0(unlist(taggedDiagnostics$values[[paste0(input$selectDiagnostic)]][["code"]]), collapse = "\n")
)
})
# Preview Tagged Diagnostics ----
output$myTaggedDiagnostics <- renderUI({
if(length(names(taggedDiagnostics$values)) == 0){
selectDiagnostics <- tagList(
div(style = "padding-left: 15px",
h4("No Tagged Diagnostics")
)
)
} else {
selectDiagnostics <- tagList(
fluidRow(style = "align-items: flex-end",
column(
width = 5, style = "padding-left: 3rem; align-self: baseline;",
selectInput(inputId = "selectDiagnostic", label = "Tagged Model Diagnostics", choices = names(taggedDiagnostics$values),
width = "auto")
),
column(
width = 1, style = "padding-top: 0.7rem; align-self: center;",
actionLink(inputId = "removeTagged", icon = icon("trash"), label = "", style = "font-size: 22px;")
),
column(
width = 5, style = "align-self: baseline;",
textInput("nameTaggedScript", "R Script Name", value = "script", width = "125%")
),
column(
width = 1, style = "padding-top: 0.7rem; align-self: center;",
downloadLink(outputId = "saveTaggedScript", label = list(icon("download")), style = "font-size: 22px; color: rgba(var(--bs-link-color-rgb));")
)
)
)
}
selectDiagnostics
})
output$myTaggedPlots <- renderPlot({
req(input$selectDiagnostic)
if(length(taggedDiagnostics$values) == 0) return()
taggedDiagnostics$values[[input$selectDiagnostic]][[2]]
})
output$myTaggedTables <- renderUI({
req(input$selectDiagnostic)
if(length(taggedDiagnostics$values) == 0) return()
taggedDiagnostics$values[[input$selectDiagnostic]][[2]] %>%
autofit() %>%
htmltools_value()
})
# Show/Hide Tagged Diagnostics based on type
# Remove Tagged Diagnostics ----
# Add Confirmation Dialog
observeEvent(input$removeTagged, {
showModal(
modalDialog(
size = "m",
title = "Remove Tagged Diagnostic",
easyClose = TRUE,
div(
style = "padding-top: 10px;",
div(
style = "display: inline-block;",
actionButton("confirmRemoveTagged", label = "Confirm"),
),
div(
style = "display: inline-block;",
actionButton("cancelRemoveTagged", label = "Cancel"),
)
),
footer = NULL
)
)
})
observeEvent(input$confirmRemoveTagged, {
taggedDiagnostics$values[[input$selectDiagnostic]] <- NULL
removeModal()
})
observeEvent(input$cancelRemoveTagged, {
removeModal()
})
observe({
#TO DO, find out what tree structure is when only node is clicked...
if(length(names(taggedDiagnostics$values)) == 0){
shinyjs::hide("md_code")
} else {
shinyjs::show("md_code")
}
})
# Show/Hide Tagged Diagnostics ----
## Tag Diagnostics ----
observeEvent(input$open_savePlotModal, {
showModal(
modalDialog(
size = "m",
easyClose = TRUE,
fluidRow(
column(
width = 12,
uiOutput("userPlotName")
)
),
conditionalPanel("(!input.isDynamic && output.previewPlot) || (input.isDynamic && output.previewPlotly) || output.previewTable",
actionButton("savePlot", label = "Tag")
),
conditionalPanel("(!input.isDynamic && !output.previewPlot && !output.previewTable) || (input.isDynamic && !output.previewPlotly && !output.previewTable)",
actionButton("savePlot", label = "Tag") %>% shinyjs::disabled()
),
textOutput("userPlotDup"),
footer = NULL
)
)
})
## Validate Duplicated Tagged ----
dupTaggedValidation <- reactive({
validate(
need(!(input$plotName %in% names(taggedDiagnostics$values)), "Warning: Tagged diagnostic name already exists and will be overwritten")
)
})
output$userPlotDup <- renderPrint({
dupTaggedValidation()
})
outputOptions(output, "userPlotDup", suspendWhenHidden = FALSE)
# Save Script of Tagged Diagnostics ----
output$saveTaggedScript <- downloadHandler(
filename = function(){
paste(input$nameTaggedScript,"R", sep = ".")
},
content = function(file) {
# Copy the report file to a temporary directory before processing it
tagged <- taggedDiagnostics$values
libs <- c("library(Certara.DarwinReporter)",
"library(Certara.Xpose.NLME)",
"library(xpose)",
"library(ggplot2)",
"library(dplyr)",
"library(tidyr)",
"library(flextable)\n")
libs <- paste0(libs, collapse = "\n")
code <- lapply(tagged, function(x) x$code)
init <-
c(
paste0(
darwin_data_name,
" <- darwin_data(project_dir = '",
darwin_data$project_dir,
"',"
),
paste0("working_dir = '", darwin_data$working_dir, "',"),
paste0("output_dir = '", darwin_data$output_dir, "',"),
paste0("key_models_dir = '", darwin_data$key_models_dir, "')")
)
init <- gsub("\\\\", "\\\\\\\\", init)
init <- c(init, "\n\n")
if(pirana){
showModal(
modalDialog(
title = "File Saved",
p("File has been saved to your downloads folder and is additionally available in ./pirana_scripts"),
easyClose = TRUE,
footer = NULL
)
)
pirana_scripts <- file.path(pirana_dir, "pirana_scripts")
if(!dir.exists(pirana_scripts)){
dir.create(pirana_scripts)
}
print(paste0("saving pirana script to ", pirana_scripts))
writeLines(unlist(c(libs, init, code)), con = paste0(pirana_scripts, "/", input$nameTaggedScript,".R"))
}
writeLines(unlist(c(libs, init, code)), con = file)
}
)
observeEvent(input$isAutoFormat, {
if (!input$isAutoFormat) {
shinyjs::show(id = "customReportDraggable")
} else {
shinyjs::hide(id = "customReportDraggable")
}
})
#Generate Rmd ----
output$generateRmd <- downloadHandler(
filename = function(){
paste(input$reportName, "Rmd", sep = ".")
},
content = function(file) {
rmd <-
create_rmd(
darwin_data = darwin_data,
title = input$reportName,
objects = taggedDiagnostics$values,
orientation = input$pageLayout,
marginLeft = input$marginLeft,
marginRight = input$marginRight,
marginTop = input$marginTop,
marginBottom = input$marginBottom,
includeAppendix = input$includeAppendix,
autoFormat = input$isAutoFormat,
customOrder = input$rank_list_2,
raw = TRUE,
darwin_data_name = darwin_data_name
)
if(pirana){
showModal(
modalDialog(
title = "File Saved",
p("File has been saved to your downloads folder and is additionally available in ./pirana_scripts"),
easyClose = TRUE,
footer = NULL
)
)
pirana_scripts <- file.path(pirana_dir, "pirana_scripts")
if(!dir.exists(pirana_scripts)){
dir.create(pirana_scripts)
}
writeLines(unlist(c(rmd)), con = paste0(pirana_scripts, "/", gsub(":", "",input$reportName),".Rmd"))
}
writeLines(unlist(c(rmd)), con = file)
}
)
output$selectReport <- renderUI({
bucketReport <- tagList(
fluidRow(style = "padding-left:25px; padding-right:25px;",
bucket_list(
header = NULL,
group_name = "bucket_list_group",
orientation = "horizontal",
add_rank_list(
text = "Tagged",
labels = names(taggedDiagnostics$values),
input_id = "rank_list_1"
),
add_rank_list(
text = "Report Output",
labels = NULL,
input_id = "rank_list_2"
)
)
)
)
bucketReport
})
# Show modal if trying to generate a report and no tagged diagnostics
observeEvent(input$active_tab, {
active_tab <- input$active_tab
if (active_tab == "tab_report" && length(taggedDiagnostics$values) == 0) {
showModal(
modalDialog(
size = "m",
title = "No tagged plots or tables",
easyClose = TRUE,
p("Navigate to the 'Preview' tab and select a model diagnostic from the available options on the left, then click the 'Tag' button in the bottom right corner of the screen.")
)
)
}
})
output$generateReport <- downloadHandler(
filename = function(){
paste(input$reportName, input$fileType, sep = ".")
},
content = function(file) {
# Copy the report file to a temporary directory before processing it
create_rmd(
darwin_data = darwin_data,
title = input$reportName,
objects = taggedDiagnostics$values,
orientation = input$pageLayout,
marginLeft = input$marginLeft,
marginRight = input$marginRight,
marginTop = input$marginTop,
marginBottom = input$marginBottom,
includeAppendix = input$includeAppendix,
autoFormat = input$isAutoFormat,
customOrder = input$rank_list_2
)
tempReport <- file.path(tempdir(), "report_template.Rmd")
tempReportWord <- file.path(tempdir(), "report_template.docx")
wordTemplate <- system.file("extdata", "report_template.docx", package = "Certara.DarwinReporter", mustWork = TRUE)
file.copy("report_template.Rmd", tempReport, overwrite = TRUE)
file.copy(wordTemplate, tempReportWord, overwrite = TRUE)
if (input$isAutoFormat) {
params <- list(inputs = taggedDiagnostics$values,
darwin_data = darwin_data)
} else {
params <- list(inputs = taggedDiagnostics$values[input$rank_list_2],
darwin_data = darwin_data)
}
# Knit the document, passing in the `params` list, and eval it in a
# child of the global environment (this isolates the code in the document
# from the code in model results app).
shiny::withProgress(
message = paste0("Rendering ", input$reportName, ".", input$fileType),
value = 0,{
shiny::incProgress(3/10)
rmarkdown::render(tempReport, output_file = file,
output_format = report_render(input$fileType),
params = params,
envir = new.env(parent = globalenv()))
shiny::incProgress(7/10)
Sys.sleep(0.25)
shiny::incProgress(10/10)
})
file.remove("report_template.Rmd")
}
)
output$report_download_buttons <- renderUI({
if(pirana){
ui <- fluidRow(
column(
width = 4,
actionLink("generateReportPirana", label = list("Download Report", HTML(" "), icon("file-download")), style = "font-size: 18px; font-family:Segoe UI Light, Arial, sans-serif;")
),
column(
width = 4,
offset = 3,
downloadLink("generateRmd", label = list("Download RMarkdown", HTML(" "), icon("file-code")), style = "font-size: 18px; font-family:Segoe UI Light, Arial, sans-serif;")
)
)
} else {
ui <- fluidRow(
column(
width = 4,
downloadLink("generateReport", label = list("Download Report", HTML(" "), icon("file-download")), style = "font-size: 18px; font-family:Segoe UI Light, Arial, sans-serif; width: -webkit-fill-available;")
),
column(
width = 4,
offset = 3,
downloadLink("generateRmd", label = list("Download RMarkdown", HTML(" "), icon("file-code")), style = "font-size: 18px; font-family:Segoe UI Light, Arial, sans-serif; width: -webkit-fill-available;")
)
)
}
ui
})
observeEvent(input$generateReportPirana,{
filename <- paste(input$reportName, input$fileType, sep = ".")
filename <- gsub(":", "", filename)
create_rmd(
darwin_data = darwin_data,
title = input$reportName,
objects = taggedDiagnostics$values,
orientation = input$pageLayout,
marginLeft = input$marginLeft,
marginRight = input$marginRight,
marginTop = input$marginTop,
marginBottom = input$marginBottom,
includeAppendix = input$includeAppendix,
autoFormat = input$isAutoFormat,
customOrder = input$rank_list_2,
darwin_data_name= darwin_data_name
) #if missing directory argument uses wd
tempReport <- file.path(tempdir(), "report_template.Rmd")
tempReportWord <- file.path(tempdir(), "report_template.docx")
wordTemplate <- system.file("extdata", "report_template.docx", package = "Certara.DarwinReporter", mustWork = TRUE)
file.copy("report_template.Rmd", tempReport, overwrite = TRUE)
file.copy(wordTemplate, tempReportWord, overwrite = TRUE)
# Set up parameters to pass to Rmd document
if (input$isAutoFormat) {
params <- list(inputs = taggedDiagnostics$values,
darwin_data = darwin_data)
} else {
params <- list(inputs = taggedDiagnostics$values[input$rank_list_2],
darwin_data = darwin_data)
}
pirana_reports <- file.path(pirana_dir, "pirana_reports", "shiny")
if(!dir.exists(pirana_reports)){
dir.create(pirana_reports, recursive = TRUE)
}
# Knit the document, passing in the `params` list, and eval it in a
# child of the global environment (this isolates the code in the document
# from the code in model results app).
#NOTE Users should set this env variable from Windows if having issues with pandoc
#Sys.setenv(RSTUDIO_PANDOC = "C:/Program Files/RStudio/bin/pandoc")
shiny::withProgress(
message = paste0("Rendering ", input$reportName, ".", input$fileType),
value = 0,{
shiny::incProgress(3/10)
rmarkdown::render(tempReport, output_file = paste0(pirana_reports, "/", filename),
output_format = report_render(input$fileType),
params = params,
envir = new.env(parent = globalenv()))
shiny::incProgress(7/10)
Sys.sleep(0.25)
shiny::incProgress(10/10)
})
file.remove("report_template.Rmd")
showModal(
modalDialog(
title = "File Saved",
p("Report has been saved to ./pirana_reports/shiny"),
easyClose = TRUE,
footer = NULL
)
)
})
observeEvent(input$fileType, {
if (input$fileType == "pdf") {
shinyjs::show(id = "pdf_layout")
shinyjs::show(id = "pdf_options")
} else {
shinyjs::hide(id = "pdf_layout")
shinyjs::hide(id = "pdf_options")
}
})
# Model Diagnostics Tree Output ----
output$treeModelDiagnostics <- shinyTree::renderTree({
resultsTreeList
})
outputOptions(output, "treeModelDiagnostics", suspendWhenHidden = FALSE)
observeEvent(input$exitShiny, {
showModal(
modalDialog(
size = "m",
title = "Exit Darwin Reporter",
easyClose = TRUE,
fluidRow(
div(style = "padding-top: 10px;"),
column(
width = 4,
checkboxInput(inputId = "saveSettingsRds", label = "Save Settings", value = TRUE)
)
),
div(
style = "padding-top: 10px;",
div(
style = "display: inline-block;",
actionButton("exitConfirm", "Exit")
),
div(
style = "display: inline-block;",
actionButton("exitCancel", "Cancel")
)
),
footer = NULL
)
)
})
observeEvent(input$exitCancel, {
removeModal(session = session)
})
observeEvent(input$exitConfirm, {
# from the code in model results app).
shiny::withProgress(
message = paste0("Exiting Darwin Reporter"),
value = 0,
{
if(pirana){
dir_out <- file.path(pirana_dir, "pirana_shiny")
if(!dir.exists(dir_out)){
dir.create(dir_out)
}
} else {
dir_out <- "."
}
if (input$saveSettingsRds) {
settings_out <- update_settings(settings, input)
saveRDS(settings_out, file = paste0(dir_out, "/settings.Rds"))
shiny::incProgress(3 / 10, message = "Settings saved")
Sys.sleep(1)
}
# if (input$saveTaggedRds) {
# shiny::incProgress(7 / 10, message = "Saving tagged objects")
#
# tagged_out <- isolate({
# taggedDiagnostics$values
# })
#
# save_tagged_rds(parse_tagged(tagged_out), dir_out)
#
# }
}
)
removeModal()
message("Shiny session has ended")
# we can implement a try for above code, if FALSE, don't stop app.
session$sendCustomMessage(type = "shinymaterialJS", js$closewindow())
session$onSessionEnded(function() {
stopApp(isolate({
taggedDiagnostics$values
})
)
})
})
session$onSessionEnded(function() {
stopApp(isolate({taggedDiagnostics$values}))
}
)
}
ui <- tagList(
# 1.0 Shiny JS ----
shinyjs::useShinyjs(),
shinyjs::extendShinyjs(
text = jsFunctions2,
functions = c("closewindow", "select_sidenav_tab")
),
tags$head(tags$style(styleCSS)),
shinyWidgets::chooseSliderSkin("Modern", color = "#0a7bc1"),
tags$script(
'Shiny.addCustomMessageHandler("switchTab", function(tabName) {
var instance = M.Tabs.getInstance($(".tabs"));
instance.select(tabName);
});'
),
tags$script(
HTML(
"$(document).ready(function() {
$('ul.tabs').on('click', 'a', function() {
Shiny.setInputValue('active_tab', $(this).attr('href').substring(1));
});
});"
)
),
# 2.0 Header ----
certara_header("Darwin Reporter"),
# 3.0 Page ----
bslib::page_navbar(
title = NULL,
window_title = "Darwin Reporter",
## 3.1 Overview Page ----
bslib::nav_panel(
title = "Overview",
value = "side_nav_tab_search_overview",
bslib::card_body(
bslib::card(
fluidRow(
column(width = 2,
uiOutput("runInfoCards")),
column(
width = ifelse(is.null(darwin_data$search_overview), 12, 10),
fluidRow(
column(
width = 6,
bslib::card(
height = "400px",
full_screen = TRUE,
shinyWidgets::addSpinner(
plotly::plotlyOutput("fitnessVsIteration", height = "100%"),
spin = "circle",
color = "#0a7bc1"
)
)
),
column(
width = 6,
bslib::card(
height = "400px",
full_screen = TRUE,
shinyWidgets::addSpinner(
plotly::plotlyOutput("fitnessPenaltiesVsIteration", height = "100%"),
spin = "circle",
color = "#0a7bc1"
)
)
)
),
div(style = "padding-left: 15px",
h4("Key Models")),
div(
style = "overflow-x: auto;",
DT::DTOutput("fitnessSummaryTable")
)
)
)
)
)
),
## 3.2 Diagnostics Page ----
bslib::nav_panel(
title = "Diagnostics",
value = "side_nav_tab_diagnostics",
## 3.3 Sidebar ----
bslib::layout_sidebar(
sidebar = bslib::sidebar(
width = 350,
open = TRUE,
actionLink(inputId = "backToSearchOverview", icon = icon("arrow-left"), label = "Back to Search Overview", style = "font-size: 14px;"),
div(id ="darwin_key_models_selection", style = "padding-top: 5px;",
selectInput(inputId = "selectedModel", label = "Key Model", choices = names(xpdb)),
conditionalPanel("input.selectedPlotType == 'covariate_scatter' || input.selectedPlotType == 'covariate_box'",
uiOutput("covSelection")
)
) %>% shinyjs::hidden(),
div(style = "padding: 10px;"),
div(style="height:25rem; overflow-y: scroll;", #Add vertical scroll bar to tree
h5("Search"),
shinyTree::shinyTree("treeModelDiagnostics",
search = TRUE,
theme = "proton",
multiple = FALSE,
themeIcons = FALSE,
themeDots = TRUE
)
),
div(style = "padding: 10px;"),
bslib::card(
class = "sidebar-card",
h6("Currently Selected:"),
textOutput("selectedPlotName"),
div(style = "padding: 10px;"),
h6("Description:"),
textOutput("selectedPlotDesc")
),
div(id = "selected_plot_type", #Create hidden input for plot cusomtization conditional panel
selectInput(inputId = "selectedPlotType", label = "", choices = c("scatter", "distribution", "covariate_scatter", "covariate_box", "ind_plots", "none"), selected = "none")
) %>% shinyjs::hidden()
),
### 4.0 Main Body Card ----
bslib::navset_card_underline(
id = "maincard",
title = NULL,
#### 4.1 Preview Tab ----
bslib::nav_panel(
title = "Preview",
value = "tab_preview",
bslib::card_body(
height = "100%",
class = "preview-tab",
##### 4.1a Plot Display ----
div(
id = "main_plot_preview",
div(id = "plotly_switch", style = "padding-left: 15px; padding-bottom: 10px;",
checkboxInput(inputId = "isDynamic", label = "Interactive", value = FALSE)
) %>% shinyjs::hidden(),
div(id = "diagnostics-page-plot",
style = "padding-left: 25px; margin-left: 25px; padding-right: 25px; padding-bottom: 15px;",
conditionalPanel(
"input.isDynamic == false",
bslib::card(
style = "border: none;",
full_screen = TRUE,
shinyjqui::jqui_resizable(
plotOutput("previewPlot")
)
)
),
conditionalPanel(
"input.isDynamic == true",
bslib::card(
style = "border: none;",
full_screen = TRUE,
shinyjqui::jqui_resizable(
plotly::plotlyOutput("previewPlotly")
)
)
)
)
) %>% shinyjs::hidden(),
##### 4.1b Table Display ----
div(
id = "main_table_preview", # style = "overflow-x: scroll",
fluidRow(
div(style = "padding-left: 25px; padding-right: 25px;",
uiOutput("previewTable")
)
),
fluidRow(style = "padding-bottom: 1rem;",
column(
width = 6,
div(style = "padding-left: 1rem; padding-right: 1rem;",
h4("Select Columns"),
uiOutput("selectTableCols", style = "width: 100rem; padding-right: 15px;")
)
)
),
uiOutput("selectTableArrangement"),
div(style = "padding-top: 1rem; padding-left: 1rem; padding-right: 1rem;",
fluidRow(
column(width = 4,
h4("Format Columns")
),
column(width = 4,
h4("Caption")
),
column(width = 4,
h4("Footer")
)
),
fluidRow(class = "multi-input-with-checkbox",
column(width = 4,
selectInput(inputId = "tableAlign", label = "Column Alignment", selected = "left", choices = c("left", "right", "center"))
),
column(width = 4, class = "col-checkbox",
checkboxInput(inputId = "isTableCaption", label = "", value = TRUE)
),
column(width = 4, class = "col-checkbox",
checkboxInput(inputId = "isTableFooter", label = "", value = TRUE)
)
),
fluidRow(
column(width = 4,
numericInput(inputId = "tableDigits", label = "Number of Digits", value = 4, min = 0, max = 10, width = "125%")
),
column(width = 4,
uiOutput("selectTableCaption")
),
column(width = 4,
textInput("tableFooter", label = "Footer Text", value = "Source: script.R", width = "125%")
)
)
),
fluidRow(
div(style = "padding-left: 30px; padding-top: 20px;",
actionLink("linkModalTableGlossary", label = "View Table Glossary")
)
)
) %>% shinyjs::hidden(),
br(),
##### 4.1c Plot Options ----
conditionalPanel("input.selectedPlotType != 'none'",
div(id = "plottabs", # class = "ptab",
bslib::navset_card_underline(
###### 4.2 Style Sub-Tab ----
bslib::nav_panel(
title = shiny::HTML(paste0('<i class="fa-solid fa-paint-roller"></i>  Style')),
value = "style",
bslib::card_body(
class = "style-subtab",
####### 4.2a GOF Inputs ----
div(id = "gofStyleInputs",
######## Scatter / Cov-Scatter ----
conditionalPanel("input.selectedPlotType == 'scatter' || input.selectedPlotType == 'covariate_scatter'",
fluidRow(style = "padding-top :10px;",
column(
width = 2,
offset = 1,
checkboxInput(inputId = "displayPoints", label = "Points", value = TRUE),
div(class = "custom_style_point",
selectInput(inputId = "shapePoint", "Point Shape", choices = c("circle-fill", "circle", "square-fill", "square", "triangle-fill", "triangle"), selected = settings$point.shape),
numericInput(inputId = "sizePoint", label = "Point Size", min = 0, max = 10, step = .1, value = settings$point.size),
colourInput("colorPoint", "Point Color", value = settings$point.color),
sliderInput("alphaPoint", "Point Transparency", min = 0, max = 100, value = settings$point.alpha, post = "%", ticks = FALSE)
)
),
column(
width = 2,
checkboxInput(inputId = "displayLines", label = "Lines", value = FALSE),
div(class = "custom_style_lines",
selectInput(inputId = "typeLine", "Line Type", choices = c("blank", "solid", "dashed", "dotted", "dotdash", "longdash", "twodash"), selected = settings$line.type),
numericInput(inputId = "sizeLine", label = "Line Size", min = 0, max = 5, step = .1, value = settings$line.size),
colourInput("colorLine", "Line Color", value = settings$line.color),
sliderInput("alphaLine", "Line Transparency", min = 0, max = 100, value = settings$line.alpha, post = "%", ticks = FALSE)
)
),
column(
width = 2,
checkboxInput(inputId = "displayRefLine", label = "Reference Line", value = TRUE),
div(class = "custom_style_ref_line",
selectInput(inputId = "typeLineGuide", "Reference Line Type", choices = c("blank", "solid", "dashed", "dotted", "dotdash", "longdash", "twodash"), selected = settings$guide.line.type),
numericInput(inputId = "sizeLineGuide", label = "Reference Line Size", min = 0, max = 10, step = .1, value = settings$guide.line.size),
colourInput("colorLineGuide", "Reference Line Color", value = settings$guide.line.color),
sliderInput("alphaLineGuide", "Reference Line Transparency", min = 0, max = 100, value = settings$guide.line.alpha, post = "%", ticks = FALSE)
)
),
column(
width = 2,
checkboxInput(inputId = "displaySmoothing", label = "Smoothing", value = TRUE),
div(class = "custom_style_smoothing_line",
selectInput(inputId = "typeLineSmooth", "Smoothing Line Type", choices = c("blank", "solid", "dashed", "dotted", "dotdash", "longdash", "twodash"), selected = settings$smooth.line.type),
numericInput(inputId = "sizeLineSmooth", label = "Smoothing Line Size", min = 0, max = 10, step = .1, value = settings$smooth.line.size),
colourInput("colorLineSmooth", "Smoothing Line Color", value = settings$smooth.line.color),
numericInput("spanSmooth", "Span", min = 0, max = 1, step = .05, value = 0.75),
uiOutput("spanRangeValidation"),
selectInput(inputId = "smoothingType", label = "Smoothing Method", choices = c("loess", "lm", "glm", "gam"), selected = settings$plot.scatter.smoothing)
#Note: Cannot change alpha line transparency of smoothing line via xpose - we need ggplot2::stat_smooth()
)
),
column(
width = 2,
checkboxInput(inputId = "displayText", label = "Text", value = FALSE),
)
)
),
######## Ind. Plots ----
conditionalPanel("input.selectedPlotType == 'ind_plots'",
fluidRow(style = "padding-bottom: 10px;",
column(
width = 2,
offset = 2,
h5("DV")
),
column(
width = 2,
h5("IPRED")
),
column(
width = 2,
h5("PRED")
),
column(
width = 2,
h5("Legend")
)
),
fluidRow(class = "multi-input-with-checkbox",
column(
width = 2,
offset = 2,
selectInput(inputId = "shapePointDV", "Point Shape", choices = c("circle-fill", "circle", "square-fill", "square", "triangle-fill", "triangle"), selected = settings$indplots.point.shape.DV)
),
column(
width = 2,
selectInput(inputId = "typeLineIPRED", "Line Type", choices = c("blank", "solid", "dashed", "dotted", "dotdash", "longdash", "twodash"), selected = settings$indplots.line.type.IPRED)
),
column(
width = 2,
selectInput(inputId = "typeLinePRED", "Line Type", choices = c("blank", "solid", "dashed", "dotted", "dotdash", "longdash", "twodash"), selected = settings$indplots.line.type.PRED)
),
column(class = "col-checkbox",
width = 2,
checkboxInput(inputId = "displayLegend", label = "Show Legend", value = TRUE)
)
),
fluidRow(
column(
width = 2,
offset = 2,
colourInput("colorPointDV", "Point Color", value = settings$indplots.point.color.DV),
numericInput(inputId = "sizePointDV", "Point Size", min = 0, max = 10, step = .1, value = settings$indplots.point.size.DV),
sliderInput("alphaPointDV", "Point Transparency", min = 0, max = 100, value = settings$indplots.point.alpha.DV, post = "%", ticks = FALSE)
),
column(
width = 2,
colourInput("colorLineIPRED", "Line Color", value = settings$indplots.line.color.IPRED)
),
column(
width = 2,
colourInput("colorLinePRED", "Line Color", value = settings$indplots.line.color.PRED)
),
column(
width = 2,
div(class = "custom_legend",
selectInput(inputId = "legendPosition", "Legend Position", choices = c("bottom", "top", "left", "right"), selected = settings$indplots.legend.position)
)
)
)
),
######## Distr. Plots ----
conditionalPanel("input.selectedPlotType == 'distribution'",
fluidRow(style = "padding-top: 10px;",
column(
width = 2,
offset = 3,
checkboxInput(inputId = "displayHistogram", label = "Histogram", value = TRUE),
div(class = "custom_style_histogram",
numericInput(inputId = "nbinsHistogram", label = "Histogram N Bins", min = 1, max = 100, value = settings$hist.nbins, step = 1),
selectInput(inputId = "typeLineHistogram", label = "Histogram Line Type", choices = c("blank", "solid", "dashed", "dotted", "dotdash", "longdash", "twodash"), selected = settings$hist.line.type),
numericInput(inputId = "sizeHistogram", label = "Histogram Line Size", min = 0, max = 100, value = settings$hist.size, step = 1),
colourInput("colorHistogram", "Histogram Line Color", value = settings$hist.line.color),
colourInput("fillHistogram", "Histogram Fill Color", value = settings$hist.fill.color),
sliderInput("alphaHistogram", "Histogram Transparency", min = 0, max = 100, value = settings$hist.alpha, post = "%", ticks = FALSE)
)
),
column(
width = 2,
checkboxInput(inputId = "displayDensity", label = "Density", value = FALSE),
div(class = "custom_style_density",
selectInput(inputId = "typeLineDensity", label = "Density Line Type", choices = c("blank", "solid", "dashed", "dotted", "dotdash", "longdash", "twodash"), selected = settings$density.line.type),
numericInput(inputId = "sizeDensity", label = "Density Line Size", min = 0, max = 100, value = settings$density.size, step = 1),
colourInput("colorDensity", "Density Line Color", value = settings$density.line.color),
colourInput("fillDensity", "Density Fill Color", value = settings$density.fill.color),
sliderInput("alphaDensity", "Density Transparency", min = 0, max = 100, value = settings$density.alpha, post = "%", ticks = FALSE)
)
),
column(
width = 2,
checkboxInput(inputId = "displayRug", label = "Rug", value = TRUE),
div(class = "custom_style_rug",
selectInput(inputId = "positionRug", label = "Rug Sides", choices = c("bottom", "top", "both"), selected = settings$rug.sides),
numericInput(inputId = "sizeLineRug", label = "Rug Line Size", min = 0, max = 100, value = settings$rug.line.size, step = 1),
colourInput("colorRug", "Rug Color", value = settings$rug.color)
)
)
)
),
######## Cov. Box Plot ----
conditionalPanel("input.selectedPlotType == 'covariate_box'",
fluidRow(style = "display: flex; padding-top: 10px;",
column(
width = 3,
offset = 2,
colourInput("colorBoxPlot", "Box Plot Line Color", value = settings$boxplot.line.color),
colourInput("fillBoxPlot", "Box Plot Fill Color", value = settings$boxplot.fill.color),
sliderInput("alphaBoxPlot", "Box Plot Transparency", min = 0, max = 100, value = settings$boxplot.alpha, post = "%", ticks = FALSE)
),
column(
style = "padding-top: 2rem;",
width = 2,
checkboxInput(inputId = "displayOutliers", "Display Outliers", value = TRUE)
),
column(
width = 3,
div(class = "custom_style_outliers",
selectInput(inputId = "shapeOutlier", label = "Outlier Shape", choices = c("circle-fill", "circle", "square-fill", "square", "triangle-fill", "triangle"), selected = settings$outlier.shape),
numericInput(inputId = "sizeOutlier", label = "Outlier Size", min = 0, max = 100, value = 1, step = settings$outlier.size),
sliderInput("alphaOutlier", "Outlier Transparency", min = 0, max = 100, value = settings$outlier.alpha, post = "%", ticks = FALSE),
colourInput("colorOutlier", "Outlier Color", value = settings$outlier.color)
)
)
)
)
) %>% shinyjs::hidden(),
####### 4.2b Darwin Style Inputs ----
div(id = "darwinStyleInputs", style = "padding-left: 3rem;",
fluidRow(
column(
width = 2,
offset = 2,
selectInput(inputId = "legendPositionDarwin", label = "Legend Position", choices = c("top", "bottom", "left", "right"), selected = settings$darwinplots.legend.position),
selectInput(inputId = "legendDirectionDarwin", label = "Legend Direction", choices = c("vertical", "horizontal"), selected = settings$darwinplots.legend.direction),
),
######## Fitness ----
column(id = "darwinStyleFitnessInputs",
width = 6,
fluidRow(class = "multi-input-with-checkbox",
column(
width = 4,
selectInput(inputId = "typeLineMean", "Line Type (Mean)", choices = c("blank", "solid", "dashed", "dotted", "dotdash", "longdash", "twodash"), selected = settings$darwinplots.line.type.mean)
),
column(
width = 4,
selectInput(inputId = "typeLineMin", label = "Line Type (Min)", choices = c("blank", "solid", "dashed", "dotted", "dotdash", "longdash", "twodash"), selected = settings$darwinplots.line.type.min)
),
column(class = "col-checkbox",
width = 4,
checkboxInput(inputId = "annotateBestFitness", label = "Annotate Best Fitness", value = TRUE)
)
),
fluidRow(
column(
width = 4,
colourInput("colorLineMean", "Line Color (Mean)", value = settings$darwinplots.line.color.mean)
),
column(
width = 4,
colourInput("colorLineMin", "Line Color (Min)", value = settings$darwinplots.line.color.min)
),
column(
width = 4,
conditionalPanel("input.annotateBestFitness == true",
sliderInput("sizeAnnotate", "Annotation Size", min = 0, max = 10, value = 5, step = 0.25, ticks = FALSE)
)
)
),
fluidRow(
column(
width = 4,
sliderInput("widthLineMean", "Line Width (Mean)", min = 0, max = 5, value = settings$darwinplots.line.width.mean, ticks = FALSE, step = 0.1)
),
column(
width = 4,
sliderInput("widthLineMin", "Line Width (Min)", min = 0, max = 5, value = settings$darwinplots.line.width.min, ticks = FALSE, step = 0.1)
)
)
) %>% shinyjs::hidden(),
# material_column(width = 2,
# material_dropdown("legendPositionDarwin", "Legend Position", choices = c("top", "bottom", "left", "right"), selected = settings$darwinplots.legend.position),
# div(style = "padding:5px;"),
# material_dropdown("legendDirectionDarwin", "Legend Direction", choices = c("vertical", "horizontal"), selected = settings$darwinplots.legend.direction),
# ),
# material_column(width = 3,
# material_checkbox("annotateBestFitness", label = "Annotate Best Fitness", initial_value = TRUE)
# )
#
# )
#)#,
######## Penalty ----
column(id = "darwinStylePenaltyInputs", # style = "padding-left: 3rem;",
width = 4,
fluidRow(
column(
width = 6,
checkboxInput(inputId = "scaleOFV", label = "Scale OFV", value = TRUE)
),
column(
width = 6,
checkboxInput(inputId = "groupPenalties", label = "Group Penalties", value = FALSE)
)
)
) %>% shinyjs::hidden()
)
) %>% shinyjs::hidden()
)
),
###### 4.3 Layout Sub-Tab ----
bslib::nav_panel(# "tab_layout",
title = shiny::HTML(paste0('<i class="fa-solid fa-table-cells"></i>  Layout')),
bslib::card_body(
class = "layout-subtab",
min_height = "220px",
div(id = "gofLayoutInputs",
fluidRow(class = "multi-input-with-checkbox",
column(
width = 2,
selectInput(inputId = "selectedFacet", label = "Select Facet", choices = c("none"))
),
column(
width = 2,
selectInput(inputId = "selectedAxisScale", label = "Axis Scale", choices = c("free", "fixed"), selected = settings$axis.scale)
),
column(class = "col-checkbox",
width = 2,
checkboxInput(inputId = "isLogX", label = "x-axis log", value = FALSE)
),
column(class = "col-checkbox",
width = 2,
checkboxInput(inputId = "isLogY", label = "y-axis log", value = FALSE)
),
column(class = "col-checkbox",
width = 2,
checkboxInput(inputId = "isDefaultArrangement", label = "Default Arrangement", value = TRUE)
),
column(class = "col-checkbox",
width = 2,
checkboxInput(inputId = "isExtraHlines", label = "Additional Ref Lines", value = FALSE),
)
),
fluidRow(
column(class = "custom_facet_arrangement",
width = 2, offset = 8,
numericInput(inputId = "arrangeRowNum", label = "Number of Rows", value = settings$arrange.nrow, min = 1, max = 100),
numericInput(inputId = "arrangeColNum", label = "Number of Columns", value = settings$arrange.ncol, min = 1, max = 100),
numericInput(inputId = "selectedPage",label = "Page Number", min = 1, max = 100, step = 1, value = 1)
),
column(class = "custom_hlines",
style = "margin-left: auto;",
width = 2,
numericInput(inputId = "hLine1", label = "Line 1: Y = ", value = settings$guide.line.extra.y1, min = NA, max = NA),
numericInput(inputId = "hLine2", label = "Line 2: Y =", value = settings$guide.line.extra.y2, min = NA, max = NA)
)
)
)
)
),
###### 4.4 Display Sub-Tab ----
bslib::nav_panel(
title = shiny::HTML(paste0('<i class="fa-solid fa-eye-slash"></i>  Display')),
bslib::card_body(
class = "display-subtab",
div(style = "padding: 0.3rem"),
fluidRow(class = "multi-input-with-checkbox",
column(class = "col-checkbox",
width = 2,
offset = 1,
checkboxInput(inputId = "isDefaultText", label = "Default Text", value = TRUE)
),
column(class = "col-checkbox",
width = 2,
checkboxInput(inputId = "isCertaraTheme", label = "Certara Theme", value = settings$certara.theme)
),
column(class = "col-checkbox",
width = 2,
div(class = "custom_plot_theme_inputs",
checkboxInput(inputId = "isShowBorder", label = "Border", value = settings$background.border)
)
),
column(class = "col-checkbox",
width = 2,
div(class = "custom_plot_theme_inputs",
checkboxInput(inputId = "isShowGridLines", label = "Grid Lines", value = settings$background.gridlines)
)
),
column(
width = 2,
div(class = "custom_plot_theme_inputs",
colourInput("colorBackground", "Plot Background Color", value = settings$background.color)
)
)
),
fluidRow(
column(
width = 2,
offset = 1,
div(class = "custom_text_inputs",
div(id = "darwinTextInputs",
textInput(inputId = "textDarwinTitle", label = "Title", value = ""),
textInput(inputId = "textDarwinSubtitle", label = "Subtitle", value = ""),
textInput(inputId = "textDarwinCaption", label = "Caption", value = ""),
textInput(inputId = "xlabDarwin", label = "x-Label", value = ""),
textInput(inputId = "ylabDarwin", label = "y-Label", value = "")
) %>% shinyjs::hidden(),
div(id = "xposeTextInputs",
textInput(inputId = "textTitle", label = "Title", value = "@y vs. @x | @run"),
textInput(inputId = "textSubtitle", label = "Subtitle", value = "-2LL: @ofv"),
textInput(inputId = "textCaption", label = "Caption", value = "@dir"),
textInput(inputId = "xlab", label = "x-Label", value = "@x"),
textInput(inputId = "ylab", label = "y-Label", value = "@y"),
actionLink("linkModalTags", label = "View Plot Tags")
) %>% shinyjs::hidden()
)
),
column(class = "custom_plot_theme_inputs",
width = 2,
numericInput(inputId = "sizeTitle", label = "Title Size", min = 1, max = 30, value = settings$title.size, step = 1),
selectInput(inputId = "fontTitle", label = "Title Font", choices = c("Times New Roman", "Arial", "Courier New"), selected = settings$title.font),
colourInput("colorTitle", "Title Font Color", value = settings$title.color),
selectInput(inputId = "faceTitle", label = "Title Face", choices = c("plain", "bold", "italic", "bold.italic"), selected = settings$title.face),
),
column(class = "custom_plot_theme_inputs",
width = 2,
numericInput(inputId = "sizeSubtitle", label = "Subtitle Size", min = 1, max = 30, value = settings$subtitle.size, step = 1),
selectInput(inputId = "fontSubtitle", label = "Subtitle Font", choices = c("Times New Roman", "Arial", "Courier New"), selected = settings$subtitle.font),
colourInput("colorSubtitle", "Subtitle Font Color", value = settings$subtitle.color),
selectInput(inputId = "faceSubtitle", label = "Subtitle Face", choices = c("plain", "bold", "italic", "bold.italic"), selected = settings$subtitle.face)
),
column(class = "custom_plot_theme_inputs",
width = 2,
numericInput(inputId = "sizeCaption", label = "Caption Size", min = 1, max = 30, value = settings$caption.size, step = 1),
selectInput(inputId = "fontCaption", label = "Caption Font", choices = c("Times New Roman", "Arial", "Courier New"), selected = settings$caption.font),
colourInput("colorCaption", label = "Caption Font Color", value = settings$caption.color),
selectInput(inputId = "faceCaption", label = "Caption Face", choices = c("plain", "bold", "italic", "bold.italic"), selected = settings$caption.face)
),
column(class = "custom_plot_theme_inputs",
width = 2,
numericInput(inputId = "sizeAxis", label = "Axis Label Size", min = 1, max = 30, value = settings$axis.size, step = settings$axis.size),
selectInput(inputId = "fontAxis", label = "Axis Label Font", choices = c("Times New Roman", "Arial", "Courier New"), selected = settings$axis.font),
colourInput("colorAxis", label = "Axis Label Font Color", value = settings$axis.color),
selectInput(inputId = "faceAxis", label = "Axis Label Face", choices = c("plain", "bold", "italic", "bold.italic"), selected = settings$axis.face)
)
)
)
)
)
),
##### 4.5 Tag Button ----
fluidRow(
column(
width = 12,
conditionalPanel("input.selectedPlotType != 'none'",
actionButton(inputId = "open_savePlotModal", label = NULL, icon = icon("tag"))
)
)
)
)
)
),
#### 4.6 Tagged Tab ----
bslib:: nav_panel(
title = "Tagged",
bslib::card_body(
uiOutput("myTaggedDiagnostics"),
div(
id = "my_tagged_plots_out",
style = "padding-left: 25px; padding-right: 25px; padding-bottom: 15px;",
bslib::card(
style = "border: none;",
full_screen = TRUE,
plotOutput("myTaggedPlots")
)
),
div(id = "my_tagged_tables_out",
style = "padding-left: 25px; padding-right: 25px; padding-bottom: 15px;",
uiOutput("myTaggedTables")
),
shinyAce::aceEditor(
outputId = "md_code",
autoScrollEditorIntoView = TRUE,
minLines = 5,
maxLines = 35,
value = NULL,
readOnly = TRUE
)
)
),
#### 4.7 Report Tab ----
bslib::nav_panel(
title = "Report",
value = "tab_report",
bslib::card_body(
fluidRow(style = "padding-left:25px; padding-right:25px;",
column(
width = 12,
fluidRow(
column(width = 4,
textInput("reportName", "Report Title:", value = paste0("Report_", format(Sys.time(), "%Y-%m-%d_%H:%M:%S")), width = '125%')
),
column(
width = 2,
selectInput(inputId = "fileType", label = "File Type", choices = c("html", "pdf", "docx"))
),
column(id = "pdf_layout",
width = 2,
selectInput(inputId = "pageLayout", label = "Page Layout", choices = c("Portrait", "Landscape"))
) %>% shinyjs::hidden(),
column(
width = 2, style = "padding-left: 10px; padding-right: 10px;",
div(style = "padding-top: 2rem;",
checkboxInput(inputId = "isAutoFormat", label = "Auto Format", value = TRUE)
)
),
column(
width = 2,
div(style = "padding-top: 2rem;",
checkboxInput(inputId = "includeAppendix", label = "Appendix", value = TRUE)
)
)
),
fluidRow(id = "pdf_options",
column(
width = 2,
numericInput(inputId = "marginLeft", label = "Margin Left (unit: cm)", min = 1, max = 10, value = 3, step = 1)
),
column(
width = 2,
numericInput(inputId = "marginRight", label = "Margin Right (unit: cm)", min = 1, max = 10, value = 3, step = 1)
),
column(
width = 2,
numericInput(inputId = "marginTop", label = "Margin Top (unit: cm)", min = 1, max = 10, value = 2, step = 1)
),
column(
width = 2,
numericInput(inputId = "marginBottom", label = "Margin Bottom (unit: cm)", min = 1, max = 10, value = 2, step = 1)
)
) %>% shinyjs::hidden()
)
),
div(id = "customReportDraggable",
uiOutput("selectReport")
) %>% shinyjs::hidden(),
fluidRow(
column(
width = 10, offset = 2,
uiOutput("report_download_buttons")
)
)
)
)
)
)
)
),
# 5.0 Footer ----
certara_footer(url = 'https://certara.github.io/R-DarwinReporter/')
)
runApp(
shinyApp(ui = ui, server = server),
launch.browser = TRUE
)
}
Try the Certara.DarwinReporter package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.