Nothing
R/shinyResults.R
In Certara.ModelResults: Generate Diagnostics for Pharmacometric Models Using 'shiny'
Defines functions
.run_shinyResults
pirana_run_model_results
update_tagged
resultsUI
Documented in
resultsUI
#' 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 model A single object, vector, or list of objects of class \code{NlmePmlModel}.
#' @param xpdb A single object or list of objects of class \code{xpose_data}.
#' @param tagged List of tagged objects returned from previous \code{tagged <- resultsUI()} session.
#' @param settings List of settings (e.g., settings.Rds) returned from previous Shiny session.
#' @param ... Additional arguments for Pirana integration.
#'
#'
#' @examples
#' if (interactive()) {
#'
#'
#'# RsNLME
#' library(Certara.RsNLME)
#' library(Certara.ModelResults)
#'
#' model1 <- pkmodel(numCompartments = 1,
#' data = pkData,
#' ID = "Subject",
#' Time = "Act_Time",
#' A1 = "Amount",
#' CObs = "Conc",
#' modelName = "OneCpt_IVBolus_FOCE-ELS")
#'
#' baseFitJob1 <- fitmodel(model1)
#'
#'
#' model2 <- pkmodel(numCompartments = 2,
#' data = pkData,
#' ID = "Subject",
#' Time = "Act_Time",
#' A1 = "Amount",
#' CObs = "Conc",
#' modelName = "TwCpt_IVBolus_FOCE-ELS")
#'
#' baseFitJob2 <- fitmodel(model2)
#'
#' # Run Model Results
#' resultsUI(model = c(model1, model2))
#'
#'
#' # NONMEM via xpose
#'
#' library(Certara.ModelResults)
#' library(xpose)
#'
#' xpdb <- xpose_data(
#' runno = "1",
#' prefix = "run",
#' ext = ".lst",
#' dir = "./NONMEM/Hands_onB/")
#'
#' resultsUI(xpdb = xpdb)
#'
#' # Multiple models
#'
#'xpdb_multiple <- list(
#' run1 = xpose_data(file = "run1.lst"),
#' run2 = xpose_data(file = "run2.lst"),
#' run3 = xpose_data(file = "run3.lst"),
#' run4 = xpose_data(file = "run4.lst")
#')
#' }
#'
#' @return If \code{interactive()}, returns a list of tagged diagnostics from the Shiny application, otherwise returns \code{TRUE}.
#' @export
#'
resultsUI <- function(model, xpdb = NULL, tagged = NULL, settings = NULL, ...) {
arg_list <- as.list(substitute(list(...)))
isPirana <- arg_list$pirana
if (!is.null(isPirana)) {
if(isPirana){
script_path <- eval(arg_list$script_path, envir = model_results_env)
pirana <- TRUE
} else {
pirana <- FALSE
script_path <- NULL
}
} else {
pirana <- FALSE
script_path <- NULL
}
model_name <- NULL
xpdb_name <- deparse(substitute(xpdb))
if(missing(model)){
if(is.null(xpdb)){
stop("Must specify xpdb if model argument empty")
} else {
if(class(xpdb)[[1]] == "list"){
stopifnot(any(lapply(xpdb, function(x) is.xpdb(x)) == TRUE))
software <- unique(unlist(lapply(xpdb, 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"
} else {
stopifnot(is.xpdb(xpdb))
mname <- xpdb$summary[xpdb$summary$label == "run", "value"][[1]]
software <- xpdb$summary[xpdb$summary$label == "software", "value"][[1]]
if(!(software %in% c("nonmem", "phx/nlme"))){
stop("software must be one of 'nonmem' or 'phx/nlme', please check xbdb$summary")
}
xpdb <- list(xpdb)
names(xpdb) <- mname
init_arg_type <- "xpdb_single"
}
}
hasResetInfo <- TRUE
} else {
if(inherits(model, "list")){
stopifnot(any(lapply(model, function(x) class(x)[[1]]) == "NlmePmlModel"))
modelNames <- sapply(model, function(x) x@modelInfo@modelName)
xpdb <- lapply(model, function(x)
xposeNlme(dir = x@modelInfo@workingDir,
modelName = x@modelInfo@modelName)
)
hasResetInfo <- unlist(lapply(model, function(x) x@hasResetInfo))
names(xpdb) <- modelNames
if(grepl("c()", deparse(substitute(model)))){
init_arg_type <- "model_multiple"
} else {
init_arg_type <- "model_list"
}
} else {
stopifnot(inherits(model, "NlmePmlModel"))
modelName <- model@modelInfo@modelName
xpdb <- list(xposeNlme(dir = model@modelInfo@workingDir,
modelName = model@modelInfo@modelName)
)
hasResetInfo <- model@hasResetInfo
names(xpdb) <- modelName
init_arg_type <- "model_single"
}
software <- "phx/nlme"
if(init_arg_type == "model_list"){
model_name <- c(deparse(substitute(model)), names(model))
xpdb_name <- names(xpdb)
} else {
model_name <- deparse(substitute(model))
}
}
if(software == "nonmem"){
software <- "NONMEM"
} else {
software <- "NLME"
}
if (is.null(settings)) {
settings <- initialize_settings
} else {
settings <- modifyList(initialize_settings, settings)
}
tagged_diagnostics <- .run_shinyResults(xpdb = xpdb, tagged = tagged, software = software,
model_name = model_name, xpdb_name = xpdb_name,
init_arg_type = init_arg_type, hasResetInfo = hasResetInfo,
settings = settings, pirana = pirana, script_path = script_path)
if (interactive()) {
return(invisible(tagged_diagnostics))
} else {
return(TRUE)
}
}
update_tagged <- function(object, xpdb, obj, type, code, run){
object$xpdb <- xpdb
object$obj <- obj
object$type <- type
object$code <- code
object$run <- run
return(object)
}
pirana_run_model_results <- function(script_path, settings_path = NULL, tagged_path = NULL) {
stopifnot(file.exists(script_path))
if(!is.null(settings_path)){
stopifnot(file.exists(settings_path))
settings <- readRDS(settings_path)
} else {
settings <- NULL
}
if(!is.null(tagged_path)){
stopifnot(file.exists(tagged_path))
tagged_lines <- readLines(tagged_path)
tagged <- list()
for(i in seq_along(tagged_lines)){
tagged[[i]] <- readRDS(tagged_lines[[i]])
}
tagged <- rlang::flatten(tagged)
} else {
tagged <- NULL
}
source(script_path)
assign("script_path", value = script_path, envir = model_results_env)
resultsUI(xpdb = xpdb, settings = settings, tagged = tagged, pirana = TRUE, script_path = script_path)
}
#' @rawNamespace import(shiny, except = c(runExample, dataTableOutput, renderDataTable))
#' @importFrom magrittr %>%
#' @rawNamespace import(dplyr, except = c(between, first, last))
#' @import ggplot2
#' @import flextable
#' @import bslib
#' @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
#'
.run_shinyResults <- function(xpdb, tagged = NULL, software = NULL, model_name = NULL, xpdb_name = NULL, init_arg_type = NULL, hasResetInfo = FALSE, settings = NULL, pirana = FALSE, script_path = NULL) {
# Setup tree
if(software == "NLME"){
resultsTreeList <- resultsTreeListNLME
} else {
resultsTreeList <- resultsTreeListNONMEM
}
plot_desc_location <- system.file("extdata","plot_desc.csv",package="Certara.ModelResults")
plot_desc <- read.csv(plot_desc_location)
server <- function(input, output, session) {
if(pirana) {
script_path <- get("script_path", envir = model_results_env)
}
# 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())
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 ----
## Checkbox style 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 {
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) return()
#TO DO, find out what tree structure is when only node is clicked...
if(reactiveSelections$value$tree %in% table_trees){
shinyjs::hide("main_plot_preview")
shinyjs::hide("plottabs")
shinyjs::show("main_table_preview")
} else {
shinyjs::hide("main_table_preview")
shinyjs::show("main_plot_preview")
shinyjs::show("plottabs")
}
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, "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", "Select Covariate", choices = reactiveSelections$value$covariates, selected = reactiveSelections$value$selected_cov)
)
})
# UI: Save Plot Name ----
output$userPlotName <- renderUI({
textInput("plotName", label = "Name", value = paste(input$selectedModel, reactiveSelections$value$tree, sep = " - "))
})
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 <- ""
return()
}
if (treeSelected %in% branches) {
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,
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 == "Overall"){
cols <- colsOverallNONMEM
} else if (treeSelected %in% c("Theta", "Secondary")){
cols <- colsPrmNONMEM[-c(8,10,11, 12)]
} else {
cols <- colsPrmNONMEM
}
} 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
}
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
)
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%`})
})
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(style = "padding-left: 1rem; padding-right: 1rem;",
div(
h4("Rename/Reorder Columns"),
h5("Drag below inputs to reorder table columns"),
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")
}
})
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]
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(mainTable())
mainTable() %>%
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)
}
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)
} 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)
}
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)
}
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", "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 ----
## 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 <- eventReactive(list(input$plotName, input$open_savePlotModal), {
validate(
need(!(input$plotName %in% names(taggedDiagnostics$values)),
"Warning: Tagged diagnostic name already exists and will be overwritten"
)
)
}, ignoreNULL = FALSE)
output$userPlotDup <- renderPrint({
dupTaggedValidation()
})
outputOptions(output, "userPlotDup", suspendWhenHidden = FALSE)
## 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({
if(length(names(taggedDiagnostics$values)) == 0){
shinyjs::hide("md_code")
} else {
shinyjs::show("md_code")
}
})
# 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.ModelResults)",
"library(Certara.Xpose.NLME)",
"library(xpose)",
"library(ggplot2)",
"library(dplyr)",
"library(tidyr)",
"library(magrittr)",
"library(flextable)\n")
libs <- paste0(libs, collapse = "\n")
code <- lapply(tagged, function(x) x$code)
if(pirana){
pirana_init <- readLines(script_path)
} else {
pirana_init <- NULL
}
if(init_arg_type %in% c("model_multiple", "model_single", "model_list")){
init <- gen_xpdb_code(model_name, names(xpdb), init_arg_type)
} else if (init_arg_type == "xpdb_single") {
init <- gen_xpdb_list(names(xpdb), xpdb_name)
} else {
init <- NULL
}
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
)
)
root <- get_dir_from_script(pirana_init)
pirana_scripts <- file.path(root, "pirana_scripts")
if(!dir.exists(pirana_scripts)){
dir.create(pirana_scripts)
}
writeLines(unlist(c(pirana_init, libs, init, code)), con = paste0(pirana_scripts, "/", input$nameTaggedScript,".R"))
}
writeLines(unlist(c(pirana_init, libs, init, code)), con = file)
}
)
#Generate Rmd ----
output$generateRmd <- downloadHandler(
filename = function(){
paste(input$reportName, "Rmd", sep = ".")
},
content = function(file) {
if(pirana){
pirana_init <- readLines(script_path)
} else {
pirana_init <- NULL
}
if(init_arg_type %in% c("model_multiple", "model_single", "model_list")){
init <- gen_xpdb_code(model_name, names(xpdb), init_arg_type)
} else if (init_arg_type == "xpdb_single") {
init <- gen_xpdb_list(names(xpdb), xpdb_name)
} else {
init <- NULL
}
rmd <- create_rmd_raw(title = input$reportName, objects = taggedDiagnostics$values[input$rank_list_2], orientation = input$pageLayout,
marginLeft = input$marginLeft, marginRight = input$marginRight, marginTop = input$marginTop, marginBottom = input$marginBottom,
init = c(pirana_init, init)) #if missing directory argument uses wd
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
)
)
root <- get_dir_from_script(pirana_init)
pirana_scripts <- file.path(root, "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
})
# Need function to dynamically generate r markdown doc chunks given n elements in input$ranklist2
#or
#edit r mardownk to take in plot list and plot all values in single code chunk
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(title = input$reportName, objects = taggedDiagnostics$values[input$rank_list_2], orientation = input$pageLayout,
marginLeft = input$marginLeft, marginRight = input$marginRight, marginTop = input$marginTop, marginBottom = input$marginBottom) #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.ModelResults", mustWork = TRUE)
file.copy("report_template.Rmd", tempReport, overwrite = TRUE)
file.copy(wordTemplate, tempReportWord, overwrite = TRUE)
# Set up parameters to pass to Rmd document
params <- list(inputs = taggedDiagnostics$values[input$rank_list_2])
# 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)
})
}
)
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;")
),
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;")
)
)
}
ui
})
observeEvent(input$generateReportPirana,{
filename <- paste(input$reportName, input$fileType, sep = ".")
filename <- gsub(":", "", filename)
create_rmd(title = input$reportName, objects = taggedDiagnostics$values[input$rank_list_2], orientation = input$pageLayout,
marginLeft = input$marginLeft, marginRight = input$marginRight, marginTop = input$marginTop, marginBottom = input$marginBottom) #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.ModelResults", mustWork = TRUE)
file.copy("report_template.Rmd", tempReport, overwrite = TRUE)
file.copy(wordTemplate, tempReportWord, overwrite = TRUE)
# Set up parameters to pass to Rmd document
params <- list(inputs = taggedDiagnostics$values[input$rank_list_2])
pirana_init <- readLines(script_path)
root <- get_dir_from_script(pirana_init)
pirana_reports <- file.path(root, "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)
})
showModal(
modalDialog(
title = "File Saved",
p("Report has been saved to ./pirana_reports"),
easyClose = TRUE,
footer = NULL
)
)
})
# Model Diagnostics Tree Output ----
output$treeModelDiagnostics <- shinyTree::renderTree({
resultsTreeList
})
observeEvent(input$exitShiny, {
showModal(
modalDialog(
size = "m",
title = "Exit Model Results",
easyClose = TRUE,
fluidRow(
div(style = "padding-top: 10px;"),
column(
width = 4,
checkboxInput(inputId = "saveTaggedRds", label = "Save Tagged", value = TRUE)
),
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 Model Results"),
value = 0,
{
if(pirana){
pirana_init <- readLines(script_path)
root <- get_dir_from_script(pirana_init)
dir_out <- file.path(root, "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 ----
ui <- tagList(
## 1.0 ShinyJS ----
shinyjs::useShinyjs(),
shinyjs::extendShinyjs(
text = jsFunctions,
functions = c("closewindow")
),
tags$head(tags$style(styleCSS)),
shinyWidgets::chooseSliderSkin("Modern", color = "#0a7bc1"),
## 2.0 Header ----
certara_header(header_title = "Model Results"),
## 3.0 Page ----
bslib::page_sidebar(
window_title = "Model Results",
## 4.0 Sidebar ----
sidebar = bslib::sidebar(
width = 350,
open = TRUE,
selectInput(inputId = "selectedModel", label = "Selected Model", choices = names(xpdb), width = 300),
conditionalPanel("input.selectedPlotType == 'covariate_scatter' || input.selectedPlotType == 'covariate_box'",
uiOutput("covSelection")
),
div(style = "padding: 10px;"),
div(style='height:500px; 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;"),
# verbatimTextOutput("sel_names"),
# verbatimTextOutput("sel_slices"),
# verbatimTextOutput("sel_classid"),
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")
)
),
## 5.0 Main Body Card ----
bslib::navset_card_underline(
id = "maincard",
title = NULL,
### 5.1 Preview Tab ----
bslib::nav_panel(
title = "Preview",
bslib::card_body(
height = "100%",
class = "preview-tab",
#### 5.1a Plot Display ----
div(
id = "main_plot_preview",
div(style = "padding-left: 15px; padding-bottom: 10px;",
checkboxInput(inputId = "isDynamic", label = "Interactive", value = FALSE)
),
div(
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")
)
)
)
)
),
#### 5.1b Table Display ----
div(
id = "main_table_preview",
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"),
div(style = "padding: 3px;" ),
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"), width = "125%")
),
column(width = 4, class = "col-checkbox",
checkboxInput(inputId = "isTableCaption", label = "Add Table Caption", value = TRUE)
),
column(width = 4, class = "col-checkbox",
checkboxInput(inputId = "isTableFooter", label = "Add Table Footer", 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(),
# uiOutput("previewTable"),
#### 5.1c Plot Options ----
conditionalPanel("input.selectedPlotType != 'none'",
div(id = "plottabs", # class = "ptab",
bslib::navset_card_underline(
##### Style Sub-Tab ----
bslib::nav_panel(
title = shiny::HTML(paste0('<i class="fa-solid fa-paint-roller"></i>  Style')),
bslib::card_body(
class = "style-subtab",
###### Scatter / Cov-Scatter ----
conditionalPanel("input.selectedPlotType == 'scatter' || input.selectedPlotType == 'covariate_scatter'",
fluidRow(style = "padding-top :10px;",
column(
width = 2,
offset = 1,
checkboxInput(inputId = "displayPoints", "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", "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", "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", "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", "Ref. Line", value = TRUE),
div(class = "custom_style_ref_line",
selectInput(inputId = "typeLineGuide", "Ref. Line Type", choices = c("blank", "solid", "dashed", "dotted", "dotdash", "longdash", "twodash"), selected = settings$guide.line.type),
numericInput(inputId = "sizeLineGuide", "Ref. Line Size", min = 0, max = 10, step = .1, value = settings$guide.line.size),
colourInput("colorLineGuide", "Ref. Line Color", value = settings$guide.line.color),
sliderInput("alphaLineGuide", "Ref. Line Transparency", min = 0, max = 100, value = settings$guide.line.alpha, post = "%", ticks = FALSE)
)
),
column(
width = 2,
checkboxInput(inputId = "displaySmoothing", "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", "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", "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", "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", "Histogram", value = TRUE),
div(class = "custom_style_histogram",
numericInput(inputId = "nbinsHistogram", "Histogram N Bins", min = 1, max = 100, value = settings$hist.nbins, step = 1),
selectInput(inputId = "typeLineHistogram", "Histogram Line Type", choices = c("blank", "solid", "dashed", "dotted", "dotdash", "longdash", "twodash"), selected = settings$hist.line.type),
numericInput(inputId = "sizeHistogram", "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", "Density", value = FALSE),
div(class = "custom_style_density",
selectInput(inputId = "typeLineDensity", "Density Line Type", choices = c("blank", "solid", "dashed", "dotted", "dotdash", "longdash", "twodash"), selected = settings$density.line.type),
numericInput(inputId = "sizeDensity", "Density Line Size", min = 0, max = 100, value = settings$density.size, step = 1),
colourInput("colorDensity", "Density Line Color", value = settings$density.line.color),
div(style = "padding: 0.12rem;"),
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", "Rug", value = TRUE),
div(class = "custom_style_rug",
selectInput(inputId = "positionRug", "Rug Sides", choices = c("bottom", "top", "both"), selected = settings$rug.sides),
numericInput(inputId = "sizeLineRug", "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", "Outlier Shape", choices = c("circle-fill", "circle", "square-fill", "square", "triangle-fill", "triangle"), selected = settings$outlier.shape),
numericInput(inputId = "sizeOutlier", "Outlier Size", min = 0, max = 100, value = 1, step = settings$outlier.size),
colourInput("colorOutlier", "Outlier Color", value = settings$outlier.color),
sliderInput("alphaOutlier", "Outlier Transparency", min = 0, max = 100, value = settings$outlier.alpha, post = "%", ticks = FALSE)
)
)
)
)
)
),
##### Layout Sub-Tab ----
bslib::nav_panel(
title = shiny::HTML(paste0('<i class="fa-solid fa-table-cells"></i>  Layout')),
bslib::card_body(
class = "layout-subtab",
min_height = "220px",
fluidRow(class = "multi-input-with-checkbox",
column(
width = 2,
selectInput(inputId = "selectedFacet", "Select Facet", choices = c("none"))
),
column(
width = 2,
selectInput(inputId = "selectedAxisScale", "Axis Scale", choices = c("free", "fixed"), selected = settings$axis.scale)
),
column(class = "col-checkbox",
width = 2,
checkboxInput(inputId = "isLogX", "x-axis log", value = FALSE)
),
column(class = "col-checkbox",
width = 2,
checkboxInput(inputId = "isLogY", "y-axis log", value = FALSE)
),
column(class = "col-checkbox",
width = 2,
checkboxInput(inputId = "isDefaultArrangement", "Default Arrangement", value = TRUE),
),
column(class = "col-checkbox",
width = 2,
checkboxInput(inputId = "isExtraHlines", "Additional Ref Lines", value = FALSE),
)
),
fluidRow(
column(class = "custom_facet_arrangement",
width = 2, offset = 8,
numericInput(inputId = "arrangeRowNum", "Number of Rows", value = settings$arrange.nrow, min = 1, max = 100),
numericInput(inputId = "arrangeColNum", "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", "Line 1: Y = ", value = settings$guide.line.extra.y1, min = NA, max = NA),
numericInput(inputId = "hLine2", "Line 2: Y =", value = settings$guide.line.extra.y2, min = NA, max = NA)
)
)
)
),
##### 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", "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",
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")
)
),
column(class = "custom_plot_theme_inputs",
width = 2,
numericInput(inputId = "sizeTitle", "Title Size", min = 1, max = 30, value = settings$title.size, step = 1),
selectInput(inputId = "fontTitle", "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", "Title Face", choices = c("plain", "bold", "italic", "bold.italic"), selected = settings$title.face),
),
column(class = "custom_plot_theme_inputs",
width = 2,
numericInput(inputId = "sizeSubtitle", "Subtitle Size", min = 1, max = 30, value = settings$subtitle.size, step = 1),
selectInput(inputId = "fontSubtitle", "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", "Subtitle Face", choices = c("plain", "bold", "italic", "bold.italic"), selected = settings$subtitle.face)
),
column(class = "custom_plot_theme_inputs",
width = 2,
numericInput(inputId = "sizeCaption", "Caption Size", min = 1, max = 30, value = settings$caption.size, step = 1),
selectInput(inputId = "fontCaption", "Caption Font", choices = c("Times New Roman", "Arial", "Courier New"), selected = settings$caption.font),
colourInput("colorCaption", "Caption Font Color", value = settings$caption.color),
selectInput(inputId = "faceCaption", "Caption Face", choices = c("plain", "bold", "italic", "bold.italic"), selected = settings$caption.face)
),
column(class = "custom_plot_theme_inputs",
width = 2,
numericInput(inputId = "sizeAxis", "Axis Label Size", min = 1, max = 30, value = settings$axis.size, step = settings$axis.size),
selectInput(inputId = "fontAxis", "Axis Label Font", choices = c("Times New Roman", "Arial", "Courier New"), selected = settings$axis.font),
colourInput("colorAxis", "Axis Label Font Color", value = settings$axis.color),
selectInput(inputId = "faceAxis", "Axis Label Face", choices = c("plain", "bold", "italic", "bold.italic"), selected = settings$axis.face)
)
)
)
)
)
),
#### 5.1d Tag Button ----
fluidRow(
column(
width = 12,
conditionalPanel(
"input.selectedPlotType != 'none'",
actionButton(inputId = "open_savePlotModal", label = NULL, icon = icon("tag"))
)
)
)
)
)
),
### 5.2 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
)
)
),
### 5.3 Report Tab ----
bslib::nav_panel(
title = "Report",
bslib::card_body(
fluidRow(style = "padding-left:25px; padding-right:25px;",
column(
width = 12,
fluidRow(
column(
width = 4,
textInput(inputId = "reportName", "Report Title:", value = paste0("Report_", format(Sys.time(), "%Y-%m-%d_%H:%M:%S")), width = '125%')
),
column(
width = 2,
selectInput(inputId = "fileType", "File Type", choices = c("html", "pdf", "docx"))
),
column(
width = 2,
conditionalPanel("input.fileType == 'pdf'",
selectInput(inputId = "pageLayout", "Page Layout", choices = c("Portrait", "Landscape"))
)
)
),
conditionalPanel("input.fileType == 'pdf'",
fluidRow(
column(
width = 2,
numericInput(inputId = "marginLeft", "Margin Left (unit: cm)", min = 1, max = 10, value = 3, step = 1)
),
column(
width = 2,
numericInput(inputId = "marginRight", "Margin Right (unit: cm)", min = 1, max = 10, value = 3, step = 1)
),
column(
width = 2,
numericInput(inputId = "marginTop", "Margin Top (unit: cm)", min = 1, max = 10, value = 2, step = 1)
),
column(
width = 2,
numericInput(inputId = "marginBottom", "Margin Bottom (unit: cm)", min = 1, max = 10, value = 2, step = 1)
)
)
)
)
),
uiOutput("selectReport"),
fluidRow(
column(
width = 10, offset = 2,
uiOutput("report_download_buttons")
)
)
)
)
)
),
## 6.0 Footer ----
certara_footer("https://certara.github.io/R-model-results/")
)
runApp(
shinyApp(ui = ui, server = server),
launch.browser = TRUE
)
}
Try the Certara.ModelResults package in your browser
Any scripts or data that you put into this service are public.
Certara.ModelResults documentation built on April 4, 2025, 2:43 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 pirana_run_model_results update_tagged resultsUI
Documented in resultsUI
#' 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 model A single object, vector, or list of objects of class \code{NlmePmlModel}.
#' @param xpdb A single object or list of objects of class \code{xpose_data}.
#' @param tagged List of tagged objects returned from previous \code{tagged <- resultsUI()} session.
#' @param settings List of settings (e.g., settings.Rds) returned from previous Shiny session.
#' @param ... Additional arguments for Pirana integration.
#'
#'
#' @examples
#' if (interactive()) {
#'
#'
#'# RsNLME
#' library(Certara.RsNLME)
#' library(Certara.ModelResults)
#'
#' model1 <- pkmodel(numCompartments = 1,
#' data = pkData,
#' ID = "Subject",
#' Time = "Act_Time",
#' A1 = "Amount",
#' CObs = "Conc",
#' modelName = "OneCpt_IVBolus_FOCE-ELS")
#'
#' baseFitJob1 <- fitmodel(model1)
#'
#'
#' model2 <- pkmodel(numCompartments = 2,
#' data = pkData,
#' ID = "Subject",
#' Time = "Act_Time",
#' A1 = "Amount",
#' CObs = "Conc",
#' modelName = "TwCpt_IVBolus_FOCE-ELS")
#'
#' baseFitJob2 <- fitmodel(model2)
#'
#' # Run Model Results
#' resultsUI(model = c(model1, model2))
#'
#'
#' # NONMEM via xpose
#'
#' library(Certara.ModelResults)
#' library(xpose)
#'
#' xpdb <- xpose_data(
#' runno = "1",
#' prefix = "run",
#' ext = ".lst",
#' dir = "./NONMEM/Hands_onB/")
#'
#' resultsUI(xpdb = xpdb)
#'
#' # Multiple models
#'
#'xpdb_multiple <- list(
#' run1 = xpose_data(file = "run1.lst"),
#' run2 = xpose_data(file = "run2.lst"),
#' run3 = xpose_data(file = "run3.lst"),
#' run4 = xpose_data(file = "run4.lst")
#')
#' }
#'
#' @return If \code{interactive()}, returns a list of tagged diagnostics from the Shiny application, otherwise returns \code{TRUE}.
#' @export
#'
resultsUI <- function(model, xpdb = NULL, tagged = NULL, settings = NULL, ...) {
arg_list <- as.list(substitute(list(...)))
isPirana <- arg_list$pirana
if (!is.null(isPirana)) {
if(isPirana){
script_path <- eval(arg_list$script_path, envir = model_results_env)
pirana <- TRUE
} else {
pirana <- FALSE
script_path <- NULL
}
} else {
pirana <- FALSE
script_path <- NULL
}
model_name <- NULL
xpdb_name <- deparse(substitute(xpdb))
if(missing(model)){
if(is.null(xpdb)){
stop("Must specify xpdb if model argument empty")
} else {
if(class(xpdb)[[1]] == "list"){
stopifnot(any(lapply(xpdb, function(x) is.xpdb(x)) == TRUE))
software <- unique(unlist(lapply(xpdb, 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"
} else {
stopifnot(is.xpdb(xpdb))
mname <- xpdb$summary[xpdb$summary$label == "run", "value"][[1]]
software <- xpdb$summary[xpdb$summary$label == "software", "value"][[1]]
if(!(software %in% c("nonmem", "phx/nlme"))){
stop("software must be one of 'nonmem' or 'phx/nlme', please check xbdb$summary")
}
xpdb <- list(xpdb)
names(xpdb) <- mname
init_arg_type <- "xpdb_single"
}
}
hasResetInfo <- TRUE
} else {
if(inherits(model, "list")){
stopifnot(any(lapply(model, function(x) class(x)[[1]]) == "NlmePmlModel"))
modelNames <- sapply(model, function(x) x@modelInfo@modelName)
xpdb <- lapply(model, function(x)
xposeNlme(dir = x@modelInfo@workingDir,
modelName = x@modelInfo@modelName)
)
hasResetInfo <- unlist(lapply(model, function(x) x@hasResetInfo))
names(xpdb) <- modelNames
if(grepl("c()", deparse(substitute(model)))){
init_arg_type <- "model_multiple"
} else {
init_arg_type <- "model_list"
}
} else {
stopifnot(inherits(model, "NlmePmlModel"))
modelName <- model@modelInfo@modelName
xpdb <- list(xposeNlme(dir = model@modelInfo@workingDir,
modelName = model@modelInfo@modelName)
)
hasResetInfo <- model@hasResetInfo
names(xpdb) <- modelName
init_arg_type <- "model_single"
}
software <- "phx/nlme"
if(init_arg_type == "model_list"){
model_name <- c(deparse(substitute(model)), names(model))
xpdb_name <- names(xpdb)
} else {
model_name <- deparse(substitute(model))
}
}
if(software == "nonmem"){
software <- "NONMEM"
} else {
software <- "NLME"
}
if (is.null(settings)) {
settings <- initialize_settings
} else {
settings <- modifyList(initialize_settings, settings)
}
tagged_diagnostics <- .run_shinyResults(xpdb = xpdb, tagged = tagged, software = software,
model_name = model_name, xpdb_name = xpdb_name,
init_arg_type = init_arg_type, hasResetInfo = hasResetInfo,
settings = settings, pirana = pirana, script_path = script_path)
if (interactive()) {
return(invisible(tagged_diagnostics))
} else {
return(TRUE)
}
}
update_tagged <- function(object, xpdb, obj, type, code, run){
object$xpdb <- xpdb
object$obj <- obj
object$type <- type
object$code <- code
object$run <- run
return(object)
}
pirana_run_model_results <- function(script_path, settings_path = NULL, tagged_path = NULL) {
stopifnot(file.exists(script_path))
if(!is.null(settings_path)){
stopifnot(file.exists(settings_path))
settings <- readRDS(settings_path)
} else {
settings <- NULL
}
if(!is.null(tagged_path)){
stopifnot(file.exists(tagged_path))
tagged_lines <- readLines(tagged_path)
tagged <- list()
for(i in seq_along(tagged_lines)){
tagged[[i]] <- readRDS(tagged_lines[[i]])
}
tagged <- rlang::flatten(tagged)
} else {
tagged <- NULL
}
source(script_path)
assign("script_path", value = script_path, envir = model_results_env)
resultsUI(xpdb = xpdb, settings = settings, tagged = tagged, pirana = TRUE, script_path = script_path)
}
#' @rawNamespace import(shiny, except = c(runExample, dataTableOutput, renderDataTable))
#' @importFrom magrittr %>%
#' @rawNamespace import(dplyr, except = c(between, first, last))
#' @import ggplot2
#' @import flextable
#' @import bslib
#' @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
#'
.run_shinyResults <- function(xpdb, tagged = NULL, software = NULL, model_name = NULL, xpdb_name = NULL, init_arg_type = NULL, hasResetInfo = FALSE, settings = NULL, pirana = FALSE, script_path = NULL) {
# Setup tree
if(software == "NLME"){
resultsTreeList <- resultsTreeListNLME
} else {
resultsTreeList <- resultsTreeListNONMEM
}
plot_desc_location <- system.file("extdata","plot_desc.csv",package="Certara.ModelResults")
plot_desc <- read.csv(plot_desc_location)
server <- function(input, output, session) {
if(pirana) {
script_path <- get("script_path", envir = model_results_env)
}
# 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())
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 ----
## Checkbox style 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 {
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) return()
#TO DO, find out what tree structure is when only node is clicked...
if(reactiveSelections$value$tree %in% table_trees){
shinyjs::hide("main_plot_preview")
shinyjs::hide("plottabs")
shinyjs::show("main_table_preview")
} else {
shinyjs::hide("main_table_preview")
shinyjs::show("main_plot_preview")
shinyjs::show("plottabs")
}
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, "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", "Select Covariate", choices = reactiveSelections$value$covariates, selected = reactiveSelections$value$selected_cov)
)
})
# UI: Save Plot Name ----
output$userPlotName <- renderUI({
textInput("plotName", label = "Name", value = paste(input$selectedModel, reactiveSelections$value$tree, sep = " - "))
})
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 <- ""
return()
}
if (treeSelected %in% branches) {
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,
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 == "Overall"){
cols <- colsOverallNONMEM
} else if (treeSelected %in% c("Theta", "Secondary")){
cols <- colsPrmNONMEM[-c(8,10,11, 12)]
} else {
cols <- colsPrmNONMEM
}
} 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
}
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
)
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%`})
})
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(style = "padding-left: 1rem; padding-right: 1rem;",
div(
h4("Rename/Reorder Columns"),
h5("Drag below inputs to reorder table columns"),
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")
}
})
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]
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(mainTable())
mainTable() %>%
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)
}
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)
} 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)
}
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)
}
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", "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 ----
## 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 <- eventReactive(list(input$plotName, input$open_savePlotModal), {
validate(
need(!(input$plotName %in% names(taggedDiagnostics$values)),
"Warning: Tagged diagnostic name already exists and will be overwritten"
)
)
}, ignoreNULL = FALSE)
output$userPlotDup <- renderPrint({
dupTaggedValidation()
})
outputOptions(output, "userPlotDup", suspendWhenHidden = FALSE)
## 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({
if(length(names(taggedDiagnostics$values)) == 0){
shinyjs::hide("md_code")
} else {
shinyjs::show("md_code")
}
})
# 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.ModelResults)",
"library(Certara.Xpose.NLME)",
"library(xpose)",
"library(ggplot2)",
"library(dplyr)",
"library(tidyr)",
"library(magrittr)",
"library(flextable)\n")
libs <- paste0(libs, collapse = "\n")
code <- lapply(tagged, function(x) x$code)
if(pirana){
pirana_init <- readLines(script_path)
} else {
pirana_init <- NULL
}
if(init_arg_type %in% c("model_multiple", "model_single", "model_list")){
init <- gen_xpdb_code(model_name, names(xpdb), init_arg_type)
} else if (init_arg_type == "xpdb_single") {
init <- gen_xpdb_list(names(xpdb), xpdb_name)
} else {
init <- NULL
}
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
)
)
root <- get_dir_from_script(pirana_init)
pirana_scripts <- file.path(root, "pirana_scripts")
if(!dir.exists(pirana_scripts)){
dir.create(pirana_scripts)
}
writeLines(unlist(c(pirana_init, libs, init, code)), con = paste0(pirana_scripts, "/", input$nameTaggedScript,".R"))
}
writeLines(unlist(c(pirana_init, libs, init, code)), con = file)
}
)
#Generate Rmd ----
output$generateRmd <- downloadHandler(
filename = function(){
paste(input$reportName, "Rmd", sep = ".")
},
content = function(file) {
if(pirana){
pirana_init <- readLines(script_path)
} else {
pirana_init <- NULL
}
if(init_arg_type %in% c("model_multiple", "model_single", "model_list")){
init <- gen_xpdb_code(model_name, names(xpdb), init_arg_type)
} else if (init_arg_type == "xpdb_single") {
init <- gen_xpdb_list(names(xpdb), xpdb_name)
} else {
init <- NULL
}
rmd <- create_rmd_raw(title = input$reportName, objects = taggedDiagnostics$values[input$rank_list_2], orientation = input$pageLayout,
marginLeft = input$marginLeft, marginRight = input$marginRight, marginTop = input$marginTop, marginBottom = input$marginBottom,
init = c(pirana_init, init)) #if missing directory argument uses wd
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
)
)
root <- get_dir_from_script(pirana_init)
pirana_scripts <- file.path(root, "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
})
# Need function to dynamically generate r markdown doc chunks given n elements in input$ranklist2
#or
#edit r mardownk to take in plot list and plot all values in single code chunk
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(title = input$reportName, objects = taggedDiagnostics$values[input$rank_list_2], orientation = input$pageLayout,
marginLeft = input$marginLeft, marginRight = input$marginRight, marginTop = input$marginTop, marginBottom = input$marginBottom) #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.ModelResults", mustWork = TRUE)
file.copy("report_template.Rmd", tempReport, overwrite = TRUE)
file.copy(wordTemplate, tempReportWord, overwrite = TRUE)
# Set up parameters to pass to Rmd document
params <- list(inputs = taggedDiagnostics$values[input$rank_list_2])
# 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)
})
}
)
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;")
),
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;")
)
)
}
ui
})
observeEvent(input$generateReportPirana,{
filename <- paste(input$reportName, input$fileType, sep = ".")
filename <- gsub(":", "", filename)
create_rmd(title = input$reportName, objects = taggedDiagnostics$values[input$rank_list_2], orientation = input$pageLayout,
marginLeft = input$marginLeft, marginRight = input$marginRight, marginTop = input$marginTop, marginBottom = input$marginBottom) #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.ModelResults", mustWork = TRUE)
file.copy("report_template.Rmd", tempReport, overwrite = TRUE)
file.copy(wordTemplate, tempReportWord, overwrite = TRUE)
# Set up parameters to pass to Rmd document
params <- list(inputs = taggedDiagnostics$values[input$rank_list_2])
pirana_init <- readLines(script_path)
root <- get_dir_from_script(pirana_init)
pirana_reports <- file.path(root, "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)
})
showModal(
modalDialog(
title = "File Saved",
p("Report has been saved to ./pirana_reports"),
easyClose = TRUE,
footer = NULL
)
)
})
# Model Diagnostics Tree Output ----
output$treeModelDiagnostics <- shinyTree::renderTree({
resultsTreeList
})
observeEvent(input$exitShiny, {
showModal(
modalDialog(
size = "m",
title = "Exit Model Results",
easyClose = TRUE,
fluidRow(
div(style = "padding-top: 10px;"),
column(
width = 4,
checkboxInput(inputId = "saveTaggedRds", label = "Save Tagged", value = TRUE)
),
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 Model Results"),
value = 0,
{
if(pirana){
pirana_init <- readLines(script_path)
root <- get_dir_from_script(pirana_init)
dir_out <- file.path(root, "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 ----
ui <- tagList(
## 1.0 ShinyJS ----
shinyjs::useShinyjs(),
shinyjs::extendShinyjs(
text = jsFunctions,
functions = c("closewindow")
),
tags$head(tags$style(styleCSS)),
shinyWidgets::chooseSliderSkin("Modern", color = "#0a7bc1"),
## 2.0 Header ----
certara_header(header_title = "Model Results"),
## 3.0 Page ----
bslib::page_sidebar(
window_title = "Model Results",
## 4.0 Sidebar ----
sidebar = bslib::sidebar(
width = 350,
open = TRUE,
selectInput(inputId = "selectedModel", label = "Selected Model", choices = names(xpdb), width = 300),
conditionalPanel("input.selectedPlotType == 'covariate_scatter' || input.selectedPlotType == 'covariate_box'",
uiOutput("covSelection")
),
div(style = "padding: 10px;"),
div(style='height:500px; 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;"),
# verbatimTextOutput("sel_names"),
# verbatimTextOutput("sel_slices"),
# verbatimTextOutput("sel_classid"),
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")
)
),
## 5.0 Main Body Card ----
bslib::navset_card_underline(
id = "maincard",
title = NULL,
### 5.1 Preview Tab ----
bslib::nav_panel(
title = "Preview",
bslib::card_body(
height = "100%",
class = "preview-tab",
#### 5.1a Plot Display ----
div(
id = "main_plot_preview",
div(style = "padding-left: 15px; padding-bottom: 10px;",
checkboxInput(inputId = "isDynamic", label = "Interactive", value = FALSE)
),
div(
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")
)
)
)
)
),
#### 5.1b Table Display ----
div(
id = "main_table_preview",
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"),
div(style = "padding: 3px;" ),
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"), width = "125%")
),
column(width = 4, class = "col-checkbox",
checkboxInput(inputId = "isTableCaption", label = "Add Table Caption", value = TRUE)
),
column(width = 4, class = "col-checkbox",
checkboxInput(inputId = "isTableFooter", label = "Add Table Footer", 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(),
# uiOutput("previewTable"),
#### 5.1c Plot Options ----
conditionalPanel("input.selectedPlotType != 'none'",
div(id = "plottabs", # class = "ptab",
bslib::navset_card_underline(
##### Style Sub-Tab ----
bslib::nav_panel(
title = shiny::HTML(paste0('<i class="fa-solid fa-paint-roller"></i>  Style')),
bslib::card_body(
class = "style-subtab",
###### Scatter / Cov-Scatter ----
conditionalPanel("input.selectedPlotType == 'scatter' || input.selectedPlotType == 'covariate_scatter'",
fluidRow(style = "padding-top :10px;",
column(
width = 2,
offset = 1,
checkboxInput(inputId = "displayPoints", "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", "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", "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", "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", "Ref. Line", value = TRUE),
div(class = "custom_style_ref_line",
selectInput(inputId = "typeLineGuide", "Ref. Line Type", choices = c("blank", "solid", "dashed", "dotted", "dotdash", "longdash", "twodash"), selected = settings$guide.line.type),
numericInput(inputId = "sizeLineGuide", "Ref. Line Size", min = 0, max = 10, step = .1, value = settings$guide.line.size),
colourInput("colorLineGuide", "Ref. Line Color", value = settings$guide.line.color),
sliderInput("alphaLineGuide", "Ref. Line Transparency", min = 0, max = 100, value = settings$guide.line.alpha, post = "%", ticks = FALSE)
)
),
column(
width = 2,
checkboxInput(inputId = "displaySmoothing", "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", "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", "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", "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", "Histogram", value = TRUE),
div(class = "custom_style_histogram",
numericInput(inputId = "nbinsHistogram", "Histogram N Bins", min = 1, max = 100, value = settings$hist.nbins, step = 1),
selectInput(inputId = "typeLineHistogram", "Histogram Line Type", choices = c("blank", "solid", "dashed", "dotted", "dotdash", "longdash", "twodash"), selected = settings$hist.line.type),
numericInput(inputId = "sizeHistogram", "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", "Density", value = FALSE),
div(class = "custom_style_density",
selectInput(inputId = "typeLineDensity", "Density Line Type", choices = c("blank", "solid", "dashed", "dotted", "dotdash", "longdash", "twodash"), selected = settings$density.line.type),
numericInput(inputId = "sizeDensity", "Density Line Size", min = 0, max = 100, value = settings$density.size, step = 1),
colourInput("colorDensity", "Density Line Color", value = settings$density.line.color),
div(style = "padding: 0.12rem;"),
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", "Rug", value = TRUE),
div(class = "custom_style_rug",
selectInput(inputId = "positionRug", "Rug Sides", choices = c("bottom", "top", "both"), selected = settings$rug.sides),
numericInput(inputId = "sizeLineRug", "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", "Outlier Shape", choices = c("circle-fill", "circle", "square-fill", "square", "triangle-fill", "triangle"), selected = settings$outlier.shape),
numericInput(inputId = "sizeOutlier", "Outlier Size", min = 0, max = 100, value = 1, step = settings$outlier.size),
colourInput("colorOutlier", "Outlier Color", value = settings$outlier.color),
sliderInput("alphaOutlier", "Outlier Transparency", min = 0, max = 100, value = settings$outlier.alpha, post = "%", ticks = FALSE)
)
)
)
)
)
),
##### Layout Sub-Tab ----
bslib::nav_panel(
title = shiny::HTML(paste0('<i class="fa-solid fa-table-cells"></i>  Layout')),
bslib::card_body(
class = "layout-subtab",
min_height = "220px",
fluidRow(class = "multi-input-with-checkbox",
column(
width = 2,
selectInput(inputId = "selectedFacet", "Select Facet", choices = c("none"))
),
column(
width = 2,
selectInput(inputId = "selectedAxisScale", "Axis Scale", choices = c("free", "fixed"), selected = settings$axis.scale)
),
column(class = "col-checkbox",
width = 2,
checkboxInput(inputId = "isLogX", "x-axis log", value = FALSE)
),
column(class = "col-checkbox",
width = 2,
checkboxInput(inputId = "isLogY", "y-axis log", value = FALSE)
),
column(class = "col-checkbox",
width = 2,
checkboxInput(inputId = "isDefaultArrangement", "Default Arrangement", value = TRUE),
),
column(class = "col-checkbox",
width = 2,
checkboxInput(inputId = "isExtraHlines", "Additional Ref Lines", value = FALSE),
)
),
fluidRow(
column(class = "custom_facet_arrangement",
width = 2, offset = 8,
numericInput(inputId = "arrangeRowNum", "Number of Rows", value = settings$arrange.nrow, min = 1, max = 100),
numericInput(inputId = "arrangeColNum", "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", "Line 1: Y = ", value = settings$guide.line.extra.y1, min = NA, max = NA),
numericInput(inputId = "hLine2", "Line 2: Y =", value = settings$guide.line.extra.y2, min = NA, max = NA)
)
)
)
),
##### 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", "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",
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")
)
),
column(class = "custom_plot_theme_inputs",
width = 2,
numericInput(inputId = "sizeTitle", "Title Size", min = 1, max = 30, value = settings$title.size, step = 1),
selectInput(inputId = "fontTitle", "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", "Title Face", choices = c("plain", "bold", "italic", "bold.italic"), selected = settings$title.face),
),
column(class = "custom_plot_theme_inputs",
width = 2,
numericInput(inputId = "sizeSubtitle", "Subtitle Size", min = 1, max = 30, value = settings$subtitle.size, step = 1),
selectInput(inputId = "fontSubtitle", "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", "Subtitle Face", choices = c("plain", "bold", "italic", "bold.italic"), selected = settings$subtitle.face)
),
column(class = "custom_plot_theme_inputs",
width = 2,
numericInput(inputId = "sizeCaption", "Caption Size", min = 1, max = 30, value = settings$caption.size, step = 1),
selectInput(inputId = "fontCaption", "Caption Font", choices = c("Times New Roman", "Arial", "Courier New"), selected = settings$caption.font),
colourInput("colorCaption", "Caption Font Color", value = settings$caption.color),
selectInput(inputId = "faceCaption", "Caption Face", choices = c("plain", "bold", "italic", "bold.italic"), selected = settings$caption.face)
),
column(class = "custom_plot_theme_inputs",
width = 2,
numericInput(inputId = "sizeAxis", "Axis Label Size", min = 1, max = 30, value = settings$axis.size, step = settings$axis.size),
selectInput(inputId = "fontAxis", "Axis Label Font", choices = c("Times New Roman", "Arial", "Courier New"), selected = settings$axis.font),
colourInput("colorAxis", "Axis Label Font Color", value = settings$axis.color),
selectInput(inputId = "faceAxis", "Axis Label Face", choices = c("plain", "bold", "italic", "bold.italic"), selected = settings$axis.face)
)
)
)
)
)
),
#### 5.1d Tag Button ----
fluidRow(
column(
width = 12,
conditionalPanel(
"input.selectedPlotType != 'none'",
actionButton(inputId = "open_savePlotModal", label = NULL, icon = icon("tag"))
)
)
)
)
)
),
### 5.2 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
)
)
),
### 5.3 Report Tab ----
bslib::nav_panel(
title = "Report",
bslib::card_body(
fluidRow(style = "padding-left:25px; padding-right:25px;",
column(
width = 12,
fluidRow(
column(
width = 4,
textInput(inputId = "reportName", "Report Title:", value = paste0("Report_", format(Sys.time(), "%Y-%m-%d_%H:%M:%S")), width = '125%')
),
column(
width = 2,
selectInput(inputId = "fileType", "File Type", choices = c("html", "pdf", "docx"))
),
column(
width = 2,
conditionalPanel("input.fileType == 'pdf'",
selectInput(inputId = "pageLayout", "Page Layout", choices = c("Portrait", "Landscape"))
)
)
),
conditionalPanel("input.fileType == 'pdf'",
fluidRow(
column(
width = 2,
numericInput(inputId = "marginLeft", "Margin Left (unit: cm)", min = 1, max = 10, value = 3, step = 1)
),
column(
width = 2,
numericInput(inputId = "marginRight", "Margin Right (unit: cm)", min = 1, max = 10, value = 3, step = 1)
),
column(
width = 2,
numericInput(inputId = "marginTop", "Margin Top (unit: cm)", min = 1, max = 10, value = 2, step = 1)
),
column(
width = 2,
numericInput(inputId = "marginBottom", "Margin Bottom (unit: cm)", min = 1, max = 10, value = 2, step = 1)
)
)
)
)
),
uiOutput("selectReport"),
fluidRow(
column(
width = 10, offset = 2,
uiOutput("report_download_buttons")
)
)
)
)
)
),
## 6.0 Footer ----
certara_footer("https://certara.github.io/R-model-results/")
)
runApp(
shinyApp(ui = ui, server = server),
launch.browser = TRUE
)
}
Try the Certara.ModelResults 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.