diff --git a/R/PMupdate.R b/Archived/PMupdate.R
similarity index 83%
rename from R/PMupdate.R
rename to Archived/PMupdate.R
index 954114c0..7b2ce528 100644
--- a/R/PMupdate.R
+++ b/Archived/PMupdate.R
@@ -27,12 +27,12 @@ PMupdate <- function(force = F) {
cat("You have the most current version of Pmetrics.\n")
return(invisible(FALSE))
} else {
- # check for devtools
- devtools_installed <- requireNamespace("devtools")
- if (!devtools_installed) {
- cat("The devtools package is required to install from github.\n")
+ # check for remotes
+ remotes_installed <- requireNamespace("remotes", quietly = TRUE)
+ if (!remotes_installed) {
+ cat("The remotes package is required to install from github.\n")
cat(paste0(
- "Enter ", crayon::blue("<1>"), " to install devtools or ",
+ "Enter ", crayon::blue("<1>"), " to install remotes or ",
crayon::blue("<2>"), " to abort.\n"
))
ans <- ""
@@ -40,7 +40,7 @@ PMupdate <- function(force = F) {
ans <- readline("Response: ")
}
if (ans == "1") {
- install.packages("devtools")
+ install.packages("remotes")
} else {
cat("Pmetrics update aborted.\n")
return(invisible(FALSE))
@@ -74,7 +74,7 @@ PMupdate <- function(force = F) {
# update
OS <- getOS()
if (OS != 2) { # Mac/Linux
- Pmetrics_installed <- tryCatch(devtools::install_github(repo = "LAPKB/Pmetrics", force = force),
+ Pmetrics_installed <- tryCatch(remotes::install_github(repo = "LAPKB/Pmetrics", force = force),
error = function(e) -1
)
if (Pmetrics_installed != -1) {
@@ -85,9 +85,9 @@ PMupdate <- function(force = F) {
cat(paste0(crayon::blue("NOTE: "), "Windows is unable to update loaded packages.\nPlease do the following.\n"))
cat("\n1. Paste the following into the R console: detach(\"package:Pmetrics\", unload = TRUE)\n")
if (force) {
- cat("2. Paste the following into the R console: devtools::install_packages(repo = \"LAPKB/Pmetrics\", force = T)\n")
+ cat("2. Paste the following into the R console: remotes::install_packages(repo = \"LAPKB/Pmetrics\", force = T)\n")
} else {
- cat("2. Paste the following into the R console: devtools::install_packages(repo = \"LAPKB/Pmetrics\")\n")
+ cat("2. Paste the following into the R console: remotes::install_packages(repo = \"LAPKB/Pmetrics\")\n")
}
cat("3. Allow Rstudio to restart session.\n")
cat("4. Rstudio will complete installation.\n")
diff --git a/DESCRIPTION b/DESCRIPTION
index b15e98d7..f8430479 100644
--- a/DESCRIPTION
+++ b/DESCRIPTION
@@ -17,6 +17,7 @@ Description: Parametric and non-parametric
Authors@R: c(
person("Michael", "Neely", email = "mneely@usc.edu", role = c("aut", "cre")),
person("Julián", "Otálvaro", email = "juliandavid347@gmail.com", role = "aut"),
+ person("Markus", "Hovd", email = "", role = "ctb"),
person("Walter", "Yamada", email = "", role= "ctb"),
person("Alan", "Schumitzky", email = "", role = "ctb"),
person("Rong", "Chen", email = "", role = "ctb"),
@@ -40,7 +41,6 @@ Imports:
lifecycle,
lubridate,
magrittr,
- npde,
openxlsx,
pander,
plotly,
@@ -58,13 +58,13 @@ Imports:
tidyr,
utils
Suggests:
- curl,
data.table,
devtools,
ggpubr,
htmltools,
knitr,
mclust,
+ npde,
pandoc,
patchwork,
PmetricsData,
diff --git a/NAMESPACE b/NAMESPACE
index 994e7a61..f011b970 100644
--- a/NAMESPACE
+++ b/NAMESPACE
@@ -98,16 +98,18 @@ export(ab_line)
export(add_shapes)
export(add_smooth)
export(additive)
-export(build_model)
-export(build_plot)
export(combination)
export(covariate)
export(editPMoptions)
export(errorPoly)
export(export_plotly)
export(fixed)
-export(getPMdata)
+export(getCov)
+export(getDefaultColors)
+export(getFixedColNames)
+export(getFixedColNum)
export(getPMoptions)
+export(getPalettes)
export(makeAUC)
export(makeCov)
export(makeCycle)
diff --git a/R/PMconfig.R b/R/PMconfig.R
index d1452a1d..20cf4cb7 100644
--- a/R/PMconfig.R
+++ b/R/PMconfig.R
@@ -17,6 +17,20 @@ getBits <- function() {
}
}
+# getFixedColNames ------------------------------------------------------------------
+
+#' @title Names of fixed columns
+#' @description
+#' `r lifecycle::badge("stable")`
+#'
+#' Returns the names of fixed columns (non-covariate) in Pmetrics data objects.
+#' @return A vector of fixed column names:
+#' `c("id", "evid", "time", "dur", "dose", "addl", "ii", "input", "out", "outeq", "c0", "c1", "c2", "c3")`
+#'
+#' @export
+#' @examples
+#' getFixedColNames()
+#' @author Michael Neely
getFixedColNames <- function() {
# set current names of fixed columns in data file
@@ -26,6 +40,20 @@ getFixedColNames <- function() {
)
}
+
+# getFixedColNum ------------------------------------------------------------------
+
+#' @title Number of fixed columns
+#' @description
+#' `r lifecycle::badge("stable")`
+#'
+#' Returns the number of fixed columns (non-covariate) in Pmetrics data objects.
+#' @return An integer with the number of fixed columns.
+#'
+#' @export
+#' @examples
+#' getFixedColNum()
+#' @author Michael Neely
getFixedColNum <- function() {
# set current number of fixed columns in data file
length(getFixedColNames())
diff --git a/R/PMutilities.R b/R/PMutilities.R
index f5e3ba3e..cc3d276b 100644
--- a/R/PMutilities.R
+++ b/R/PMutilities.R
@@ -1804,8 +1804,28 @@ makePMmatrixBlock <- function(mdata) {
# getCov ------------------------------------------------------------------
-# function to get covariate information from PMmatrix object
+#' @title Extract covariate information
+#' @description
+#' `r lifecycle::badge("stable")`
+#'
+#' Extracts covariate information from a Pmetrics data objects.
+#' @details
+#' When given a [PM_data] or *PMmatrix* object, will return a list
+#' with the number of covariates, their names, and the starting and
+#' ending column numbers
+#' @param mdata A [PM_data] or *PMmatrix* object
+#' @return A list with named items: *ncov, covnames, covstart, covend*.
+#'
+#' @export
+#' @examples
+#' library(PmetricsData)
+#' getCov(dataEx)
+#' @author Michael Neely
+
getCov <- function(mdata) {
+ if(inherits(mdata, "PM_data")){
+ mdata <- mdata$data
+ }
nfixed <- getFixedColNum()
ncolData <- ncol(mdata)
ncov <- ncolData - nfixed
@@ -1849,21 +1869,18 @@ getOSname <- function() {
# check for installed packages --------------------------------------------
-checkRequiredPackages <- function(pkg, repos = "CRAN") {
+checkRequiredPackages <- function(pkg, repos = "CRAN", quietly = TRUE) {
managePkgs <- function(thisPkg) {
- # if (length(grep(thisPkg, installed.packages()[, 1])) == 0) {
- # install.packages(thisPkg, dependencies = T)
- # }
- if (requireNamespace(thisPkg, quietly = T)) {
+ if (requireNamespace(thisPkg, quietly = TRUE)) {
return("ok") # package is installed
} else { # package is not installed
cat(paste0("The package ", thisPkg, " is required and will be installed.\n"))
if (repos == "CRAN") {
- install.packages(thisPkg, dependencies = T, quiet = T) # try to install
+ install.packages(thisPkg, dependencies = TRUE, verbose = FALSE, quiet = TRUE) # try to install
} else {
- devtools::install_github(repos)
+ tryCatch(remotes::install_github(repos), error = function(e) FALSE)
}
- if (requireNamespace(thisPkg, quietly = T)) { # check again
+ if (requireNamespace(thisPkg, quietly = TRUE)) { # check again
return("ok") # now it is installed and ok
} else {
return(thisPkg)
@@ -1871,13 +1888,19 @@ checkRequiredPackages <- function(pkg, repos = "CRAN") {
}
}
- pkg %>%
+ msg <- pkg %>%
map_chr(managePkgs) %>%
- keep(~ . != "ok") %>%
- map_chr(~ if (length(.) > 0) {
- stop(paste("The following required packages did not successfully install: ", ., sep = "", collapse = ", "))
- })
- return(invisible())
+ keep(~ . != "ok")
+
+ if(length(msg)>0){
+ if(!quietly){cat(crayon::red("\nError:"), "The following packages needed for this function did not install:",
+ paste(msg, collapse = ", "))
+ }
+ return(invisible(FALSE))
+ }
+ else {
+ return(invisible(TRUE)) #all packages present or installed
+ }
}
@@ -1988,20 +2011,3 @@ weighted_median <- function(values, weights) {
return(median_value)
}
-
-#' @title Get Pmetrics package example data
-#' @description
-#' `r lifecycle::badge("stable")`
-#'
-#' Get the data and examples for the Pmetrics package.
-#'
-#' @details
-#' This function installs the **PmetricsData** package available on github.
-#' The repository URL is [https://github.com/LAPKB/PmetricsData](https://github.com/LAPKB/PmetricsData). These data
-#' are used in all Pmetrics examples.
-#'
-#' @export
-getPMdata <- function(){
- remotes::install_github("LAPKB/PmetricsData")
- requireNamespace("PmetricsData")
-}
diff --git a/R/build_model.R b/R/build_model.R
deleted file mode 100644
index 0d7b860c..00000000
--- a/R/build_model.R
+++ /dev/null
@@ -1,1688 +0,0 @@
-#' Launch Model Builder app
-#'
-#' Open the shiny model builder app.
-#'
-#' @details
-#' The app will open in a separate window.
-#'
-#' @param ... Optional [PM_data] and/or [PM_model] object(s). *PM_data* objects
-#' supply covariates. *PM_model* objects supply any other defined model element,
-#' and covariates only if there is no *PM_data* object or it has no covariates.
-#' If the *PM_model* object contains covariates, they will be superseded by those in
-#' the *PM_data* object, if supplied.
-#' @return Launches the shiny app.
-#' @export
-#' @author Michael Neely
-#'
-build_model <- function(...) {
- if(!requireNamespace("shiny", quietly = TRUE)){ #suggests
- stop("The shiny package must be installed to run build_plot().\n")
- }
- if(!requireNamespace("bslib", quietly = TRUE)){ #suggests
- stop("The bslib package must be installed to run build_plot().\n")
- }
- requireNamespace("plotly") #imports
-
- obj <- list(...)
- data_arg <- purrr::detect(obj, \(x) inherits(x, "PM_data"))
- model_arg <- purrr::detect(obj, \(x) inherits(x, "PM_model"))
-
-
- # Define UI for application that draws a histogram
- shiny::shinyApp(
-
- ui <- bslib::page_fluid(
- theme = bslib::bs_theme(bootswatch = "slate"),
- title = "Pmetrics Model Builder App",
- widths = c(3, 9),
-
-
- # ui <- fluidPage(
- # theme = shinythemes::shinytheme("slate"),
- #
- # # Application title
- # titlePanel("Pmetrics Model Builder App"),
- # # Layout
-
- # Model components
- # #Formatting
- tags$head(
- tags$style(HTML(
- ".alert {padding: 20px; background-color: #F44336; color: white;}",
- ".success {padding: 20px; background-color: #04AA6D; color: white;}",
- ".info {padding: 5px 20px 5px 5px; background-color: #3498db; color: white; font-size: 16px;}",
- ".closebtn {margin-left: 12px; color: white; font-weight: bold; float: right; font-size: 22px; line-height: 20px; cursor: pointer; transition: 0.3s;}",
- ".closebtn:hover {color: black;}",
- ".btn-help {display:block; color: white; padding: 2px 10px 2px 10px; text-align: center; border-radius: 100%; border: 1px solid DodgerBlue; }"
- )),
- tags$div(HTML("
- "))
- ),
- # navlistPanel(
- bslib::navset_pill_list(
-
- "Model Components",
- widths = c(3, 9),
- # tabPanel: Model Library
- # tabPanel(
- bslib::nav_panel(
- "Model Library",
- actionButton(
- "help_library",
- "",
- icon = icon("info"),
- class = "btn-help"
- ),
- fluidRow(
- column(
- 6,
- h2("Previous Model"),
- fileInput(
- "model_file",
- "Choose prior model file",
- accept = c(".txt", "text/plain")
- ),
- ),
- column(
- 6,
- h2("Data File"),
- fileInput(
- "data_file",
- "Choose prior data file",
- accept = c(".csv", ".ssv", "text/plain")
- ),
- )
- ),
- h2("Model Library"),
- fluidRow(
- column(
- 6,
- h3("Filters"),
- selectInput(
- "mod_route",
- "Dosing route(s):",
- list("", "Oral", "Intravenous"),
- multiple = TRUE
- ),
- numericInput(
- "mod_ncomp",
- "Number of compartments (including oral bolus):",
- value = NA,
- min = 1
- ),
- selectInput(
- "mod_elim",
- "Elimination from:",
- "",
- multiple = TRUE
- ),
- radioButtons(
- "mod_kecl",
- "Parameterized as:",
- c("Rate constants", "Clearances"),
- selected = character(0)
- ),
- checkboxInput(
- "mod_alg",
- "Algebraic models only",
- value = FALSE
- )
- ),
- column(
- 6,
- h3("Description Search"),
- textInput(
- inputId = "searchme",
- label = ""
- )
- )
- ), # end fluid Row
- uiOutput("bottom_library")
- ), # end tabPanel: Model Library
- # tabPanel: Primary
- # tabPanel(
- bslib::nav_panel(
- "PRImary",
- actionButton(
- "help_pri",
- "",
- icon = icon("info"),
- class = "btn-help"
- ),
- fluidRow(
- column(4, h5("Number of primary parameters:")),
- column(4, h5("Specify as:"))
- ),
- fluidRow(
- column(
- 4,
- numericInput("nvar",
- "",
- value = 1,
- min = 1
- )
- ),
- column(
- 5,
- radioButtons("ab_msd_cv",
- "",
- choices = c("Range", "Mean/CV%", "Mean/SD"),
- inline = TRUE,
- selected = "Range"
- )
- )
- ),
- hr(style = "border-top: 1px solid #FFFFFF;"),
- uiOutput("pri_var"),
- uiOutput("bottom_pri")
- ), # end tabPanel: Primary
- # tabPanel: Covariates
-
- # tabPanel(
- bslib::nav_panel(
- "COVariates",
- actionButton(
- "help_cov",
- "",
- icon = icon("info"),
- class = "btn-help"
- ),
- uiOutput("cov"),
- uiOutput("bottom_cov"),
- ), # end tabPanel: Covariates
- # tabPanel: Secondary
- # tabPanel(
- bslib::nav_panel(
- "SECondary",
- actionButton(
- "help_sec",
- "",
- icon = icon("info"),
- class = "btn-help"
- ),
- textAreaInput("secVar",
- "Secondary variable definitions:",
- rows = NULL
- ),
- uiOutput("bottom_sec")
- ), # end tabPanel: Secondary
-
- # tabPanel(
- bslib::nav_panel(
- "INItial Conditions",
- actionButton(
- "help_ini",
- "",
- icon = icon("info"),
- class = "btn-help"
- ),
- fluidRow(
- uiOutput("ini"),
- textAreaInput("iniCond",
- "Initial conditions. Edit as necessary.",
- rows = NULL
- ),
- actionButton("reset_ini", "Reset", icon("trash"))
- ),
- uiOutput("bottom_ini")
- ), # end tabPanel: Initial Conditions
- # tabPanel: FA (bioavailability)
- # tabPanel(
- bslib::nav_panel(
- "FA (bioavailability)",
- actionButton(
- "help_fa",
- "",
- icon = icon("info"),
- class = "btn-help"
- ),
- fluidRow(
- uiOutput("fa"),
- textAreaInput("FA",
- "Bioavailability Code. Edit as necessary.",
- rows = NULL
- ),
- actionButton("reset_fa", "Reset", icon("trash"))
- ),
- uiOutput("bottom_fa")
- ), # end tabPanel: F
- # tabPanel: Lag
-
- # tabPanel(
- bslib::nav_panel(
- "LAG time",
- actionButton(
- "help_lag",
- "",
- icon = icon("info"),
- class = "btn-help"
- ),
- fluidRow(
- uiOutput("lag"),
- textAreaInput("lagTime",
- "Lag Time Code. Edit as necessary.",
- rows = NULL
- ),
- actionButton("reset_lag", "Reset", icon("trash"))
- ),
- uiOutput("bottom_lag")
- ), # end tabPanel: Lag
- # tabPanel: Equations
- # tabPanel(
- bslib::nav_panel(
- "EQuatioNs",
- actionButton(
- "help_eqn",
- "",
- icon = icon("info"),
- class = "btn-help"
- ),
- fluidRow(
- column(
- 4,
- textAreaInput("modEq",
- "Model Equations:",
- rows = NULL
- )
- ),
- textOutput("edit_eqn")
- ),
- uiOutput("bottom_eqn")
- ), # end tabPanel: Equations
- # tabPanel: Outputs
- # tabPanel(
- bslib::nav_panel(
- "OUTputs",
- actionButton(
- "help_out",
- "",
- icon = icon("info"),
- class = "btn-help"
- ),
- numericInput("nout",
- "Number of output equations:",
- value = 1,
- width = "30%"
- ),
- uiOutput("outputs"),
- uiOutput("bottom_out")
- ) # end tabPanel: Outputs
- ) # end navlistPanel
- ), # end ui
-
- server <- function(input, output, session) {
- # does object exist?
- exist_obj <- function(obj) {
- tryCatch(length(obj), error = function(e) FALSE)
- }
-
- # DECLARE GLOBAL REACTIVE VALUES
-
- # reactive value to store model made by user
- new_model <- reactiveVal()
- # a copy of new_model suitable for pasting into R
- copy_list <- reactiveVal()
-
- # create reactive model objects for model loaded as file,
- # from library, or passed as argument
- # the model itself
- model_obj <- reactiveVal()
- # the type of algebraic model
- alg_mod <- reactiveVal()
- # save the same to check if user edits restored algebraic model
- orig_model <- reactiveVal()
- orig_alg_model <- reactiveVal()
- # reactive object for data loaded from file or passed as argument
- data_obj <- reactiveVal()
- # reactive objects for covariates
- cov_names <- reactiveVal() # supplied by model or data
- cov_list <- reactiveVal() # supplied in app
- ncov <- reactiveVal()
- cov_source <- reactiveVal()
-
- # the model can be passed as an argument in build_model()
- # check if it is so and set
- if (!is.null(model_arg)) {
- model_obj(model_arg$model_list) # update global reactive value
- }
-
- # the data can be passed as an argument in build_model()
- # covariates in data will supersede covariates in model
- if (!is.null(data_arg)) {
- data_obj(data_arg) # update global
- cov_data <- getCov(data_arg$standard_data)
- if (cov_data$ncov > 0) {
- cov_names(cov_data$covnames)
- ncov(cov_data$ncov)
- ninput <- max(data_arg$standard_data$input, na.rm = TRUE)
- cov_source("Covariates obtained from data.")
- }
- } else if (!is.null(model_arg)) { # model supplied, but not data
- if (length(model_arg$model_list$cov) > 0) { # model has covariates
- cov_names(purrr::map_chr(model_arg$model_list$cov, \(x) x$covariate))
- ncov(length(model_arg$model_list$cov))
- cov_source("Covariates obtained from model, since none were in the data.")
- } else {
- cov_names(NULL)
- ncov(0)
- cov_source("No covariates available.")
- }
- ninput <- 100 # set to something ridiculous
- } else { # no data or model
- cov_names(NULL)
- ncov(0)
- ninput <- 100 # set to something ridiculous
- cov_source("No covariates available.")
- }
-
- # variables
- npar <- reactive({
- as.integer(input$nvar)
- })
- numeqt <- reactive({
- as.integer(input$nout)
- })
- blockNames <- c("pri", "cov", "sec", "bol", "ini", "fa", "lag", "eqn", "out")
-
-
- # set initial values for stored variables
- store <- reactiveValues(
- var_name_1 = "Ke",
- var_a_1 = 0,
- var_b_1 = 5,
- # var_mean_1 = 2.5,
- # var_sd_1 = 0.833,
- var_constant_1 = FALSE,
- var_gtz_1 = FALSE
- )
-
-
-
-
- # extract secondary variables
- extract_sec <- reactive({
- if (input$secVar != "") {
- purrr::map(input$secVar, function(x) {
- eqn <- parse(text = x)
- dplyr::case_when(
- class(eqn[[1]]) == "=" ~ deparse(eqn[[1]][[2]]),
- class(eqn[[1]]) == "if" ~ deparse(eqn[[1]][[3]][[2]])
- )
- })
- } else {
- ""
- }
- })
-
- # process reset buttons
- observeEvent(input$reset_ini, {
- updateSelectizeInput(
- inputId = "special_ini",
- selected = ""
- )
- })
- observeEvent(input$reset_ini, {
- updateTextAreaInput(
- inputId = "iniCond",
- value = ""
- )
- })
-
- observeEvent(input$reset_fa, {
- updateSelectizeInput(
- inputId = "special_fa",
- selected = ""
- )
- })
- observeEvent(input$reset_fa, {
- updateTextAreaInput(
- inputId = "FA",
- value = ""
- )
- })
-
- observeEvent(input$reset_lag, {
- updateSelectizeInput(
- inputId = "special_lag",
- selected = ""
- )
- })
- observeEvent(input$reset_lag, {
- updateTextAreaInput(
- inputId = "lagTime",
- value = ""
- )
- })
-
-
-
-
-
-
-
- # MODEL LIBRARY COMPONENT -------------------------------------------------
-
-
- mods <- modelLibrary
-
- # create the global filter results
- mods_filter <- reactiveVal()
-
- # make combined filter trigger
- filter_obj <- reactive({
- list(
- input$mod_route, input$mod_ncomp, input$mod_elim, input$mod_kecl,
- input$mod_alg, input$searchme
- )
- })
-
- # set compartments for elimination
- observeEvent(input$mod_ncomp, {
- if (!is.na(input$mod_ncomp)) {
- updateSelectInput(
- inputId = "mod_elim",
- choices = 1:input$mod_ncomp,
- selected = NULL
- )
- }
- })
-
- # function to aid filtering
- find_x_in_y <- function(x, y) {
- any(stringr::str_detect(y, stringr::regex(x, ignore_case = T)))
- }
-
-
-
- # if filter inputs change, execute this
- observeEvent(filter_obj(), {
- this_filter <- mods
- if (!is.null(input$mod_route)) {
- this_filter <- this_filter %>%
- dplyr::filter(purrr::map_lgl(route, ~ find_x_in_y(input$mod_route, .x)))
- }
- if (!is.na(input$mod_ncomp)) {
- this_filter <- this_filter %>%
- dplyr::filter(purrr::map_lgl(ncomp, ~ input$mod_ncomp == .x))
- }
- if (!is.null(input$mod_elim) && input$mod_elim != "") {
- this_filter <- this_filter %>%
- dplyr::filter(purrr::map_lgl(elim, ~ find_x_in_y(input$mod_elim, .x)))
- }
- if (length(input$mod_kecl) > 0) {
- if (input$mod_kecl == "Rate constants") {
- key <- "K"
- } else {
- key <- "CL"
- }
- this_filter <- this_filter %>%
- dplyr::filter(par == key)
- }
- if (input$mod_alg) {
- this_filter <- this_filter %>%
- dplyr::filter(algebraic != "")
- }
-
- # if search box changes, execute this
- if (input$searchme != "") {
- # browser()
- # terms <- stringr::str_split(input$searchme, ",|;|\\s+") %>% unlist() %>% stringi::stri_remove_empty()
- terms <- stringr::str_split(input$searchme, ",|;|\\s+") %>% unlist()
- terms <- terms[nzchar(terms)]
- this_filter <- this_filter %>%
- dplyr::filter(purrr::map_lgl(name, ~ find_x_in_y(terms, .x)))
- }
-
- # update the global filter results
- if (nrow(this_filter) == 0) {
- this_filter <- dplyr::tibble(name = "None")
- }
- mods_filter(this_filter)
- })
-
-
- # BOTTOM PANEL: Library
-
- output$bottom_library <- renderUI({
- list(
- hr(style = "border-top: 1px solid #FFFFFF;"),
- fluidRow(
- column(
- 6,
- h4("Matching Models"),
- selectInput(
- "mod_list",
- "",
- choices = mods_filter()$name,
- selectize = FALSE,
- multiple = FALSE,
- size = 10
- ),
- actionButton("select_model", "Select", icon("check"))
- ),
- column(
- 6,
- h4("Model Snapshot"),
- markdown("B = Bolus, R = infusion Rate, Y = observation"),
- plotOutput("model_snapshot")
- )
- ) # end fluidRow
- ) # end list
- }) # end renderUI
-
- # render the model snapshot
- observeEvent(input$mod_list,
- ignoreInit = TRUE,
- ignoreNULL = TRUE,
- {
- output$model_snapshot <- renderPlot({
- mod_to_plot <- tryCatch(modelLibrary$mod[which(modelLibrary$name == input$mod_list)][[1]], error = function(e) NA)
- class(mod_to_plot) <- "PM_model"
- # browser()
- tryCatch(plot(mod_to_plot),
- error = function(e) {
- ggplot2::ggplot(
- data = data.frame(x = c(0, 1), y = c(0, 1)),
- aes(x, y)
- ) +
- annotate("label", x = 0.5, y = 0.5, label = "Unable to display model diagram...") +
- ggraph::theme_graph()
- }
- )
- })
- }
- )
-
- # update model if select model updates
- observeEvent(input$select_model,
- ignoreInit = TRUE,
- {
- # update reactive variables
- model_obj(modelLibrary$mod[which(modelLibrary$name == input$mod_list)][[1]]$model_list) # this model will update
- alg_mod(modelLibrary$algebraic[which(modelLibrary$name == input$mod_list)]) # indicates algebraic model
- orig_model(model_obj()$eqn) # keep the original model
- orig_alg_model(alg_mod()) # keep the original algebraic code
- }
- )
-
- # update model if previous model loaded from file
- observeEvent(input$model_file,
- ignoreInit = TRUE,
- {
- loaded_mod <- tryCatch(PM_model$new(input$model_file$datapath), error = function(e) {
- print("Error loading model.")
- return()
- })
- model_obj(loaded_mod$model_list)
- model_arg <- NULL # zero out
- }
- )
-
- # update model if previous model loaded from file
- observeEvent(input$data_file,
- ignoreInit = TRUE,
- {
- loaded_dat <- tryCatch(PM_data$new(input$data_file$datapath), error = function(e) {
- print("Error loading data.")
- return()
- })
- data_obj(loaded_dat)
- data_arg <- NULL # zero out
- }
- )
-
- observeEvent(
- data_obj(), # the data object has changed, update covariates
- {
- cov_names(getCov(data_obj()$standard_data)$covnames)
- ncov(getCov(data_obj()$standard_data)$ncov)
- # browser()
- if (ncov() == 0) {
- cov_source("Covariates obtained from data when available, but no covariates in this dataset.")
- } else {
- cov_source("Covariates obtained from data.")
- }
- }
- )
-
-
- observeEvent(
- model_obj(), # the model object has changed, update fields
- {
- # grab model
- model <- model_obj()
-
- npar <- length(model$pri)
- updateNumericInput(inputId = "nvar", value = npar)
- purrr::walk(
- 1:npar,
- ~ {
- store[[paste0("var_name_", .x)]] <- names(model$pri)[.x]
- store[[paste0("var_a_", .x)]] <- ifelse(abmsdcv() == "Range" | abmsdcv() == "Mean/CV%", model$pri[[.x]]$min, model$pri[[.x]]$mean)
- store[[paste0("var_b_", .x)]] <- ifelse(abmsdcv() == "Range" | abmsdcv() == "Mean/CV%", model$pri[[.x]]$max, model$pri[[.x]]$sd)
- store[[paste0("var_constant_", .x)]] <- model$pri[[.x]]$constant
- store[[paste0("var_gtz_", .x)]] <- model$pri[[.x]]$gtz
- }
- )
- # browser()
- if (!is.null(model$cov) &&
- !is.null(data_obj()) && getCov(data_obj()$standard_data)$ncov == 0) { # model has covariates, but none in app
- cov_names(purrr::map_chr(model$cov, \(x) x$covariate))
- ncov(length(cov_names()))
- cov_source("Covariates obtained from model.")
- }
- updateTextAreaInput(inputId = "secVar", value = paste(model$sec, collapse = "\n"))
- updateTextAreaInput(inputId = "lagTime", value = paste(model$lag, collapse = "\n"))
- updateTextAreaInput(inputId = "iniCond", value = paste(model$ini, collapse = "\n"))
- updateTextAreaInput(inputId = "FA", value = paste(model$fa, collapse = "\n"))
- updateTextAreaInput(inputId = "modEq", value = paste(model$eqn, collapse = "\n"))
- numeqt <- length(model$out)
- updateNumericInput(inputId = "nout", value = numeqt)
- purrr::walk(
- 1:numeqt,
- ~ {
- store[[paste0("out_eqn_", .x)]] <- model$out[[.x]]$val
- store[[paste0("out_assay_err_", .x)]] <- paste0(model$out[[.x]]$err$assay$coefficients, collapse = ", ")
- store[[paste0("out_assay_err_always_", .x)]] <- model$out[[.x]]$err$assay$constant
- store[[paste0("out_model_err_type_", .x)]] <-
- dplyr::case_when(
- !is.null(model$out[[.x]]$err$model$additive) && !model$out[[.x]]$err$model$constant ~ "Additive (lambda)",
- !is.null(model$out[[.x]]$err$model$additive) && model$out[[.x]]$err$model$constant ~ "Additive Fixed",
- !is.null(model$out[[.x]]$err$model$proportional) && !model$out[[.x]]$err$model$constant ~ "Proportional (gamma)",
- !is.null(model$out[[.x]]$err$model$proportional) && model$out[[.x]]$err$model$constant ~ "Proportional Fixed"
- )
- store[[paste0("out_model_err_val_", .x)]] <-
- ifelse(
- !is.null(model$out[[.x]]$err$model$additive),
- model$out[[.x]]$err$model$additive,
- model$out[[.x]]$err$model$proportional
- )
- }
- )
- }
- )
-
-
-
- # PRIMARY PARAMETERS COMPONENT
-
- # get user choice for ab vs msd
- abmsdcv <- reactive({
- input$ab_msd_cv
- })
-
- # save primary values
- observeEvent(npar(),
- {
- purrr::map(
- 1:npar(),
- ~ {
- if (exist_obj(input[[paste0("var_name_", .x)]])) store[[paste0("var_name_", .x)]] <- input[[paste0("var_name_", .x)]]
- if (exist_obj(input[[paste0("var_a_", .x)]])) store[[paste0("var_a_", .x)]] <- input[[paste0("var_a_", .x)]]
- if (exist_obj(input[[paste0("var_b_", .x)]])) store[[paste0("var_b_", .x)]] <- input[[paste0("var_b_", .x)]]
- if (exist_obj(input[[paste0("var_constant_", .x)]])) store[[paste0("var_constant_", .x)]] <- input[[paste0("var_constant_", .x)]]
- if (exist_obj(input[[paste0("var_gtz_", .x)]])) store[[paste0("var_gtz_", .x)]] <- input[[paste0("var_gtz_", .x)]]
- }
- )
- },
- ignoreNULL = TRUE,
- ignoreInit = TRUE
- )
-
- # render variable primary parameters in UI
- output$pri_var <- renderUI({
- purrr::map(
- 1:npar(),
- ~ {
- fluidRow(
- column(
- 3,
- textInput(
- paste0("var_name_", .x),
- label = paste0("Name ", .x, ":"),
- value = store[[paste0("var_name_", .x)]]
- )
- ),
- column(
- 2,
- numericInput(
- paste0("var_a_", .x),
- dplyr::case_when(
- abmsdcv() == "Range" ~ "Min:",
- abmsdcv() == "Mean/SD" ~ "Mean:",
- abmsdcv() == "Mean/CV%" ~ "Mean:"
- ),
- value = store[[paste0("var_a_", .x)]]
- )
- ),
- column(
- 2,
- numericInput(
- paste0("var_b_", .x),
- dplyr::case_when(
- abmsdcv() == "Range" ~ "Max:",
- abmsdcv() == "Mean/SD" ~ "SD:",
- abmsdcv() == "Mean/CV%" ~ "CV%:"
- ),
- value = store[[paste0("var_b_", .x)]]
- )
- ),
- column(
- 2,
- div(
- style = "display: inline-block; margin-left: 10px; margin-right: 10px; vertical-align: -30px;",
- checkboxInput(
- paste0("var_constant_", .x),
- "Constant?",
- value = store[[paste0("var_constant_", .x)]]
- )
- )
- ),
- column(
- 2,
- div(
- style = "display: inline-block; margin-left: 10px; margin-right: 10px; vertical-align: -30px;",
- checkboxInput(
- paste0("var_gtz_", .x),
- "GTZ?",
- value = store[[paste0("var_gtz_", .x)]]
- )
- )
- ) # end columns
- ) # end row
- } # end ~ function
- ) # end map
- }) # end renderUI
-
-
- # COVARIATE COMPONENT
-
- # set default covariate values based on data
- output$cov <- renderUI({
- if (ncov() > 0) {
- purrr::map(cov_names(), function(x) {
- checkboxInput(
- inputId = paste0(x, "_constant"),
- label = paste0(x),
- value = FALSE
- )
- })
- } else {
- textAreaInput(
- "cov_user",
- "Covariates",
- )
- }
- })
-
- observe({
- if (exist_obj(input$cov_user) && any(input$cov_user != "")) {
- cov_list(stringr::str_split(input$cov_user, "\n")[[1]])
- } else {
- cov_list("")
- }
- })
-
-
- # INI COMPONENT
- output$ini <- renderUI({
- selectizeInput("special_ini",
- "Select the following parameters to be intial conditions:",
- choices = list(
- `Primary` = map(1:npar(), ~ input[[paste0("var_name_", .x)]]),
- `Secondary` = extract_sec(),
- `Covariates` = as.list(c(cov_names(), gsub("!", "", cov_list())))
- ),
- multiple = TRUE,
- options = list(maxItems = numeqt())
- )
- })
-
- observe({
- nini <- length(input$special_ini)
- if (nini > 0) {
- updateTextAreaInput(
- inputId = "iniCond",
- value = purrr::map(
- 1:nini,
- ~ paste0("X[", .x, "] = ", input$special_ini[.x])
- ) %>%
- unlist() %>% paste(collapse = "\n")
- )
- }
- })
-
- # FA COMPONENT
- output$fa <- renderUI({
- selectizeInput("special_fa",
- "Select the following parameters to be bioavailability:",
- choices = list(
- `Primary` = map(1:npar(), ~ input[[paste0("var_name_", .x)]]),
- `Secondary` = extract_sec(),
- `Covariates` = as.list(c(cov_names(), gsub("!", "", cov_list())))
- ),
- multiple = TRUE,
- options = list(maxItems = ninput)
- )
- })
-
- observe({
- nfa <- length(input$special_fa)
- if (nfa > 0) {
- updateTextAreaInput(
- inputId = "FA",
- value = purrr::map(
- 1:nfa,
- ~ paste0("FA[", .x, "] = ", input$special_fa[.x])
- ) %>%
- unlist() %>% paste(collapse = "\n")
- )
- }
- })
-
- # LAG COMPONENT
- output$lag <- renderUI({
- selectizeInput("special_lag",
- "Select the following parameters to be lag times:",
- choices = list(
- `Primary` = map(1:npar(), ~ input[[paste0("var_name_", .x)]]),
- `Secondary` = extract_sec(),
- `Covariates` = as.list(c(cov_names(), gsub("!", "", cov_list())))
- ),
- multiple = TRUE,
- options = list(maxItems = ninput)
- )
- })
-
- observe({
- nlag <- length(input$special_lag)
- if (nlag > 0) {
- updateTextAreaInput(
- inputId = "lagTime",
- value = purrr::map(
- 1:nlag,
- ~ paste0("LAG[", .x, "] = ", input$special_lag[.x])
- ) %>%
- unlist() %>% paste(collapse = "\n")
- )
- }
- })
-
-
- # EQN COMPONENT
-
- observeEvent(input$modEq, {
- alg <- alg_mod()
- if (!is.null(alg) && alg != "") {
- # compare
- if (!identical(
- stringr::str_replace_all(input$modEq, "\\s+", ""),
- stringr::str_replace_all(paste(orig_model(), collapse = "\n"), "\\s+", "")
- )) {
- alg_mod("") # remove algebraic code
- output$edit_eqn <- renderText({
- "Warning: changing algebraic model equations forces use of ODE solver."
- })
- } else {
- alg_mod(orig_alg_model()) # restore algebraic code
- output$edit_eqn <- renderText({
- ""
- })
- }
- }
- })
-
-
- # OUTPUTS COMPONENT
-
- ## save outputs values
- observeEvent(numeqt(),
- {
- purrr::map(
- 1:numeqt(),
- ~ {
- if (exist_obj(input[[paste0("out_eqn_", .x)]])) store[[paste0("out_eqn_", .x)]] <- input[[paste0("out_eqn_", .x)]]
- if (exist_obj(input[[paste0("out_assay_err_", .x)]])) store[[paste0("out_assay_err_", .x)]] <- input[[paste0("out_assay_err_", .x)]]
- if (exist_obj(input[[paste0("out_assay_err_always_", .x)]])) store[[paste0("out_assay_err_always_", .x)]] <- input[[paste0("out_assay_err_always_", .x)]]
- if (exist_obj(input[[paste0("out_model_err_type_", .x)]])) store[[paste0("out_model_err_type_", .x)]] <- input[[paste0("out_model_err_type_", .x)]]
- if (exist_obj(input[[paste0("out_model_err_val_", .x)]])) store[[paste0("out_model_err_val_", .x)]] <- input[[paste0("out_model_err_val_", .x)]]
- }
- )
- },
- ignoreNULL = TRUE,
- ignoreInit = TRUE
- )
-
- # render output parameters in UI
- output$outputs <- renderUI({
- purrr::map(
- 1:numeqt(),
- ~ {
- fluidPage(
- fluidRow(
- h3(paste0("Output ", .x)),
- column(
- 4,
- textInput(
- paste0("out_eqn_", .x),
- label = "Equation:",
- value = store[[paste0("out_eqn_", .x)]]
- )
- )
- ), # end fluidRow
- fluidRow(
- column(6, h4("Assay Error")),
- if (.x == 1) {
- column(6, h4("Model Error"))
- }
- ),
- fluidRow(
- column(
- 4,
- textInput(
- paste0("out_assay_err_", .x),
- "Coefficients: ",
- value = store[[paste0("out_assay_err_", .x)]]
- )
- ),
- column(
- 2,
- div(
- style = "display: inline-block; margin-left: 10px; margin-right: 10px; vertical-align: -30px;",
- checkboxInput(
- paste0("out_assay_err_always_", .x),
- "Use always?",
- value = store[[paste0("out_assay_err_always_", .x)]]
- )
- )
- ),
- if (.x == 1) {
- column(
- 4,
- selectInput(
- paste0("out_model_err_type_", .x),
- "Type:",
- choices = c("Additive (lambda)", "Additive Fixed", "Proportional (gamma)", "Proportional Fixed"),
- selected = store[[paste0("out_model_err_type_", .x)]]
- )
- )
- },
- if (.x == 1) {
- column(
- 2,
- textInput(
- paste0("out_model_err_val_", .x),
- "Value:",
- value = store[[paste0("out_model_err_val_", .x)]]
- )
- )
- }
- ) # end fluidRow
- ) # end fluidPage
- } # end ~ function
- ) # end map
- }) # end renderUI
-
-
-
- # BOTTOM PANEL: Components
-
- tab <- function(n) {
- return(paste0(rep(" ", n), collapse = ""))
- }
-
- purrr::map(
- blockNames, function(x) {
- output[[paste0("model_list_", x)]] <- renderUI({
- all_blocks <- list() # this is for printing
-
- # primary
- all_blocks[[1]] <-
- paste0(
- tab(4), "pri = list(
",
- paste0(purrr::map(1:npar(), ~ paste0(
- tab(6),
- input[[paste0("var_name_", .x)]],
- " = ",
- dplyr::case_when(
- is.na(input[[paste0("var_b_", .x)]]) ~ paste0("fixed(", input[[paste0("var_a_", .x)]]),
- abmsdcv() == "Range" ~ paste0("ab(", input[[paste0("var_a_", .x)]], ", ", input[[paste0("var_b_", .x)]]),
- abmsdcv() == "Mean/SD" ~ paste0("msd(", input[[paste0("var_a_", .x)]], ", ", input[[paste0("var_b_", .x)]]),
- abmsdcv() == "Mean/CV%" ~ {
- theta <- input[[paste0("var_a_", .x)]]
- omega <- sqrt(log(((as.numeric(input[[paste0("var_b_", .x)]]) / 100))**2 + 1))
- a <- round(theta * exp(-3 * omega), 3)
- b <- round(theta * exp(3 * omega), 3)
- paste0("ab(", a, ", ", b)
- }
- ),
- if (!is.null(input[[paste0("var_b_", .x)]]) &&
- is.na(input[[paste0("var_b_", .x)]]) &&
- input[[paste0("var_constant_", .x)]]) {
- ", constant = TRUE"
- },
- if (!is.null(input[[paste0("var_gtz_", .x)]]) && input[[paste0("var_gtz_", .x)]]) {
- ", gtz = TRUE"
- },
- ")"
- ))) %>%
- unlist() %>% paste(collapse = ",
"), "
",
- tab(4), ")"
- )
-
- # covariates
- if (ncov() > 0) {
- all_blocks[[2]] <-
- paste0(
- tab(4), "cov = list(
",
- paste0(purrr::map(cov_names(), ~ paste0(
- tab(6),
- "covariate(\"",
- .x,
- "\"",
- ifelse(
- !is.null(input[[paste0(.x, "_constant")]]) && input[[paste0(.x, "_constant")]],
- ", constant = TRUE)",
- ")"
- )
- ))) %>%
- unlist() %>% paste(collapse = ",
"), "
",
- tab(4), ")"
- )
- } else if (any(cov_list() != "")) {
- covs <- cov_list()
- fixed_cov <- grepl("!", covs)
- if (any(fixed_cov)) { # found fixed covariates
- covs <- gsub("!", "", covs)
- }
- all_blocks[[2]] <-
- paste0(
- tab(4), "cov = list(
",
- paste0(purrr::map(1:length(covs), \(x) paste0(
- tab(6),
- "covariate(\"",
- covs[x],
- "\"",
- ifelse(
- fixed_cov[x],
- ", constant = TRUE)",
- ")"
- )
- ))) %>%
- unlist() %>% paste(collapse = ",
"), "
",
- tab(4), ")"
- )
- } else {
- all_blocks[[2]] <- NULL
- }
-
-
- # secondary
- if (input$secVar != "") {
- all_blocks[[3]] <-
- paste0(
- tab(4), "sec = list(
",
- paste0(tab(6), "\"", stringr::str_split_1(input$secVar, "\n"),
- "\"",
- collapse = ",
"
- ),
- "
", tab(4), ")"
- )
- } else {
- all_blocks[[3]] <- NULL
- }
-
- # bolus compartments
- # if (input$bolComp != ""){
- # all_blocks[[4]] <-
- # paste0(
- # tab(4), "bol = c(
",
- # paste0(tab(6), "\"", stringr::str_split_1(input$bolComp, "\n"), "\"", collapse = ",
"),
- # "
", tab(4), ")"
- # )
- # } else {
- # all_blocks[[4]] <- NULL
- # }
- all_blocks[[4]] <- NULL # no longer need bolus
-
- # initial conditions
- if (input$iniCond != "") {
- all_blocks[[5]] <-
- paste0(
- tab(4), "ini = list(
",
- paste0(tab(6), "\"", stringr::str_split_1(input$iniCond, "\n"),
- "\"",
- collapse = ",
"
- ),
- "
", tab(4), ")"
- )
- } else {
- all_blocks[[5]] <- NULL
- }
-
- # bioavailability
- if (input$FA != "") {
- all_blocks[[6]] <-
- paste0(
- tab(4), "fa = list(
",
- paste0(tab(6), "\"", stringr::str_split_1(input$FA, "\n"),
- "\"",
- collapse = ",
"
- ),
- "
", tab(4), ")"
- )
- } else {
- all_blocks[[6]] <- NULL
- }
-
- # lag time
- if (input$lagTime != "") {
- all_blocks[[7]] <-
- paste0(
- tab(4), "lag = list(
",
- paste0(tab(6), "\"", stringr::str_split_1(input$lagTime, "\n"), "\"", collapse = ",
"),
- "
", tab(4), ")"
- )
- } else {
- all_blocks[[7]] <- NULL
- }
-
- # equations
- if (input$modEq != "") {
- # browser()
- alg <- alg_mod()
- # browser()
- all_blocks[[8]] <-
- paste0(
- tab(4), "eqn = list(
",
- if (!is.null(alg) && alg != "") {
- paste0(tab(6), "\"{algebraic: ", alg, "}\",
")
- },
- paste0(tab(6), "\"", stringr::str_split_1(input$modEq, "\n"),
- "\"",
- collapse = ",
"
- ),
- "
", tab(4), ")"
- )
- } else {
- all_blocks[[8]] <- NULL
- }
-
- # outputs
- all_blocks[[9]] <-
- paste0(
- tab(4), "out = list(
",
- paste0(
- purrr::map(
- 1:numeqt(), ~ paste0(
- tab(6),
- "Y", .x, " = list(
",
- tab(8), "val = \"", input[[paste0("out_eqn_", .x)]], "\",
",
- tab(8), "err = list(
",
- paste0(
- tab(10), "model = ",
- dplyr::case_when(
- input$out_model_err_type_1 == "Additive (lambda)" ~ paste0("additive(", input$out_model_err_val_1, "),
"),
- input$out_model_err_type_1 == "Additive Constant" ~ paste0("additive(", input$out_model_err_val_1, ", constant = TRUE),
"),
- input$out_model_err_type_1 == "Proportional (gamma)" ~ paste0("proportional(", input$out_model_err_val_1, "),
"),
- input$out_model_err_type_1 == "Proportional Constant" ~ paste0("proportional(", input$out_model_err_val_1, ", constant = TRUE),
"),
- )
- ),
- paste0(
- tab(10), "assay = ",
- dplyr::case_when(
- input[[paste0("out_assay_err_always_", .x)]] == TRUE ~ paste0("errorPoly(c(", input[[paste0("out_assay_err_", .x)]], "), constant = TRUE)
"),
- input[[paste0("out_assay_err_always_", .x)]] == FALSE ~ paste0("errorPoly(c(", input[[paste0("out_assay_err_", .x)]], "))
"),
- )
- ),
- tab(8), ")
", # close err list
- tab(6), ")" # close output Y list
- ) # end paste0
- ) # end map
- %>%
- unlist() %>% paste(collapse = ",
"), "
",
- tab(4), ")
" # close out list
- ) # end paste0
- ) # end paste0
-
- # create object suitable for copying to clipboard
- copy_list(
- paste0(
- "PM_model$new(\n",
- tab(2), "list(\n",
- paste0(purrr::compact(
- # tidy up html characters
- purrr::map(
- all_blocks,
- ~ {
- stringr::str_replace_all(.x, "
", "\n") # %>%
- # stringr::str_replace_all("\\\"","'") %>%
- }
- )
- ), collapse = ",\n"),
- tab(2), ")\n", ")"
- )
- )
-
- # model_list to create a PM_model before all_blocks compacted
- model_list <- all_blocks %>%
- # tidy up html characters
- purrr::map(
- ~ {
- stringr::str_replace_all(.x, "
\\s*", "") %>%
- stringr::str_replace_all("\\\"", "'") %>%
- stringr::str_replace_all("^\\s+", "")
- }
- ) %>%
- # parse
-
- purrr::map(~ tryCatch(eval(parse(text = .x)), error = function(e) "Error")) %>%
- purrr::set_names(blockNames) %>%
- # remove empty
- purrr::compact()
-
- # update reactiveVal
- new_model(model_list)
-
- # put it all together to display all_blocks in app
- HTML(paste0(
- "",
- "PM_model$new(
",
- tab(2), "list(
",
- paste0(purrr::compact(all_blocks), collapse = ",
"),
- tab(2), ")
",
- ")
",
- "
"
- ))
- }) # end output
- } # end function
- ) # end map
-
-
- # render the model diagrams
- purrr::map(blockNames, function(x) {
- output[[paste0("model_diagram_", x)]] <- renderPlot({
- mod <- list(model_list = list(
- eqn = stringr::str_split(input$modEq, "\n") %>% unlist(),
- out = purrr::set_names(paste0("Y", 1:numeqt())) %>% map2(1:numeqt(), ~ list(val = input[[paste0("out_eqn_", .y)]]))
- ))
- class(mod) <- "PM_model"
- # browser()
- tryCatch(plot(mod),
- error = function(e) {
- ggplot2::ggplot(
- data = data.frame(x = c(0, 1), y = c(0, 1)),
- aes(x, y)
- ) +
- ggplot2::annotate("label", x = 0.5, y = 0.5, label = "Model building in progress...") +
- ggraph::theme_graph()
- }
- )
- })
- })
-
-
- # Create the layout for the bottom panel
- purrr::map(
- blockNames, function(x) {
- output[[paste0("bottom_", x)]] <- renderUI({
- list(
- hr(style = "border-top: 1px solid #FFFFFF;"),
- fluidRow(
- tabsetPanel(
- tabPanel(
- type = "pills",
- "Model Diagram",
- plotOutput(paste0("model_diagram_", x))
- ),
- type = "pills",
- tabPanel(
- "Model List",
- div(
- style = "width: 75%;",
- htmlOutput(paste0("model_list_", x))
- ),
- column(
- 2,
- actionButton(paste0("save_model_list_", x), "Save", icon = icon("save"))
- ),
- column(
- 2,
- actionButton(paste0("copy_model_list_", x), "Copy", icon = icon("copy"))
- )
- )
- ) # end tabsetPanel
- ) # end fluidRow
- ) # end list
- }) # end renderUI
- } # end function
- ) # end map
-
-
-
- # BUTTON ACTIONS ----------------------------------------------------------
-
-
- # save the model
- observe({
- purrr::map(
- blockNames,
- ~ {
- observeEvent(
- input[[paste0("save_model_list_", .x)]],
- ignoreInit = TRUE,
- ignoreNULL = TRUE,
- {
- if (is.null(new_model())) {
- return()
- } else {
- # browser()
- incomplete_blocks <- sapply(new_model(), function(x) ifelse(is.list(x), FALSE, stringr::str_detect(x, "^Error")))
- if (any(incomplete_blocks)) {
- incomplete_blocks <- paste0("#", names(new_model())[incomplete_blocks %>% unlist()], collapse = ", ")
- # browser()
- message(paste("Enter information for", incomplete_blocks, "block", c("", "s")[1 + (length(incomplete_blocks) > 1)], "first, then save."))
- alert_count(alert_count() + 1) # trigger message popup
- } else {
- # browser()
- model_save <- tryCatch(PM_model$new(new_model())$write("model.txt"), error = function(e) "Fail")
- if (model_save != "Fail") {
- message("Model saved as 'model.txt' in current working directory.")
- success_count(success_count() + 1) # trigger message popup
- } else {
- message("Model not yet complete.")
- alert_count(alert_count() + 1) # trigger message popup
- }
- }
- }
- }
- )
- }
- ) # end map
- }) # end observe
-
-
- # copy the model
- observe({
- purrr::map(
- blockNames,
- ~ {
- observeEvent(
- input[[paste0("copy_model_list_", .x)]],
- ignoreInit = TRUE,
- ignoreNULL = TRUE,
- {
- if (is.null(new_model())) {
- return()
- } else {
- OS <- getOS()
- if (OS != 2) { # Mac or Linux
- clip <- pipe("pbcopy", "w")
- writeLines(copy_list(), clip)
- close(clip)
- } else { # Windows
- writeClipboard(copy_list())
- }
- }
- }
- ) # end observeEvent
- }
- ) # end map
- }) # end observe
-
- # message popup
- message <- reactiveVal("")
- alert_count <- reactiveVal(0)
- success_count <- reactiveVal(0)
- help_count <- reactiveVal(0)
-
- # alerts
- observeEvent(alert_count(),
- ignoreInit = TRUE,
- {
- showModal(
- modalDialog(
- size = "m",
- div(
- class = "alert",
- message()
- ) # end div
- )
- )
- }
- )
-
-
- # success
- observeEvent(success_count(),
- ignoreInit = TRUE,
- {
- showModal(
- modalDialog(
- size = "m",
- div(
- class = "success",
- message()
- ) # end div
- )
- )
- }
- )
-
- # help
- observeEvent(help_count(),
- ignoreInit = TRUE,
- {
- showModal(
- modalDialog(
- size = "l",
- div(
- class = "info",
- message()
- ) # end div
- )
- )
- }
- )
-
- # help messages
- observeEvent(input$help_library, {
- message(
- list(
- h4("Model Library"),
- markdown("
- * Choose a model from the library or load
- one of your own previously created models to populate
- model fields.
- * Using components to the left, you can edit the
- fields, or define them yourself for any level of customization.
- It's best to define relevant components in the menu order from
- top to bottom.
- * If you don't wish to use a model from the library, and you
- don't have a prior model file, start with the PRImary tab.
- * You can also load a data file, which will be used to determine
- the covariates and maximum number of inputs.
- * If you load both model and data files, covariates in the data file
- will be used.
- ")
- )
- )
- help_count(help_count() + 1)
- })
-
- observeEvent(input$help_pri, {
- message(
- list(
- h4("Primary Parameters"),
- markdown("
- * Pmetrics estimates distributions for primary parameters only.
- Choose the number of parameters, whether to parameterize as range,
- mean/CV%, or mean/SD and enter names.
- * Range is the most common way to specify prior model parameter values
- with a nonparametric statistical approach."),
- HTML("- "),
- withMathJax("Mean/CV% is the most common way to specify prior model parameter values
- with a parametric statistical approach. In this model, primary parameters are
- described as a typical (mean) value $\\theta$ in the population, distributed with
- interindividual variability, $\\eta$, assumed to be log-normally distributed with
- variance $\\omega^2$, such that an individual j has a parameter value of
- $\\theta * e^{\\eta_j}$.
- When reported as CV%, $\\omega = \\sqrt{log((\\frac{CV%}{100})^2 + 1)}$,
- from the entered $\\theta$ and CV%, Pmetrics will calculate a range
- for the parameter as $[\\theta * e^{-3\\omega}, \\theta * e^{3\\omega}]$"),
- HTML("
- "),
- withMathJax("Mean/SD is the least common way to specify prior model parameter values
- with a parameteric statistical approach because it implies an additive model
- such that individual j has a parameter value of $\\theta + \\eta_j$, which
- of course can be negative. For this reason, it is far more common to use
- the exponential prior, typically reported as mean/CV%. However, if a parameter
- itself is log transformed, then mean/SD is an appropriate prior specification."),
- HTML("
"),
- markdown("
- * Parameters are assumed to be random
- with unknown mean/variance. If a value is entered for either *Min* or *Mean*
- but *Max*/*SD*/*CV%* is blank, the parameter will be considered
- as *Fixed*, which means the same but unknown value in the population
- with unknown mean, zero variance. The entered value will be the starting
- value for the optimization. When a parameter is fixed, checking
- *Constant* will make the entered value the same for the population
- and it will not be optimized, i.e., known mean, zero variance.
- * Parameters can also be marked as *GTZ* or greater than zero, if they are to be kept positive.
- This is only relevant for parametric estimation, as nonparametric estimation will strictly respect boundaries.")
- )
- )
- help_count(help_count() + 1)
- })
-
- observeEvent(input$help_cov, {
- if (ncov() > 0) {
- message(
- list(
- h4("Covariates"),
- HTML("- "),
- cov_source(),
- HTML("
"),
- markdown("
- * Check any covariates which are constant between measurements.
- * Leave unchecked if covariate is linearly interpolated between measurements
- ")
- )
- )
- } else {
- message(
- list(
- h4("Covariates"),
- markdown("
- * No covariates available from model or data file.
- * You can still type any covariate name you want into the box below.
- Use \"!\" to specify a piece-wise constant covariate, e.g. \"wt!\".")
- )
- )
- }
- help_count(help_count() + 1)
- })
-
- observeEvent(input$help_sec, {
- message(
- list(
- h4("Secondary Parameters"),
- markdown("
- * Secondary variables are those that are defined by equations that are
- combinations of primary, covariates, and other secondary variables.
- * It is permissible to have conditional statements, but because expressions in
- this block are translated into variable declarations, expressions other
- than of the form `X = function(Y)` must be on a new line, prefixed by
- `&` and contain only variables which have been previously defined in the
- Primary, Covariate, or Secondary blocks.
- * Examples:
- * `V = V0 * wt`
- * `& IF(male == 1) CL = CL_m`
- ")
- )
- )
- help_count(help_count() + 1)
- })
-
- observeEvent(input$help_ini, {
- message(
- list(
- h4("Initial Conditions"),
- markdown("
- * If any Primary or Secondary parameters are initial conditions,
- choose them here and edit the code if needed.
- * You can only select as many parameters as you have model compartments (e.g. equations).
- ")
- )
- )
- help_count(help_count() + 1)
- })
-
- observeEvent(input$help_fa, {
- message(
- list(
- h4("Bioavailability (FA)"),
- markdown("
- * If any Primary or Secondary parameters are bioavailability,
- choose them here and edit the code if needed.
- * You can only select as many parameters as you have inputs (e.g. drugs).
- ")
- )
- )
- help_count(help_count() + 1)
- })
-
- observeEvent(input$help_lag, {
- message(
- list(
- h4("Lag Time"),
- markdown("
- * If any Primary or Secondary parameters are lag times,
- choose them here and edit the code if needed.
- * You can only select as many parameters as you have inputs (e.g. drugs).
- ")
- )
- )
- help_count(help_count() + 1)
- })
-
- observeEvent(input$help_eqn, {
- message(
- list(
- h4("Equations"),
- markdown("
- * Write the differential equations for your model here.
- * Use `dX[i]` for change in compartment amounts, where i is the compartment number, e.g. dX[1] or dX[2].
- * Compartment amounts are referred to as `X[i]`, e.g. X[1] or X[2].
- * Use `BOLUS[j]` for bolus input j and `RATEIV[k]` for infusion k.
- * Indeces j and k correspond to the INPUT column in the data file,
- which is usually omitted and assumed to be 1 for all doses.
- * The DUR column in the data file determines whether a dose is treated
- as a BOLUS (DUR = 0) or RATEIV (DUR > 0).
- * Any variable defined in PRI, COV, or SEC may be used.
- * Example: `dX[1] = RATEIV[1] * WT - Ke * X[1]`
- ")
- )
- )
- help_count(help_count() + 1)
- })
-
- observeEvent(input$help_out, {
- message(
- list(
- h4("Outputs"),
- markdown("
- * Outputs are referred to as *Y[i]*, where *i* is the output equation number, e.g. Y[1].
- * Compartments are referred to as *X[j]*, where *j* is the compartment number, e.g. X[1].
- * Any variable defined in PRI, COV, or SEC may be used, e.g. Y[1] = X[1]/V.
- ")
- )
- )
- help_count(help_count() + 1)
- })
- } # end server
- ) # end shinyApp
-} # end build_model
diff --git a/R/build_plot.R b/R/build_plot.R
deleted file mode 100644
index 93c76329..00000000
--- a/R/build_plot.R
+++ /dev/null
@@ -1,2116 +0,0 @@
-#' Launch Plot Builder app
-#'
-#' Open the shiny plot builder app.
-#'
-#' @details
-#' The app will open in a separate window.
-#' @param x Optional object to plot
-#' @param \dots Not currently used
-#'
-#' @return Launches the shiny app.
-#' @export
-#' @author Michael Neely
-#'
-
-build_plot <- function(x,...) {
-
- if(!requireNamespace("shiny", quietly = TRUE)){ #suggests
- stop("The shiny package must be installed to run build_plot().\n")
- }
- if(!requireNamespace("bslib", quietly = TRUE)){ #suggests
- stop("The bslib package must be installed to run build_plot().\n")
- }
- requireNamespace("plotly") #imports
-
-
- if(!missing(x)){
- choices_user <- tryCatch(deparse(substitute(x)), error = function(e) NULL)
- if(is.null(get(choices_user))){
- choices_user <- NULL
- }
- } else {
- choices_user <- NULL
- }
-
- ClassFilter <- function(x) any(grepl("^PM_result|^PM_model|^PM_data|^PM_sim|^PM_pta|^PM_cov|^PM_final",class(get(x))))
- choices2 <- Filter(ClassFilter,ls(globalenv()))
-
- choices <- unique(c(choices_user, choices2))
-
- if(length(choices)==0) {
- choices <- Filter(ClassFilter,ls("package:Pmetrics")) #load examples if none already loaded
- }
-
-
-
- shiny::shinyApp(
-
- ui <- bslib::page_sidebar(
- theme = bslib::bs_theme(bootswatch = "zephyr"),
- title = "Pmetrics Plot",
-
- sidebar = bslib::sidebar(
- width = 400,
- accordion(
- accordion_panel("Data",
- selectInput("data","Choose a Pmetrics object to plot:",choices = choices),
- uiOutput("DataControls")
- ),
- bslib::accordion_panel("Formatting",
- uiOutput("FormatControls")
- ),
- bslib::accordion_panel("Axes",
- uiOutput("AxesControls")
- )
- ) #end accordion Panel
-
- ), #end sidebarPanel
-
-
- h3("Copy and paste the code below into your R script to reproduce the plot:"),
- shiny::helpText("Note: If you accepted the default value for an argument,",
- "it is not necessary to include that argument in the call to plot",
- "and it has been omitted here, following standard R practice."),
- shiny::helpText(htmlOutput("help")),
- card(textOutput("plotCode"),
- max_height = "100px"),
- card(uiOutput("plotPM")),
-
- tags$style(type="text/css",
- ".shiny-output-error { visibility: hidden; }",
- ".shiny-output-error:before { visibility: hidden; }"
- )
-
- ), #end ui
-
- server <- function(input, output, session) {
-
- ######### HELPER FUNCTIONS #################
-
- getXlim <- function(){
- if(length(input$xmin)>0 & length(input$xmax)>0) {
- if(input$xmin!="" & input$xmax!="") {xlim <- as.numeric(c(input$xmin,input$xmax))} else {xlim <- NULL}
- } else {xlim <- NULL}
- return(xlim)
- }
-
- getYlim <- function(){
- if(length(input$ymin)>0 & length(input$ymax)>0) {
- if(input$ymin!="" & input$ymax!="") {ylim <- as.numeric(c(input$ymin,input$ymax))} else {ylim <- NULL}
- } else {ylim <- NULL}
- return(ylim)
- }
-
- getXlab <- function(){
- if(length(input$xlab)==0 & inherits(get(input$data),"PMmatrix")) return("Time (h)")
- if(length(input$xlab)==0) return(NULL)
- if(input$xlab=="") return(NULL)
- return(input$xlab)
- }
-
- getYlab <- function(){
- if(length(input$ylab)==0 & inherits(get(input$data),"PMmatrix")) return("Observation")
- if(length(input$ylab)==0) return(NULL)
- if(input$ylab=="") return(NULL)
- return(input$ylab)
- }
-
- getFormula <- function(x = "x", y = "y", charac = FALSE, choices){
- if (length(input[[x]])==0 || length(input[[y]])==0) return(NULL)
- if (input[[x]]=="Select" || input[[y]]=="Select") return(NULL)
- if (!input[[x]] %in% choices) return(NULL)
- if (!input[[y]] %in% choices) return(NULL)
- if(charac) {return(paste(input[[y]],input[[x]],sep="~"))
- } else {
- return(as.formula(paste(input[[y]],input[[x]],sep="~")))}
- }
-
- getProbs <- function(){
- if(length(input$probs)==0) {return(c(0.05,0.25,0.5,0.75,0.95))} else {return(as.numeric(input$probs))}
- }
-
- getPred <- function(icen){
- if(length(input$incl_pred)==0) return(NULL)
- if(input$incl_pred == "none") return(NULL)
- if(icen == "post") return(paste0(input$data,"$post"))
- if(icen == "pop") return(paste0(input$data,"$pop"))
- }
-
- getGroup <- function(group){
- x <- get(input$data)
- if(length(group)==0) {return(NULL)}
- colfac <- which(names(x)==group)
- if(length(colfac)>0){return(x[,colfac])}
- return(NULL)
- }
-
- setVal <- function(par, def){
- if(is.null(input[[par]])){
- return(def)
- } else {
- return(input[[par]])
- }
- }
-
-
- ############### Make Data Controls #####################
-
- #can use this for PM_result$data and for PM_data
- recycleDataControl <- function(src){
- if(src == "PM_result"){
- data_obj <- get(input$data)$data$standard_data
- }
-
- if(src == "PM_data"){
- data_obj <- get(input$data)$standard_data
- }
-
- return(list(
- shiny::helpText("Use Shift or CTRL (Windows) or CMD (Mac) + Click to (de)select subjects."),
- radioButtons("data_include","", c("Include subjects" = "yes", "Exclude subjects" = "no"), selected = "yes"),
- selectInput("data_select", "", choices = unique(data_obj$id),
- selected = unique(data_obj$id),
- multiple = TRUE, selectize = FALSE),
- selectInput("outeq","Output equation:", choices = 1:max(data_obj$outeq, na.rm = TRUE), selected = 1),
- numericInput("block","Block number:", 1, min = 1, step = 1),
- selectInput("group","Grouping factor",choices = c("None" = "none", getCov(data_obj)$covnames)) #in PMutilities
- ))
- }
-
-
- makeDataControls <- function(){
-
- ############### Data: PM_data #####################
- if(!is.null(input$data) && inherits(get(input$data),"PM_data")){
- return(list(
- recycleDataControl("PM_data")
- ))
- }
-
-
-
- ############### Data: PM_result #####################
-
- if(!is.null(input$data) && inherits(get(input$data),"PM_result")){
- return(list(
- radioButtons("res_sub","Plot which field?",
- selected = "dat",
- c("Data" = "dat",
- "Model" = "mod",
- "Obs/Pred" = "op",
- "Final" = "fin",
- "Cycle" = "cyc",
- "Covariate" = "cov",
- "Validation" = "valid"
- )),
-
- ############### Data: PM_result$data #####################
-
- conditionalPanel(
- condition = "input.res_sub == 'dat'",
- recycleDataControl("PM_result") #end data conditional panel
- ),
-
- ############### Data: PM_result$op #####################
-
- conditionalPanel(
- condition = "input.res_sub == 'op'",
- radioButtons("pred.type","",c("Posterior Predictions" = "post","Population Predictions" = "pop"), selected = "post"),
- checkboxInput("resid","Residual Plot",FALSE),
- selectInput("icen","Predictions based on:",choices=c("mean","median"),"median"),
- shiny::helpText("Use Shift or CTRL (Windows) or CMD (Mac) + Click to (de)select subjects."),
- radioButtons("op_include","",c("Include subjects" = "yes", "Exclude subjects" = "no"), selected = "yes"),
- selectInput("op_select", "", choices=unique(get(input$data)$op$id), selected=unique(get(input$data)$op$id),
- multiple = TRUE, selectize = FALSE),
- selectInput("outeq", "Output equation:", choices = 1:max(get(input$data)$op$outeq), selected = 1),
- selectInput("block", "Block:", choices = c("All",1:max(get(input$data)$op$block)))
- ), #end op conditional panel
-
- ############### Data: PM_result$final #####################
-
- conditionalPanel(
- condition = "input.res_sub == 'fin'",
- radioButtons("ptype","Plot type:",c("Univariate" = "uni", "Bivariate" = "bi")),
- conditionalPanel(
- condition="input.ptype=='bi'",
- selectInput("x","x-axis",choices=c("Select",names(get(input$data)$final$popMean)),selected = "Select"),
- selectInput("y","y-axis",choices=c("Select",names(get(input$data)$final$popMean)),selected = "Select")
- ) #end conditional panel
- ), #end final conditional panel
-
- ############### Data: PM_result$cycle #####################
-
- conditionalPanel(
- condition = "input.res_sub == 'cyc'",
- numericInput("omit","Proportion of burn-in cycles to omit:", 0.2, min = 0, max = 1, step = 0.1)
- ), #end cycle conditional panel
-
- ############### Data: PM_result$cov #####################
-
- conditionalPanel(
- condition = "input.res_sub == 'cov'",
- selectInput("covY", "Y-axis",
- choices=c("Select",names(get(input$data)$cov$data)[names(get(input$data)$cov$data) != "icen"]),
- selected = "Select"),
- selectInput("covX", "X-axis",
- choices=c("Select",names(get(input$data)$cov$data)[names(get(input$data)$cov$data) != "icen"]),
- selected = "Select"),
- shiny::helpText("Use Shift or CTRL (Windows) or CMD (Mac) + Click to (de)select subjects."),
- radioButtons("cov_include", "", c("Include subjects" = "yes", "Exclude subjects" = "no"), selected = "yes"),
- selectInput("cov_select","", choices = unique(get(input$data)$cov$data$id),
- selected = unique(get(input$data)$cov$data$id), multiple = T, selectize = FALSE),
- selectInput("icen","Summary method for changing covariates:",
- choices = c("mean", "median", "mode", "none"), "mean")
- ) #end cov conditional panel
-
- ############### Data: PM_result$model #####################
-
- # not needed
-
-
- )) #end return list
- } #end PM_result
-
- ############### Data: PM_sim #####################
-
- if(!is.null(input$data) && inherits(get(input$data),"PM_sim")){
- x <- get(input$data)$data
- if(inherits(x, "PM_simlist")){
- simlist_sims <- length(x)
- } else {
- simlist_sims <- 0
- }
- OPFilter <- function(x) any(grepl("^PM_result",class(get(x))))
- OPchoices <- Filter(OPFilter,ls(globalenv()))
- if(length(OPchoices)==0){OPchoices <- "None"} else {OPchoices <- c("None", OPchoices)}
-
-
- return(list(
- conditionalPanel(
- condition = "input.simlist_sims > 0",
- numericInput("simChooser","Which simulation?", value = 1,
- min = 1, max = simlist_sims,
- step = 1)
- ),
- selectInput("outeq","Output equation:",choices=1:max(x[[1]]$obs$outeq,na.rm=T),selected=1),
- selectInput("sim_obs","Observed (for VPC)",choices = OPchoices)
- )) #end list
- } #end PMsim
-
- ############### Data: PM_model #####################
-
- if(!is.null(input$data) && inherits(get(input$data),"PM_model")){
-
- return(NULL)
- }
-
- } #end makeDataControls function
-
- ############### Make Format Controls #####################
- makeFormatControls <- function(){
-
- ############### Format: PM_result$cov #####################
-
- if(!is.null(input$data) && inherits(get(input$data),"PM_result")
- && !is.null(input$res_sub) && input$res_sub == "cov"){
- return(list(
- accordion(
- accordion_panel(
- "Line Options",
- bslib::navset_card_tab(
- bslib::nav_panel(
- "Linear",
- checkboxInput("cov_lm", "Include?", FALSE),
- checkboxInput("def_lm_fmt","Use default formatting", TRUE),
- conditionalPanel(
- condition = "!input.def_lm_fmt",
- numericInput("lm_ci", "Confidence Interval", 0.95, min = 0.1, max = 0.99, step = 0.05),
- textInput("lm_col", "Color:", "dodgerblue"),
- numericInput("lm_lwd", "Line width", 1, step = 0.5),
- selectInput("lm_dash", "Dash style:", choices = c("solid", "dot", "dash", "longdash", "dashdot", "longdashdot"))
- )
- ),
- bslib::nav_panel(
- "Loess",
- checkboxInput("cov_loess", "Include?", TRUE),
- checkboxInput("def_loess_fmt","Use default formatting",TRUE),
- conditionalPanel(
- condition = "!input.def_loess_fmt",
- numericInput("loess_ci", "Confidence Interval", 0.95, min = 0.1, max = 0.99, step = 0.05),
- textInput("loess_col","Color:", "dodgerblue"),
- numericInput("loess_lwd", "Line width", 1, step = 0.5),
- selectInput("loess_dash", "Dash style:", choices = c("solid", "dot", "dash", "longdash", "dashdot", "longdashdot"), selected = "dash")
- )
- ),
- bslib::nav_panel(
- "Reference",
- checkboxInput("cov_ref", "Include?", FALSE),
- checkboxInput("def_ref_fmt","Use default formatting",TRUE),
- conditionalPanel(
- condition = "!input.def_ref_fmt",
- textInput("ref_col","Color:", "dodgerblue"),
- numericInput("ref_lwd","Line width", 1, step = 0.5),
- selectInput("ref_dash", "Dash style:", choices = c("solid", "dot", "dash", "longdash", "dashdot", "longdashdot"))
- )
- )
- )
- ), #end accordion panel
- accordion_panel(
- "Marker Options",
- checkboxInput("def_marker_fmt","Use default formatting",TRUE),
- conditionalPanel(
- condition = "!input.def_marker_fmt",
- textInput("mrk_col","Color:", "orange"),
- textInput("mrk_symbol","Symbol","circle"),
- numericInput("mrk_size","Size", 10, step = 1),
- numericInput("mrk_opacity","Opacity", value = 0.5, min = 0, max = 1, step = 0.1),
- numericInput("mrk_lwd","Outline width", 1, step = 0.5),
- textInput("mrk_lcol", "Outline color:", "black")
- )
- ), #end accordion_panel
- accordion_panel(
- "Plot Options",
- checkboxInput("log","Log-log plot", FALSE),
- checkboxInput("grid","Grid", TRUE),
- shiny::helpText("Only relevant for linear regression"),
- checkboxInput("def_stats_fmt","Use default statistics formatting", TRUE),
- conditionalPanel(
- condition = "!input.def_stats_fmt",
- textInput("stats_col","Color:","black"),
- numericInput("stats_size","Size", 14, step = 1),
- checkboxInput("stats_bold","Bold?", FALSE),
- numericInput("stats_x","Horizontal pos", 0.8, step = 0.1),
- numericInput("stats_y","Vertical pos", 0.1, step = 0.1)
- ),
- checkboxInput("def_title_fmt","Omit title", TRUE),
- conditionalPanel(
- condition = "!input.def_title_fmt",
- textInput("title_text", "Title:", ""),
- textInput("title_col","Color:", "black"),
- numericInput("title_size","Size", 20, step=1),
- checkboxInput("title_bold","Bold?", TRUE)
- )
-
- ) #end accordion_panel
- ) #end accordion
- )) #end list
- } #end PMcov
-
- ############### Format: PM_result$final (NPAG) #####################
-
- if(!is.null(input$data) && inherits(get(input$data),"PM_result")
- && !is.null(input$res_sub) && input$res_sub == "fin" & inherits(get(input$data)$final,"NPAG")){
- return(list(
- conditionalPanel(
- condition="input.ptype == 'uni'",
- bslib::navset_card_tab(
- bslib::nav_panel(
- "Bars",
- checkboxInput("def_bar_fmt", "Use default formatting", TRUE),
- conditionalPanel(
- condition = "!input.def_bar_fmt",
- textInput("bar_col","Color:","dodgerblue"),
- numericInput("bar_width","Width:", value = 0.02, min = 0, step = 0.01),
- numericInput("bar_opacity", "Opacity:", value = 0.5, min = 0, max = 1, step = 0.1),
- textInput("bar_lcol", "Outline Color:", "black"),
- numericInput("bar_lwd", "Outline Width:", value = 1, min = 0)
- )
- ),
- bslib::nav_panel(
- "Density Line",
- checkboxInput("incl_line","Include?", FALSE),
- checkboxInput("def_line_fmt","Use default formatting", TRUE),
- conditionalPanel(
- condition = "!input.def_line_fmt",
- textInput("line_col","Color:","black"),
- numericInput("line_width","Width:", value = 1),
- selectInput("line_dash", "Dash style:", choices = c("solid", "dot", "dash", "longdash", "dashdot", "longdashdot"))
- )
- )
- )
- ),
- conditionalPanel(
- condition = "input.ptype == 'bi'",
- bslib::navset_card_tab(
- bslib::nav_panel(
- "Markers",
- checkboxInput("def_mrk_fmt","Use default formatting", TRUE),
- conditionalPanel(
- condition = "!input.def_mrk_fmt",
- textInput("mrk_col","Color:", "dodgerblue"),
- textInput("mrk_symbol","Symbol","circle"),
- numericInput("mrk_size","Size", 5, step = 1),
- numericInput("mrk_opacity","Opacity", value = 0.5, min = 0, max = 1, step = 0.1),
- numericInput("mrk_lwd","Outline width", 1, step = 0.5),
- textInput("mrk_lcol", "Outline color:", "black")
- )
- ),
- bslib::nav_panel(
- "Drop Lines",
- checkboxInput("incl_drop", "Include?", TRUE),
- checkboxInput("def_drop_fmt","Use default formatting", TRUE),
- conditionalPanel(
- condition = "!input.def_drop_fmt",
- textInput("drop_col","Color:","black"),
- numericInput("drop_width","Width:", value = 1),
- selectInput("drop_dash", "Dash style:", choices = c("solid", "dot", "dash", "longdash", "dashdot", "longdashdot"), selected = "dash")
- )
- )
- )
- ) #end conditional panel
- )) #end list
- } #end PM_final, NPAG
-
- ############### Format: PM_result$final IT2B #####################
-
- if(!is.null(input$data) && inherits(get(input$data),"PM_result")
- && !is.null(input$res_sub) && input$res_sub == "fin" & inherits(get(input$data)$final,"IT2B")){
- return(list(
- conditionalPanel(
- condition="input.ptype=='uni'",
- checkboxInput("standard","Standardize IT2B marginals",FALSE),
- numericInput("lwd1","Line width:",4),
- textInput("col1","Color:","red")
- ),
- conditionalPanel(
- condition="input.ptype=='bi'",
- checkboxInput("grid","Grid",TRUE),
- checkboxInput("legend","Legend",TRUE),
- numericInput("lwd2","Line width:",1),
- textInput("col2","Color:","white"),
- numericInput("cex","Point size:",1,step=0.1),
- numericInput("pch","Plotting character:",3,min=1,step=1),
- selectInput("probs","Quantiles",choices=c(0.01,0.025,0.05,0.10,0.25,0.50,0.75,0.90,0.95,0.975,0.99),selected=c(0.05,0.25,0.5,0.75,0.95),multiple=T)
- ) #end conditional panel
- )) #end list
- } #end PM_final, IT2B
-
- ############### Format: PM_result$op #####################
-
- if(!is.null(input$data) && inherits(get(input$data),"PM_result")
- && !is.null(input$res_sub) && input$res_sub == "op"){
- return(list(
- accordion(
- accordion_panel(
- "Line Options",
- # h4("Line Options:"),
- bslib::navset_card_tab(
- bslib::nav_panel(
- "Linear",
- checkboxInput("op_lm", "Include?", TRUE),
- checkboxInput("def_lm_fmt","Use default formatting", TRUE),
- conditionalPanel(
- condition = "!input.def_lm_fmt",
- numericInput("lm_ci", "Confidence Interval", 0.95, min = 0.1, max = 0.99, step = 0.05),
- textInput("lm_col", "Color:", "dodgerblue"),
- numericInput("lm_lwd", "Line width", 1, step = 0.5),
- selectInput("lm_dash", "Dash style:", choices = c("solid", "dot", "dash", "longdash", "dashdot", "longdashdot"))
- )
- ),
- bslib::nav_panel(
- "Loess",
- checkboxInput("op_loess", "Include?",FALSE),
- checkboxInput("def_loess_fmt","Use default formatting",TRUE),
- conditionalPanel(
- condition = "!input.def_loess_fmt",
- numericInput("loess_ci", "Confidence Interval", 0.95, min = 0.1, max = 0.99, step = 0.05),
- textInput("loess_col","Color:", "dodgerblue"),
- numericInput("loess_lwd", "Line width", 1, step = 0.5),
- selectInput("loess_dash", "Dash style:", choices = c("solid", "dot", "dash", "longdash", "dashdot", "longdashdot"), selected = "dash")
- )
- ),
- bslib::nav_panel(
- "Reference",
- checkboxInput("op_ref", "Include?",TRUE),
- checkboxInput("def_ref_fmt","Use default formatting",TRUE),
- conditionalPanel(
- condition = "!input.def_ref_fmt",
- textInput("ref_col","Color:", "dodgerblue"),
- numericInput("ref_lwd","Line width", 1, step = 0.5),
- selectInput("ref_dash", "Dash style:", choices = c("solid", "dot", "dash", "longdash", "dashdot", "longdashdot"))
- )
- )
- )
- ), #end accordion panel
- accordion_panel(
- "Marker Options",
- # h4("Marker Options:"),
- checkboxInput("def_marker_fmt","Use default formatting",TRUE),
- conditionalPanel(
- condition = "!input.def_marker_fmt",
- textInput("mrk_col","Color:", "orange"),
- textInput("mrk_symbol","Symbol","circle"),
- numericInput("mrk_size","Size", 10, step = 1),
- numericInput("mrk_opacity","Opacity", value = 0.5, min = 0, max = 1, step = 0.1),
- numericInput("mrk_lwd","Outline width", 1, step = 0.5),
- textInput("mrk_lcol", "Outline color:", "black")
- )
- ), #end accordion_panel
- accordion_panel(
- "Plot Options",
- numericInput("mult","Multiplication factor for axes:","1"),
- checkboxInput("log","Log-log plot", FALSE),
- checkboxInput("grid","Grid", TRUE),
- shiny::helpText("Only relevant for linear regression"),
- checkboxInput("def_stats_fmt","Use default statistics formatting", TRUE),
- conditionalPanel(
- condition = "!input.def_stats_fmt",
- textInput("stats_col","Color:","black"),
- numericInput("stats_size","Size", 14, step = 1),
- checkboxInput("stats_bold","Bold?", FALSE),
- numericInput("stats_x","Horizontal pos", 0.8, step = 0.1),
- numericInput("stats_y","Vertical pos", 0.1, step = 0.1)
- ),
- checkboxInput("def_title_fmt","Omit title", TRUE),
- conditionalPanel(
- condition = "!input.def_title_fmt",
- textInput("title_text", "Title:", ""),
- textInput("title_col","Color:", "black"),
- numericInput("title_size","Size", 20, step=1),
- checkboxInput("title_bold","Bold?", TRUE)
- )
-
- ) #end accordion_panel
- ) #end accordion
- )) #end list
- } #end PM_op
-
- ############### Format: PM_result$cycle #####################
-
- if(!is.null(input$data) && inherits(get(input$data),"PM_result")
- && !is.null(input$res_sub) && input$res_sub == "cyc"){
-
- return(list(
- accordion(
- accordion_panel(
- "Line Options",
- checkboxInput("def_ab_fmt","Use default formatting",TRUE),
- conditionalPanel(
- condition = "!input.def_ab_fmt",
- bslib::navset_card_tab(
- bslib::nav_panel(
- "Both Rows",
- shiny::helpText("Applies to all plots"),
- numericInput("ab_lwd", "Line width", 1, step = 0.5),
- ),
- bslib::nav_panel(
- "Row A",
- shiny::helpText("Applies to LL, AIC, gamma/lambda"),
- textInput("a_col", "Color:", "dodgerblue"),
- selectInput("a_dash", "Dash style:", choices = c("solid", "dot", "dash", "longdash", "dashdot", "longdashdot"))
- ),
- bslib::nav_panel(
- "Row B",
- shiny::helpText("Applies to normalized parameter statistics"),
- shiny::helpText("Choose colors for each parameter trace. Select 'Other' for custom."),
- selectInput("b_col", "Color palette:",
- choices = c(getPalettes(), "Other"), selected = "Spectral"),
- conditionalPanel(
- condition = "input.b_col == 'Other'",
- shiny::helpText("Enter color names separated by commas. Values will be recycled as needed."),
- textInput("b_custom_colors", "Custom Colors:", value = "")
- ),
- shiny::helpText("Choose dash styles for each parameter trace. Values will be recycled if needed."),
- selectInput("b_dash", "Dash style:", choices = c("solid", "dot", "dash", "longdash", "dashdot", "longdashdot"), selected = "dash", multiple = TRUE)
- ) #end nav_panel
- ) #end navset_card_tab
- ) #end conditional panel
- ), #end accordion panel
- accordion_panel(
- "Marker Options",
- checkboxInput("def_marker_fmt","Use default formatting",TRUE),
- conditionalPanel(
- condition = "!input.def_marker_fmt",
- textInput("mrk_col","Color:", "dodgerblue"),
- textInput("mrk_symbol","Symbol","circle"),
- numericInput("mrk_size","Size", 4, step = 1),
- numericInput("mrk_opacity","Opacity", value = 1, min = 0, max = 1, step = 0.1),
- numericInput("mrk_lwd","Outline width", 0, step = 0.5),
- textInput("mrk_lcol", "Outline color:", "black")
- ),
- ), #end accordion_panel
- accordion_panel(
- "Plot Options",
- checkboxInput("grid","Grid", TRUE),
- ) #end accordion_panel
- ) #end accordion
- )) #end list
- } #end PM_cycle
-
- ############### Format: PM_result$data #####################
-
- if(!is.null(input$data) &&
- (inherits(get(input$data),"PM_data") |
- (inherits(get(input$data),"PM_result")
- && !is.null(input$res_sub) && input$res_sub == "dat"))){
-
- return(list(
- accordion(
- accordion_panel(
- "Line Options",
- # h4("Line Options:"),
- bslib::navset_card_tab(
- bslib::nav_panel(
- "Join",
- checkboxInput("join", "Include?", TRUE),
- checkboxInput("def_join_fmt","Use default formatting", TRUE),
- conditionalPanel(
- condition = "!input.def_join_fmt",
- textInput("join_col", "Color:", "dodgerblue"),
- numericInput("join_lwd", "Line width", 1, step = 0.5),
- selectInput("join_dash", "Dash style:", choices = c("solid", "dot", "dash", "longdash", "dashdot", "longdashdot"))
- )
- ),
- bslib::nav_panel(
- "Pred",
- radioButtons("incl_pred","Include Predictions?",c("None" = "none", "Population" = "pop", "Posterior" = "post")),
- checkboxInput("def_pred_fmt","Use default formatting", TRUE),
- conditionalPanel(
- condition = "!input.def_pred_fmt",
- textInput("pred_col","Color:", ""),
- numericInput("pred_lwd", "Line width", 1, step = 0.5),
- selectInput("pred_dash", "Dash style:", choices = c("solid", "dot", "dash", "longdash", "dashdot", "longdashdot"), selected = "dash")
- )
- ) #end nav_panel
- ) #end navset_card_tab
- ), #end accordion panel
- accordion_panel(
- "Marker Options",
- checkboxInput("def_marker_fmt","Use default formatting",TRUE),
- conditionalPanel(
- condition = "!input.def_marker_fmt",
- textInput("mrk_col","Color:", "red"),
- textInput("mrk_symbol","Symbol","circle"),
- numericInput("mrk_size","Size", 10, step = 1),
- numericInput("mrk_opacity","Opacity", value = 0.5, min = 0, max = 1, step = 0.1),
- numericInput("mrk_lwd","Outline width", 1, step = 0.5),
- textInput("mrk_lcol", "Outline color:", "black")
- ),
- ), #end accordion_panel
- accordion_panel(
- "Plot Options",
- checkboxInput("tad", "Use time after dose", FALSE),
- numericInput("mult","Multiplication factor for axes:", value = 1, min = 0, step = 1),
- checkboxInput("log","Semi-log plot", FALSE),
- checkboxInput("grid","Grid", FALSE),
- checkboxInput("def_title_fmt","Omit title", TRUE),
- conditionalPanel(
- condition = "!input.def_title_fmt",
- textInput("title_text", "Title:", ""),
- textInput("title_col","Color:", "black"),
- numericInput("title_size","Size", 20, step=1),
- checkboxInput("title_bold","Bold?", TRUE)
- )
- ), #end accordion_panel
- accordion_panel(
- "Group Options",
- conditionalPanel(
- condition = "input.group !== 'none'",
- shiny::helpText("One name per group, separate by commas"),
- textInput("group_names","Group Names:",
- value = paste(unique(get(input$data)$data$data[[input$group]]), collapse = ", ")
- ),
- checkboxInput("legend","Legend", value = ifelse(input$group != 'none', TRUE, FALSE)),
- selectInput("group_col", "Color palette for groups:",
- choices = getPalettes(), selected = "Set1")
- ),
- conditionalPanel(
- condition = "input.group == 'none'",
- shiny::helpText("Define groups in data")
- )
- ) #end accordion panel
- ) #end accordion
- )) #end list
- } #end PM_data
-
- ############### Format: PM_sim #####################
-
- if(!is.null(input$data) && inherits(get(input$data),"PM_sim")){
- return(
- list(
- accordion(
- accordion_panel(
- "Line Options",
- bslib::nav_panel(
- "Line",
- checkboxInput("sim_line", "Include?", TRUE),
- checkboxInput("def_sim_line_fmt","Use default formatting", TRUE),
- conditionalPanel(
- condition = "!input.def_sim_line_fmt",
- numericInput("sim_ci", "Confidence Interval", 0.95, min = 0.1, max = 0.99, step = 0.05),
- selectInput("sim_probs","Quantiles",
- choices=c(NA,0.01,0.025,0.05,0.10,0.25,0.50,0.75,0.90,0.95,0.975,0.99),
- selected=c(0.05,0.25,0.5,0.75,0.95), multiple = TRUE),
- textInput("sim_col", "Color:", "dodgerblue"),
- numericInput("sim_lwd", "Line width", 1, step = 0.5),
- selectInput("sim_dash", "Dash style:", choices = c("solid", "dot", "dash", "longdash", "dashdot", "longdashdot"))
- )
- )
- ), #end accordion panel
- accordion_panel(
- "Marker Options",
- checkboxInput("def_sim_marker_fmt","Use default formatting",TRUE),
- conditionalPanel(
- condition = "!input.def_sim_marker_fmt",
- textInput("mrk_col","Color:", "black"),
- textInput("mrk_symbol","Symbol","circle-open"),
- numericInput("mrk_size","Size", 8, step = 1),
- numericInput("mrk_opacity","Opacity", value = 0.5, min = 0, max = 1, step = 0.1),
- numericInput("mrk_lwd","Outline width", 1, step = 0.5),
- textInput("mrk_lcol", "Outline color:", "black")
- ),
- ), #end accordion_panel
- accordion_panel(
- "Plot Options",
- numericInput("binSize","Bin Size", value = 0, min = 0, step = 1),
- numericInput("mult","Multiplication factor for axes:", value = 1),
- checkboxInput("log","Semi-log plot", TRUE),
- checkboxInput("grid","Grid", TRUE),
- checkboxInput("def_title_fmt","Omit title", TRUE),
- conditionalPanel(
- condition = "!input.def_title_fmt",
- textInput("title_text", "Title:", ""),
- textInput("title_col","Color:", "black"),
- numericInput("title_size","Size", 20, step=1),
- checkboxInput("title_bold","Bold?", TRUE)
- )
- )
- ) #end accordion
- )) #end list
- } #end PM_sim
-
- ############### Format: PM_model #####################
-
- if(!is.null(input$data) &&
- (inherits(get(input$data),"PM_model") |
- (inherits(get(input$data),"PM_result") &&
- !is.null(input$res_sub) && input$res_sub == "mod"))){
-
- return(list(
- accordion(
- accordion_panel(
- "Line Options",
- checkboxInput("join", "Include?", TRUE),
- checkboxInput("def_join_fmt","Use default formatting", TRUE),
- conditionalPanel(
- condition = "!input.def_join_fmt",
- textInput("join_col", "Color:", "black"),
- numericInput("join_lwd", "Line width", 1, step = 0.5),
- selectInput("join_dash", "Dash style:", choices = c("solid", "dot", "dash", "longdash", "dashdot", "longdashdot"))
- )
-
- ), #end accordion panel
- accordion_panel(
- "Marker Options",
- checkboxInput("def_marker_fmt","Use default formatting",TRUE),
- conditionalPanel(
- condition = "!input.def_marker_fmt",
- textInput("mrk_col","Color:", "dodgerblue"),
- numericInput("mrk_size","Size", value = 0.25, min = 0, max = 1, step = 0.1),
- numericInput("mrk_opacity","Opacity", value = 0.5, min = 0, max = 1, step = 0.1),
- numericInput("mrk_lwd","Outline width", 0.5, step = 0.5),
- textInput("mrk_lcol", "Outline color:", "black")
- )
- )
- ) #end accordion
- ))
- } #end PM_model
-
- } #end makeFormatControls function
-
- ############### Make Axis Controls #####################
- makeAxisControls <- function(){
-
- ############### Axis: all but PM_data #####################
-
- if(!is.null(input$data) && inherits(get(input$data),"PM_sim") |
- (inherits(get(input$data),"PM_result") && input$res_sub %in% c("cov","op","fin"))){
- # if(inherits(get(input$data),c("PMcov","PMfinal","PMop", "PMsim"))){
- return(list(
- h3("Axes"),
- textInput("xmin","X min"),
- textInput("xmax","X max"),
- textInput("ymin","Y min"),
- textInput("ymax","Y max"),
- textInput("xlab","X label"),
- textInput("ylab","Y label"),
- numericInput("axis_label_size","Axis label size",1.2,step=0.1)
- )) #end list
- } #end PM_cov, PM_final, PM_op, PM_sim
-
-
- ############### Axis: PM_result$data #####################
-
- if(!is.null(input$data) &&
- (inherits(get(input$data),"PM_data") |
- (inherits(get(input$data),"PM_result") && input$res_sub == "dat"))){
-
- return(list(
- h3("Axes"),
- textInput("xmin","X min"),
- textInput("xmax","X max"),
- textInput("ymin","Y min"),
- textInput("ymax","Y max"),
- textInput("xlab","X label","Time (h)"),
- textInput("ylab","Y label","Observation"),
- numericInput("axis_label_size","Axis label size",1.2,step=0.1)
- )) #end list
- } #end PM_data
-
- if(!is.null(input$data) &&
- (inherits(get(input$data),"PM_model") |
- (inherits(get(input$data),"PM_result") && input$res_sub == "mod"))){
- return(NULL)
- }
- } #end makeAxisControls
-
- ############### Make PMplot and Statement #####################
- makePMplot <- function(code = FALSE){
-
-
- if(!is.null(input$data) &&
- (inherits(get(input$data),"PM_data") |
- inherits(get(input$data),"PM_result"))){
-
- ############### Plot and Code: PM_result$cov #####################
-
- if(!is.null(input$res_sub) && input$res_sub == "cov"){
- #x argument
- x <- get(input$data)$cov
-
- #line argument
- cov_lm <- setVal("cov_lm", FALSE)
- def_lm_fmt <- setVal("def_lm_fmt", TRUE)
- def_lm_args <- list(ci = 0.95, color = "dodgerblue", width = 1, dash = "solid")
- lm_ci <- setVal("lm_ci", def_lm_args$ci)
- lm_col <- setVal("lm_col", def_lm_args$color)
- lm_lwd <- setVal("lm_lwd", def_lm_args$width)
- lm_dash <- setVal("lm_dash", def_lm_args$dash)
-
- if(cov_lm){ #yes have lm
- if(!def_lm_fmt){ #not default format?
- line <- list(lm = list(ci = lm_ci, color = lm_col, width = lm_lwd, dash = lm_dash))
- line$lm <- line$lm[!line$lm %in% def_lm_args] #keep only non-defaults
- if(length(line$lm)==0) line$lm <- TRUE
- } else { #default format
- line <- list(lm = TRUE)
- }
- } else { #don't have lm
- line <- list() #default with cov plot
- }
-
- cov_loess <- setVal("cov_loess", TRUE)
- def_loess_fmt <- setVal("def_loess_fmt", TRUE)
- def_loess_args <- list(ci = 0.95, color = "dodgerblue", width = 1, dash = "dash")
- loess_ci <- setVal("loess_ci", def_loess_args$ci)
- loess_col <- setVal("loess_col", def_loess_args$color)
- loess_lwd <- setVal("loess_lwd", def_loess_args$with)
- loess_dash <- setVal("loess_dash", def_loess_args$dash)
-
- if(cov_loess){
- if(!def_loess_fmt){ #not default format?
- line <- modifyList(line, list(loess = list(ci = loess_ci, color = loess_col, width = loess_lwd, dash = loess_dash)))
- line$loess <- line$loess[!line$loess %in% def_loess_args] #keep only non-defaults
- if(length(line$loess)==0) line$loess <- TRUE
- }
- } else { #don't have loess
- line <- modifyList(line, list(loess = FALSE)) #default for this is TRUE
- }
-
- cov_ref <- setVal("cov_ref", FALSE)
- def_ref_fmt <- setVal("def_ref_fmt", TRUE)
- def_ref_args <- list(color = "black", width = 1, dash = "dash")
- ref_col <- setVal("ref_col", def_ref_args$color)
- ref_lwd <- setVal("ref_lwd", def_ref_args$width)
- ref_dash <- setVal("ref_dash", def_ref_args$dash)
-
- if(cov_ref){
- if(!def_ref_fmt){
- line <- modifyList(line, list(ref = list(color = ref_col, width = ref_lwd, dash = ref_dash)))
- line$ref <- line$ref[!line$ref %in% def_ref_args] #keep only non-defaults
- if(length(line$ref)==0) line$ref <- TRUE
- } else {
- line <- modifyList(line, list(ref = TRUE))
- }
- }
-
-
- #marker argument
- def_marker_fmt <- setVal("def_marker_fmt", TRUE)
- def_marker_args <- list(color = "orange", symbol = "circle", size = 10, opacity = 0.5,
- line = list(width = 1, color = "black"))
-
- mrk_col <- setVal("mrk_col", "orange")
- mrk_symbol <- setVal("mrk_symbol", "circle")
- mrk_size <- setVal("mrk_size", 10)
- mrk_opacity <- setVal("mrk_opacity", 0.5)
- mrk_lwd <- setVal("mrk_lwd", 1)
- mrk_lcol <- setVal("mrk_lcol", "black")
-
- if(def_marker_fmt){
- marker <- TRUE
- } else {
- marker <- list(color = mrk_col, symbol = mrk_symbol, size = mrk_size,
- opacity = mrk_opacity, line = list(width = mrk_lwd, color = mrk_lcol))
- marker$line <- marker$line[!marker$line %in% def_marker_args$line] #keep only non-defaults
- if(length(marker$line)==0) marker$line <- NULL
- marker <- marker[!marker %in% def_marker_args]
- if(length(marker)==0) marker <- NULL
-
- }
-
- #include/exclude arguments
- if(!is.null(input$cov_include)){
- if(input$cov_include=="yes"){
- include <- input$cov_select
- exclude <- NULL
- } else {
- include <- NULL
- exclude <- input$cov_select
- }
- } else {
- include <- exclude <- NULL
- }
-
- #title argument
- def_title_fmt <- setVal("def_title_fmt", TRUE)
- def_title_args <- list(text = "", font = list(color = "black", size = 20, bold = TRUE))
- title_text <- setVal("title_text", "")
- title_col <- setVal("title_col", "black")
- title_bold <- setVal("title_bold", TRUE)
- title_size <- setVal("title_size", 20)
- if(def_title_fmt){
- title <- ""
- } else {
- title <- list(text = title_text, font = list(color = title_col, size = title_size,
- bold = title_bold))
- title$font <- title$font[!title$font %in% def_title_args$font] #keep only non-defaults
- if(length(title$font)==0) title$font <- NULL
-
- }
-
- #stats argument
- def_stats_fmt <- setVal("def_stats_fmt", TRUE)
- def_stats_args <- list(x = 0.8, y = 0.1, font = list(color = "black", size = 14, bold = FALSE))
- stats_col <- setVal("stats_col", "black")
- stats_size <- setVal("stats_size", 14)
- stats_bold <- setVal("stats_bold", FALSE)
- stats_x <- setVal("stats_x", 0.8)
- stats_y <- setVal("stats_y", 0.1)
- if(def_stats_fmt){
- stats <- TRUE
- } else {
- stats <- list(x = stats_x, y = stats_y, font = list(color = stats_col, size = stats_size,
- bold = stats_bold))
- stats$font <- stats$font[!stats$font %in% def_stats_args$font] #keep only non-defaults
- if(length(stats$font)==0) stats$font <- NULL
- stats <- stats[!stats %in% def_stats_args]
- if(length(stats)==0) stats <- NULL
- }
-
- #formula
- cov_choices <- names(get(input$data)$cov$data)
- cov_choices <- cov_choices[cov_choices != "icen"]
-
- formula <- getFormula(x = "covX", y = "covY",
- choices = cov_choices)
-
- #Other defaults
- icen <- setVal("icen", "median")
- log <- setVal("log", FALSE)
- grid <- setVal("grid", TRUE)
-
-
- args <- list(x = x,
- formula = formula,
- line = line,
- marker = marker,
- icen = icen,
- include = include, exclude = exclude,
- log = log, grid = grid,
- title = title, stats = stats,
- xlab = getXlab(), ylab = getYlab(),
- xlim = getXlim(), ylim = getYlim())
- args <- args[which(sapply(args,function(x) length(x)>0),arr.ind=T)]
-
- #now make the code
- Name <- paste0(input$data,"$cov$plot(")
- #default args
- def_args <- list(
- formula = NULL,
- line = list(lm = FALSE, loess = TRUE, ref = FALSE),
- marker = TRUE,
- icen = "median",
- include = as.character(unique(get(input$data)$cov$data$id)), exclude = NULL,
- log = FALSE,
- grid = TRUE,
- xlab = NULL, ylab = NULL,
- title = "",
- stats = TRUE,
- xlim = NULL, ylim = NULL
- )
-
- arglist <- args[-1] #remove the data object
- arglist <- arglist[map_lgl(intersect(names(arglist),names(def_args)), \(x) !identical(arglist[[x]], def_args[[x]]) )] #remove args that are in default list
- if(length(arglist)>0){
- arglist <- paste(deparse(arglist), collapse = "") %>% stringr::str_replace("^list\\(","") %>%
- stringr::str_replace_all("(\\d+)L","\\1") %>% stringr::str_replace_all(" +"," ")
- codeStatement <- paste0(Name, arglist)
- } else {
- codeStatement <- paste0(Name, ")")
- }
-
- if(!is.null(formula)){
- p <- do.call(plot, args)
- if(code){
- return(codeStatement)
- } else {
- return(p)
- }
- } else {
- return(NULL)
- }
-
- } #end PMcov
-
-
- ############### Plot and Code: PM_result$final, NPAG #####################
-
- if(!is.null(input$res_sub) &&
- (input$res_sub == "fin" & inherits(get(input$data)$final,"NPAG"))){
-
- ptype <- setVal("ptype", "uni")
-
- #x argument
- x <- get(input$data)$final
-
- #marker argument
- def_bar_fmt <- setVal("def_bar_fmt", TRUE)
- def_mrk_fmt <- setVal("def_mrk_fmt", TRUE)
-
- def_bar_args <- list(color = "dodgerblue",
- width = 0.02, opacity = 0.5,
- line = list(color = "black", width = 1))
- def_mrk_args <- list(color = "dodgerblue", size = 5, symbol = "circle",
- opacity = 0.5,
- line = list(color = "black", width = 1))
-
- bar_col <- setVal("bar_col", def_bar_args$color)
- bar_width <- setVal("bar_width", def_bar_args$width)
- bar_size <- setVal("bar_size", def_bar_args$size)
- bar_shape <- setVal("bar_shape", def_bar_args$shape)
- bar_opacity <- setVal("bar_opacity", def_bar_args$opacity)
- bar_lcol <- setVal("bar_lcol", def_bar_args$line$color)
- bar_lwd <- setVal("bar_lwd", def_bar_args$line$width)
-
- mrk_col <- setVal("mrk_col", def_mrk_args$color)
- mrk_width <- setVal("mrk_width", def_mrk_args$width)
- mrk_size <- setVal("mrk_size", def_mrk_args$size)
- mrk_symbol <- setVal("mrk_symbol", def_mrk_args$symbol)
- mrk_opacity <- setVal("mrk_opacity", def_mrk_args$opacity)
- mrk_lcol <- setVal("mrk_lcol", def_mrk_args$line$color)
- mrk_lwd <- setVal("mrk_lwd", def_mrk_args$line$width)
-
- if(ptype == "uni"){
- if(def_bar_fmt){
- marker <- TRUE
- } else {
- marker <- list(color = bar_col, width = bar_width,
- opacity = bar_opacity,
- line = list(color = bar_lcol, width = bar_lwd))
- marker$line <- marker$line[!marker$line %in% def_bar_args$line] #keep only non-defaults
- if(length(marker$line)==0) marker$line <- NULL
- marker <- marker[!marker %in% def_bar_args]
- if(length(marker)==0) marker <- NULL
-
- }
- }
-
- if(ptype == "bi"){
- if(def_mrk_fmt){
- marker <- TRUE
- } else {
- marker <- list(color = mrk_col, size = mrk_size,
- symbol = mrk_symbol, opacity = mrk_opacity,
- line = list(color = mrk_lcol, width = mrk_lwd))
- marker$line <- marker$line[!marker$line %in% def_mrk_args$line] #keep only non-defaults
- if(length(marker$line)==0) marker$line <- NULL
- marker <- marker[!marker %in% def_mrk_args]
- if(length(marker)==0) marker <- NULL
-
- }
- }
-
- #line format
-
- incl_line <- setVal("incl_line", FALSE)
- incl_drop <- setVal("incl_drop", TRUE)
-
- def_line_fmt <- setVal("def_line_fmt", TRUE)
- def_line_args <- list(color = "black", width = 1,
- dash = "solid")
- def_line_color <- setVal("line_col", def_line_args$color)
- def_line_width <- setVal("line_width", def_line_args$width)
- def_line_dash <- setVal("line_dash", def_line_args$dash)
-
- def_drop_fmt <- setVal("def_drop_fmt", TRUE)
- def_drop_args <- list(color = "black", width = 1,
- dash = "dash")
- def_drop_color <- setVal("drop_col", def_drop_args$color)
- def_drop_width <- setVal("drop_width", def_drop_args$width)
- def_drop_dash <- setVal("drop_dash", def_drop_args$dash)
-
-
- if(ptype == "uni"){
- if(incl_line){ #we have a density line
- if(def_line_fmt){ #use default
- line <- TRUE
- } else {
- line = list(color = def_line_color, width = def_line_width, dash = def_line_dash)
- }
- } else {
- line <- FALSE
- }
- line <- line[!line %in% def_line_args]
- if(length(line)==0) line <- NULL
- }
-
- if(ptype == "bi"){
- if(incl_drop){ #we have drop lines
- if(def_drop_fmt){ #use default
- line <- TRUE
- } else {
- line = list(color = def_drop_color, width = def_drop_width, dash = def_drop_dash)
- }
- } else {
- line <- FALSE
- }
-
- line <- line[!line %in% def_drop_args]
- if(length(line)==0) line <- NULL
- }
-
-
-
- args <- list(x = x,
- formula = getFormula(choices = names(get(input$data)$final$popMean)),
- line = line,
- marker = marker,
- xlim = getXlim(), ylim = getYlim(),
- xlab = getXlab(), ylab = getYlab())
-
- if(ptype == "uni"){args$formula <- NULL} #reset formula
-
-
- args <- args[which(sapply(args,function(x) length(x)>0),arr.ind=T)]
-
- #now make the code
- Name <- paste0(input$data,"$final$plot(")
- #default args
- def_args <- list(
- formula = NULL,
- line = ifelse(ptype == "uni", FALSE, TRUE),
- marker = TRUE,
- xlab = NULL, ylab = NULL, zlab = NULL,
- title = "",
- xlim = NULL, ylim = NULL
- )
-
- arglist <- args[-1] #remove the data object
- arglist <- arglist[map_lgl(intersect(names(arglist),names(def_args)), \(x) !identical(arglist[[x]], def_args[[x]]) )] #remove args that are in default list
-
- if(length(arglist)>0){
- arglist <- paste(deparse(arglist), collapse = "") %>% stringr::str_replace("^list\\(","") %>%
- stringr::str_replace_all("(\\d+)L","\\1") %>% stringr::str_replace_all(" +"," ")
- codeStatement <- paste0(Name, arglist)
- } else {
- codeStatement <- paste0(Name, ")")
- }
-
- p <- do.call(plot, args)
- if(code){
- return(codeStatement)
- } else {
- return(p)
- }
-
- } #end PMfinal, NPAG
-
- ############### Plot and Code: PM_result$final, IT2B #####################
-
- # if(!is.null(input$res_sub) &&
- # (input$res_sub == "fin" & inherits(get(input$data)$final,"IT2B"))){
- #
- # x <- get(input$data)
- # args <- list(x=x,formula=getFormula(choices=names(get(input$data)$popMean)),cex.lab=input$cex.lab,col=getFinalPlotType()$col,
- # pch=input$pch,cex=input$cex,lwd=getFinalPlotType()$lwd,probs=getProbs(),standard=input$standard,legend=input$legend,
- # grid=input$grid,xlim=getXlim(),ylim=getYlim(),xlab=getXlab(),ylab=getYlab())
- # if(getFinalPlotType()$ptype=="uni"){args$formula <- NULL} #reset formula
- # args <- args[which(sapply(args,function(x) length(x)>0),arr.ind=T)]
- # do.call(plot.PMfinal,args)
- # } #end PMfinal, IT2B
-
- ############### Plot and Code: PM_result$op #####################
-
- if(!is.null(input$res_sub) && input$res_sub == "op"){
-
- #x argument
- x <- get(input$data)$op
-
- #resid sets different defaults for lines to follow
- resid <- setVal("resid", FALSE)
-
- #line argument
- op_lm <- setVal("op_lm", ifelse(resid, FALSE, TRUE))
- def_lm_fmt <- setVal("def_lm_fmt", TRUE)
- def_lm_args <- list(ci = 0.95, color = "dodgerblue", width = 1, dash = "solid")
- lm_ci <- setVal("lm_ci", def_lm_args$ci)
- lm_col <- setVal("lm_col", def_lm_args$color)
- lm_lwd <- setVal("lm_lwd", def_lm_args$width)
- lm_dash <- setVal("lm_dash", def_lm_args$dash)
-
- if(op_lm){ #yes have lm
- if(!def_lm_fmt){ #not default format?
- line <- list(lm = list(ci = lm_ci, color = lm_col, width = lm_lwd, dash = lm_dash))
- line$lm <- line$lm[!line$lm %in% def_lm_args] #keep only non-defaults
- if(length(line$lm)==0) line$lm <- TRUE
- } else { #default format
- if(resid) {
- line <- list(lm = TRUE) #only need if residual plot, as default for op plot
- } else {
- line <- list() #we have lm but don't need with default format and op plot
- }
- }
- } else { #don't have lm
- line <- list(lm = FALSE)
- }
-
- op_loess <- setVal("op_loess", ifelse(resid, TRUE, FALSE))
- def_loess_fmt <- setVal("def_loess_fmt", TRUE)
- def_loess_args <- list(ci = 0.95, color = "dodgerblue", width = 1, dash = "dash")
- loess_ci <- setVal("loess_ci", def_loess_args$ci)
- loess_col <- setVal("loess_col", def_loess_args$color)
- loess_lwd <- setVal("loess_lwd", def_loess_args$with)
- loess_dash <- setVal("loess_dash", def_loess_args$dash)
-
- if(op_loess){
- if(!def_loess_fmt){ #not default format?
- line <- modifyList(line, list(loess = list(ci = loess_ci, color = loess_col, width = loess_lwd, dash = loess_dash)))
- line$loess <- line$loess[!line$loess %in% def_loess_args] #keep only non-defaults
- if(length(line$loess)==0) line$loess <- TRUE
- } else { #default format
- if(!resid) line <- modifyList(line, list(loess = TRUE)) #only need if op plot, as default for resid plot
- }
- } else { #don't have loess
- if(resid) line <- modifyList(line, list(loess = FALSE)) #only add if resid plot, as default for this is TRUE
- }
-
- op_ref <- setVal("op_ref", TRUE) #regardless of resid
- def_ref_fmt <- setVal("def_ref_fmt", TRUE)
- def_ref_args <- list(color = "black", width = 1, dash = "dash")
- ref_col <- setVal("ref_col", def_ref_args$color)
- ref_lwd <- setVal("ref_lwd", def_ref_args$width)
- ref_dash <- setVal("ref_dash", def_ref_args$dash)
-
- if(op_ref){
- if(!def_ref_fmt){
- line <- modifyList(line, list(ref = list(color = ref_col, width = ref_lwd, dash = ref_dash)))
- line$ref <- line$ref[!line$ref %in% def_ref_args] #keep only non-defaults
- if(length(line$ref)==0) line$ref <- TRUE
- }
- } else {
- line <- modifyList(line, list(ref = FALSE) )
- }
-
- #marker argument
- def_marker_fmt <- setVal("def_marker_fmt", TRUE)
- def_marker_args <- list(color = "orange", symbol = "circle", size = 10, opacity = 0.5,
- line = list(width = 1, color = "black"))
-
- mrk_col <- setVal("mrk_col", "orange")
- mrk_symbol <- setVal("mrk_symbol", "circle")
- mrk_size <- setVal("mrk_size", 10)
- mrk_opacity <- setVal("mrk_opacity", 0.5)
- mrk_lwd <- setVal("mrk_lwd", 1)
- mrk_lcol <- setVal("mrk_lcol", "black")
-
- if(def_marker_fmt){
- marker <- TRUE
- } else {
- marker <- list(color = mrk_col, symbol = mrk_symbol, size = mrk_size,
- opacity = mrk_opacity, line = list(width = mrk_lwd, color = mrk_lcol))
- marker$line <- marker$line[!marker$line %in% def_marker_args$line] #keep only non-defaults
- if(length(marker$line)==0) marker$line <- NULL
- marker <- marker[!marker %in% def_marker_args]
- if(length(marker)==0) marker <- NULL
-
- }
-
- #include/exclude arguments
- if(!is.null(input$op_include)){
- if(input$op_include=="yes"){
- include <- input$op_select
- exclude <- NULL
- } else {
- include <- NULL
- exclude <- input$op_select
- }
- } else {
- include <- exclude <- NULL
- }
-
- #title argument
- def_title_fmt <- setVal("def_title_fmt", TRUE)
- def_title_args <- list(text = "", font = list(color = "black", size = 20, bold = TRUE))
- title_text <- setVal("title_text", "")
- title_col <- setVal("title_col", "black")
- title_bold <- setVal("title_bold", TRUE)
- title_size <- setVal("title_size", 20)
- if(def_title_fmt){
- title <- ""
- } else {
- title <- list(text = title_text, font = list(color = title_col, size = title_size,
- bold = title_bold))
- title$font <- title$font[!title$font %in% def_title_args$font] #keep only non-defaults
- if(length(title$font)==0) title$font <- NULL
-
- }
-
- #stats argument
- def_stats_fmt <- setVal("def_stats_fmt", TRUE)
- def_stats_args <- list(x = 0.8, y = 0.1, font = list(color = "black", size = 14, bold = FALSE))
- stats_col <- setVal("stats_col", "black")
- stats_size <- setVal("stats_size", 14)
- stats_bold <- setVal("stats_bold", FALSE)
- stats_x <- setVal("stats_x", 0.8)
- stats_y <- setVal("stats_y", 0.1)
- if(def_stats_fmt){
- stats <- TRUE
- } else {
- stats <- list(x = stats_x, y = stats_y, font = list(color = stats_col, size = stats_size,
- bold = stats_bold))
- stats$font <- stats$font[!stats$font %in% def_stats_args$font] #keep only non-defaults
- if(length(stats$font)==0) stats$font <- NULL
- stats <- stats[!stats %in% def_stats_args]
- if(length(stats)==0) stats <- NULL
- }
-
- #Other defaults
- icen <- setVal("icen", "median")
- pred.type <- setVal("pred.type", "post")
- outeq <- setVal("outeq", 1)
- block <- setVal("block", "All")
- mult <- setVal("mult", 1)
- log <- setVal("log", FALSE)
- grid <- setVal("grid", TRUE)
-
- if(block == "All") block <- NULL
-
-
- args <- list(x = x, line = line, marker = marker, resid = resid,
- icen = icen, pred.type = pred.type, outeq = as.numeric(outeq),
- block = block, include = include, exclude = exclude,
- mult = as.numeric(mult), log = log, grid = grid,
- title = title, stats = stats,
- xlab = getXlab(), ylab = getYlab(),
- xlim = getXlim(), ylim = getYlim())
- args <- args[which(sapply(args,function(x) length(x)>0),arr.ind=T)]
-
- #now make the code
- Name <- paste0(input$data,"$op$plot(")
- #default args
- def_args <- list(
- line = list(lm = TRUE, loess = FALSE, ref = TRUE),
- marker = TRUE,
- resid = FALSE,
- icen = "median", pred.type = "post", outeq = 1, block = NULL,
- include = as.character(unique(get(input$data)$op$id)), exclude = NULL,
- mult = 1,
- log = FALSE,
- grid = TRUE,
- xlab = NULL, ylab = NULL,
- title = "",
- stats = TRUE,
- xlim = NULL, ylim = NULL
- )
-
- if(resid) modifyList(def_args$line, list(lm = FALSE, loess = TRUE, ref = TRUE)) #modify default
-
- arglist <- args[-1] #remove the data object
- arglist <- arglist[map_lgl(intersect(names(arglist),names(def_args)), \(x) !identical(arglist[[x]], def_args[[x]]) )] #remove args that are in default list
- if(length(arglist)>0){
- arglist <- paste(deparse(arglist), collapse = "") %>% stringr::str_replace("^list\\(","") %>%
- stringr::str_replace_all("(\\d+)L","\\1") %>% stringr::str_replace_all(" +"," ")
- codeStatement <- paste0(Name, arglist)
- } else {
- codeStatement <- paste0(Name, ")")
- }
-
- p <- do.call(plot, args)
- if(code){
- return(codeStatement)
- } else {
- return(p)
- }
-
- } #end PM_op
-
- ############### Plot and Code: PM_result$cycle #####################
-
- if(!is.null(input$res_sub) && input$res_sub == "cyc"){
-
- x <- get(input$data)$cycle
-
- if(length(input$omit)==0) {omit <- 0.2} else {omit <- input$omit}
-
- #line argument
- def_ab_fmt <- setVal("def_ab_fmt", TRUE)
- def_a_args <- list(color = "dodgerblue", width = 1, dash = "solid")
- def_b_args <- list(colors = "Spectral", custom_colors = "", linetypes = "dash")
- a_col <- setVal("a_col", def_a_args$color)
- a_dash <- setVal("a_dash", def_a_args$dash)
- ab_lwd <- setVal("ab_lwd", def_a_args$width)
- b_col <- setVal("b_col", def_b_args$colors)
- b_custom_colors <- setVal("b_custom_colors", def_b_args$custom_colors)
- b_dash <- setVal("b_dash", def_b_args$linetypes)
-
-
- if(!def_ab_fmt){ #not default format?
- line <- list(color = a_col, width = ab_lwd, dash = a_dash)
- line <- line[!line %in% def_a_args] #keep only non-defaults
- if(length(line)==0) line <- TRUE
-
- linetypes <- b_dash
-
- if(b_custom_colors != ""){
- colors <- unlist(stringr::str_split(b_custom_colors, "\\s*,\\s*"))
- } else {
- colors <- b_col #built in palette
- }
-
- } else { #default format
- line <- list() #we have join but don't need with default format and data plot
- colors <- list()
- linetypes <- list()
- }
-
- #marker argument
- def_marker_fmt <- setVal("def_marker_fmt", TRUE)
- def_marker_args <- list(color = "dodgerblue", symbol = "circle", size = 4, opacity = 1,
- line = list(width = 0, color = "black"))
-
- mrk_col <- setVal("mrk_col", def_marker_args$col)
- mrk_symbol <- setVal("mrk_symbol", def_marker_args$shape)
- mrk_size <- setVal("mrk_size", def_marker_args$size)
- mrk_opacity <- setVal("mrk_opacity", def_marker_args$opacity)
- mrk_lwd <- setVal("mrk_lwd", def_marker_args$line$width)
- mrk_lcol <- setVal("mrk_lcol", def_marker_args$line$color)
-
- if(def_marker_fmt){
- marker <- TRUE
- } else {
- marker <- list(color = mrk_col, symbol = mrk_symbol, size = mrk_size,
- opacity = mrk_opacity, line = list(width = mrk_lwd, color = mrk_lcol))
- marker$line <- marker$line[!marker$line %in% def_marker_args$line] #keep only non-defaults
- if(length(marker$line)==0) marker$line <- NULL
- marker <- marker[!marker %in% def_marker_args]
- if(length(marker)==0) marker <- NULL
- }
-
- #Other defaults
- grid <- setVal("grid", TRUE)
-
- args <- list(
- x = x,
- line = line,
- marker = marker,
- colors = colors,
- linetypes = linetypes,
- omit = omit,
- grid = grid,
- xlab = getXlab(), ylab = getYlab()
- )
-
- args <- args[which(sapply(args,function(x) length(x)>0),arr.ind=T)]
- #now make the code
- Name <- paste0(input$data,"$cycle$plot(")
- #default args
- def_args <- list(
- line = TRUE,
- marker = TRUE,
- colors = NULL,
- linetypes = NULL,
- omit = 0.2,
- grid = TRUE,
- xlab = NULL, ylab = NULL
- )
-
- arglist <- args[-1] #remove the data object
- arglist <- arglist[map_lgl(intersect(names(arglist),names(def_args)), \(x) !identical(arglist[[x]], def_args[[x]]) )] #remove args that are in default list
- if(length(arglist)>0){
- arglist <- paste(deparse(arglist), collapse = "") %>% stringr::str_replace("^list\\(","") %>%
- stringr::str_replace_all("(\\d+)L","\\1") %>% stringr::str_replace_all(" +"," ")
- codeStatement <- paste0(Name, arglist)
- } else {
- codeStatement <- paste0(Name, ")")
- }
-
- p <- do.call(plot, args)
- if(code){
- return(codeStatement)
- } else {
- return(p)
- }
- } #end PMcycle
-
-
- ############### Plot and Code: PM_data & PM_result$data #####################
-
- if(inherits(get(input$data),"PM_data") ||
- (!is.null(input$res_sub) && input$res_sub == "dat")){
-
- #x argument
- if(inherits(get(input$data),"PM_result")){
- x <- get(input$data)$data
- }
-
- if(inherits(get(input$data),"PM_data")){
- x <- get(input$data)
- }
-
- #line argument
- join <- setVal("join", TRUE)
- def_join_fmt <- setVal("def_join_fmt", TRUE)
- def_join_args <- list(color = "dodgerblue", width = 1, dash = "solid")
- join_col <- setVal("join_col", def_join_args$color)
- join_lwd <- setVal("join_lwd", def_join_args$width)
- join_dash <- setVal("join_dash", def_join_args$dash)
-
- if(join){ #yes have join
- if(!def_join_fmt){ #not default format?
- line <- list(join = list(color = join_col, width = join_lwd, dash = join_dash))
- line$join <- line$join[!line$join %in% def_join_args] #keep only non-defaults
- if(length(line$join)==0) line$join <- TRUE
- } else { #default format
- line <- list() #we have join but don't need with default format and data plot
- }
- } else { #don't have join
- line <- list(join = FALSE)
- }
-
- incl_pred <- setVal("incl_pred", "none")
- def_pred_fmt <- setVal("def_pred_fmt", TRUE)
- def_pred_args <- list(color = "", width = 1, dash = "dash")
- pred_col <- setVal("pred_col", def_pred_args$color)
- pred_lwd <- setVal("pred_lwd", def_pred_args$width)
- pred_dash <- setVal("pred_dash", def_pred_args$dash)
-
- if(incl_pred != "none"){
- pred_obj <- get(input$data)[[incl_pred]]
- if(!def_pred_fmt){ #not default format?
- pred = list(color = pred_col, width = pred_lwd, dash = pred_dash)
- pred <- pred[!pred %in% def_pred_args] #keep only non-defaults
- if(length(pred)==0) {
- line$pred <- pred_obj
- } else {
- line$pred <- c(pred_obj, pred)
- }
- } else { #default format
- line$pred <- pred_obj
- }
- }
-
- #marker argument
- def_marker_fmt <- setVal("def_marker_fmt", TRUE)
- def_marker_args <- list(color = "red", symbol = "circle", size = 10, opacity = 0.5,
- line = list(width = 1, color = "black"))
-
- mrk_col <- setVal("mrk_col", def_marker_args$col)
- mrk_symbol <- setVal("mrk_symbol", def_marker_args$shape)
- mrk_size <- setVal("mrk_size", def_marker_args$size)
- mrk_opacity <- setVal("mrk_opacity", def_marker_args$opacity)
- mrk_lwd <- setVal("mrk_lwd", def_marker_args$line$width)
- mrk_lcol <- setVal("mrk_lcol", def_marker_args$line$color)
-
- if(def_marker_fmt){
- marker <- TRUE
- } else {
- marker <- list(color = mrk_col, symbol = mrk_symbol, size = mrk_size,
- opacity = mrk_opacity, line = list(width = mrk_lwd, color = mrk_lcol))
- marker$line <- marker$line[!marker$line %in% def_marker_args$line] #keep only non-defaults
- if(length(marker$line)==0) marker$line <- NULL
- marker <- marker[!marker %in% def_marker_args]
- if(length(marker)==0) marker <- NULL
-
- }
-
- #include/exclude arguments
- if(!is.null(input$data_include)){
- if(input$data_include=="yes"){
- include <- input$data_select
- exclude <- NULL
- } else {
- include <- NULL
- exclude <- input$data_select
- }
- } else {
- include <- exclude <- NULL
- }
-
- #title argument
- def_title_fmt <- setVal("def_title_fmt", TRUE)
- def_title_args <- list(text = "", font = list(color = "black", size = 20, bold = TRUE))
- title_text <- setVal("title_text", "")
- title_col <- setVal("title_col", "black")
- title_bold <- setVal("title_bold", TRUE)
- title_size <- setVal("title_size", 20)
- if(def_title_fmt){
- title <- ""
- } else {
- title <- list(text = title_text, font = list(color = title_col, size = title_size,
- bold = title_bold))
- title$font <- title$font[!title$font %in% def_title_args$font] #keep only non-defaults
- if(length(title$font)==0) title$font <- NULL
-
- }
-
- #group names
- names <- setVal("group_names", "")
- if(!is.null(names)){
- names <- unlist(stringr::str_split(names, "\\s*,\\s*"))
- }
-
- #legend
- if(!is.null(input$group) && input$group != "none"){
- legend <- setVal("legend", TRUE)
- } else {
- legend <- setVal("legend", FALSE)
- }
-
-
- #Other defaults
- color <- setVal("group", "none")
- colors <- setVal("group_col", "Set1")
- tad <- setVal("tad", FALSE)
- outeq <- setVal("outeq", 1)
- block <- setVal("block", 1)
- mult <- setVal("mult", 1)
- log <- setVal("log", FALSE)
- grid <- setVal("grid", FALSE)
-
- if(color == "none") color <- NULL
- if(block == "All") block <- 1
-
- args <- list(x = x,
- include = include, exclude = exclude,
- line = line, marker = marker,
- color = color,
- colors = colors,
- names = names,
- outeq = as.numeric(outeq),
- block = as.numeric(block),
- tad = tad,
- #overlay = FALSE,
- legend = legend,
- mult = as.numeric(mult), log = log, grid = grid,
- title = title,
- xlab = getXlab(), ylab = getYlab(),
- xlim = getXlim(), ylim = getYlim())
-
- args <- args[which(sapply(args,function(x) length(x)>0),arr.ind=T)]
-
-
-
- #now make the code
- if(inherits(get(input$data),"PM_result")){
- Name <- paste0(input$data,"$data$plot(")
- id_obj <- as.character(unique(get(input$data)$data$data$id))
- }
-
- if(inherits(get(input$data),"PM_data")){
- Name <- paste0(input$data,"$plot(")
- id_obj <- as.character(unique(get(input$data)$data$id))
-
- }
-
- #default args
-
- def_args <- list(
- include = id_obj, exclude = NULL,
- line = list(join = TRUE, pred = FALSE),
- marker = TRUE,
- color = NULL,
- colors = "Set1",
- names = "",
- mult = 1,
- outeq = 1, block = 1,
- tad = FALSE,
- legend = ifelse(!is.null(input$group) && input$group != "none", TRUE, FALSE),
- log = FALSE,
- grid = FALSE,
- xlab = NULL, ylab = NULL,
- title = "",
- stats = TRUE,
- xlim = NULL, ylim = NULL
- )
-
- arglist <- args[-1] #remove the data object
- if(incl_pred != "none"){ #replace pred object with its name if there
- if(inherits(arglist$line$pred, c("PM_pop", "PM_post"))){
- arglist$line$pred <- paste(input$data, incl_pred, sep = "$")
- } else {
- arglist$line$pred[[1]] <- paste(input$data, incl_pred, sep = "$")
- }
- }
- arglist <- arglist[map_lgl(intersect(names(arglist),names(def_args)), \(x) !identical(arglist[[x]], def_args[[x]]) )] #remove args that are in default list
- if(length(arglist)>0){
- arglist <- paste(deparse(arglist), collapse = "") %>% stringr::str_replace("^list\\(","") %>%
- stringr::str_replace_all("(\\d+)L","\\1") %>% stringr::str_replace_all(" +"," ")
- codeStatement <- paste0(Name, arglist)
- } else {
- codeStatement <- paste0(Name, ")")
- }
-
- codeStatement <- stringr::str_replace(codeStatement,
- "pred = \"(\\S+)\"",
- "pred = \\1")
-
- codeStatement <- stringr::str_replace(codeStatement,
- "pred = list\\(\"(\\S+)\"",
- "pred = list\\(\\1")
-
- p <- do.call(plot, args)
- if(code){
- return(codeStatement)
- } else {
- return(p)
- }
-
- } #end PM_data
-
- } #end check for PM_result
-
- ############### Plot and Code: PM_sim #####################
-
- if(!is.null(input$data) && inherits(get(input$data),"PM_sim")){
- #x argument
- x <- get(input$data)$data
-
- #line argument
- sim_line <- setVal("sim_line", TRUE)
- def_sim_line_fmt <- setVal("def_sim_line_fmt", TRUE)
- def_sim_args <- list(ci = 0.95,
- sim_probs = c(0.05,0.25,0.5,0.75,0.95),
- color = "dodgerblue", width = 1, dash = "solid")
- sim_ci <- setVal("sim_ci", def_sim_args$ci)
- sim_probs <- setVal("sim_probs", def_sim_args$sim_probs)
- sim_col <- setVal("sim_col", def_sim_args$color)
- sim_lwd <- setVal("sim_lwd", def_sim_args$width)
- sim_dash <- setVal("sim_dash", def_sim_args$dash)
-
- if(sim_line){ #yes have line
- if(!def_sim_line_fmt){ #not default format?
- line <- list(probs = sim_probs, color = sim_col, width = sim_lwd, dash = sim_dash)
- line <- line[!line %in% def_sim_args] #keep only non-defaults
- if(length(line)==0) line <- TRUE
- } else { #default format
- line <- list()
- }
- } else { #don't have line
- line <- FALSE
- }
-
-
- #marker argument
- sim_obs <- setVal("sim_obs", NULL)
- obs_name <- ""
- if(!is.null(sim_obs)){
- if(sim_obs == "None"){
- sim_obs <- NULL
- } else {
- obs_name <- sim_obs
- sim_obs <- get(sim_obs)
- }
- }
-
-
- def_sim_marker_fmt <- setVal("def_sim_marker_fmt", TRUE)
- def_marker_args <- list(color = "black", symbol = "circle-open", size = 8, opacity = 0.5,
- line = list(width = 1, color = "black"))
-
- mrk_col <- setVal("mrk_col", def_marker_args$color)
- mrk_symbol <- setVal("mrk_symbol", def_marker_args$symbol)
- mrk_size <- setVal("mrk_size", def_marker_args$size)
- mrk_opacity <- setVal("mrk_opacity", def_marker_args$opacity)
- mrk_lwd <- setVal("mrk_lwd", def_marker_args$lwd)
- mrk_lcol <- setVal("mrk_lcol", def_marker_args$lcol)
-
- if(!is.null(sim_obs)){
- if(def_sim_marker_fmt){
- marker <- TRUE
- } else {
- marker <- list(color = mrk_col, symbol = mrk_symbol, size = mrk_size,
- opacity = mrk_opacity, line = list(width = mrk_lwd, color = mrk_lcol))
- marker$line <- marker$line[!marker$line %in% def_marker_args$line] #keep only non-defaults
- if(length(marker$line)==0) marker$line <- NULL
- marker <- marker[!marker %in% def_marker_args]
- if(length(marker)==0) marker <- NULL
- }
- } else {
- marker <- FALSE
- }
-
- #title argument
- def_title_fmt <- setVal("def_title_fmt", TRUE)
- def_title_args <- list(text = "", font = list(color = "black", size = 20, bold = TRUE))
- title_text <- setVal("title_text", "")
- title_col <- setVal("title_col", "black")
- title_bold <- setVal("title_bold", TRUE)
- title_size <- setVal("title_size", 20)
- if(def_title_fmt){
- title <- ""
- } else {
- title <- list(text = title_text, font = list(color = title_col, size = title_size,
- bold = title_bold))
- title$font <- title$font[!title$font %in% def_title_args$font] #keep only non-defaults
- if(length(title$font)==0) title$font <- NULL
-
- }
-
- #Other defaults
- log <- setVal("log", TRUE)
- grid <- setVal("grid", TRUE)
- mult <- setVal("mult", 1)
- outeq <- setVal("outeq", 1)
- binSize <- setVal("binSize", 0)
- simnum <- setVal("simchooser", 1)
-
-
-
- args <- list(x = x,
- mult = as.numeric(mult),
- ci = as.numeric(sim_ci),
- binSize = as.numeric(binSize),
- outeq = as.numeric(outeq),
- line = line,
- marker = marker,
- obs = sim_obs,
- log = log,
- grid = grid,
- title = title,
- xlab = getXlab(), ylab = getYlab(),
- xlim = getXlim(), ylim = getYlim(),
- simnum = simnum)
-
-
-
- args <- args[which(sapply(args,function(x) length(x)>0),arr.ind=T)]
-
- #now make the code
- Name <- paste0(input$data,"$plot(")
- #default args
- def_args <- list(
- mult = 1,
- ci = 0.95,
- binSize = 0,
- outeq = 1,
- line = TRUE,
- marker = ifelse(is.null(sim_obs), FALSE, TRUE),
- obs = NULL,
- log = TRUE,
- grid = TRUE,
- xlab = NULL, ylab = NULL,
- title = "",
- xlim = NULL, ylim = NULL,
- simnum = 1
- )
-
- arglist <- args[-1] #remove the data object
- if(!is.null(arglist$obs)){
- arglist$obs <- obs_name
- }
- arglist <- arglist[map_lgl(intersect(names(arglist),names(def_args)), \(x) !identical(arglist[[x]], def_args[[x]]) )] #remove args that are in default list
-
- if(length(arglist)>0){
- arglist <- paste(deparse(arglist), collapse = "") %>% stringr::str_replace("^list\\(","") %>%
- stringr::str_replace_all("(\\d+)L","\\1") %>% stringr::str_replace_all(" +"," ")
- codeStatement <- paste0(Name, arglist)
- } else {
- codeStatement <- paste0(Name, ")")
- }
-
-
-
- codeStatement <- stringr::str_replace(codeStatement,
- "obs = \"(\\S+)\"",
- "obs = \\1")
-
-
- p <- do.call(plot, args)
- if(code){
- return(codeStatement)
- } else {
- return(p$p)
- }
-
- } #end PM_sim
-
- ############### Plot and Code: PM_model & PM_result$model #####################
-
- if(!is.null(input$data) &&
- (inherits(get(input$data),"PM_model") |
- (inherits(get(input$data),"PM_result")
- && !is.null(input$res_sub) && input$res_sub == "mod"))){
-
- #x argument
- if(inherits(get(input$data),"PM_result")){
- x <- get(input$data)$model
- }
-
- if(inherits(get(input$data),"PM_model")){
- x <- get(input$data)
- }
-
- #line argument
- join <- setVal("join", TRUE)
- def_join_fmt <- setVal("def_join_fmt", TRUE)
- def_join_args <- list(color = "black", width = 1, dash = "solid")
- join_col <- setVal("join_col", def_join_args$color)
- join_lwd <- setVal("join_lwd", def_join_args$width)
- join_dash <- setVal("join_dash", def_join_args$dash)
-
- if(join){ #yes have join
- if(!def_join_fmt){ #not default format?
- line <- list(color = join_col, width = join_lwd, dash = join_dash)
- line <- line[!line %in% def_join_args] #keep only non-defaults
- if(length(line)==0) line <- TRUE
- } else { #default format
- line <- list() #we have line but don't need with default format and model plot
- }
- } else { #don't have join
- line <- FALSE
- }
-
- #marker argument
- def_marker_fmt <- setVal("def_marker_fmt", TRUE)
- def_marker_args <- list(color = "dodgerblue", size = 0.25, opacity = 0.5,
- line = list(width = 1, color = "black"))
-
- mrk_col <- setVal("mrk_col", def_marker_args$col)
- mrk_size <- setVal("mrk_size", def_marker_args$size)
- mrk_opacity <- setVal("mrk_opacity", def_marker_args$opacity)
- mrk_lwd <- setVal("mrk_lwd", def_marker_args$line$width)
- mrk_lcol <- setVal("mrk_lcol", def_marker_args$line$color)
-
- if(def_marker_fmt){
- marker <- TRUE
- } else {
- marker <- list(color = mrk_col, size = mrk_size,
- opacity = mrk_opacity, line = list(width = mrk_lwd, color = mrk_lcol))
- marker$line <- marker$line[!marker$line %in% def_marker_args$line] #keep only non-defaults
- if(length(marker$line)==0) marker$line <- NULL
- marker <- marker[!marker %in% def_marker_args]
- if(length(marker)==0) marker <- NULL
-
- }
-
- #Other defaults
- args <- list(x = x,
- line = line, marker = marker)
-
-
- args <- args[which(sapply(args,function(x) length(x)>0),arr.ind=T)]
-
-
-
- #now make the code
- if(inherits(get(input$data),"PM_result")){
- Name <- paste0(input$data,"$model$plot(")
- }
-
- if(inherits(get(input$data),"PM_model")){
- Name <- paste0(input$data,"$plot(")
- }
-
-
- #default args
-
- def_args <- list(
- line = TRUE,
- marker = TRUE
- )
-
- arglist <- args[-1] #remove the data object
- arglist <- arglist[map_lgl(intersect(names(arglist),names(def_args)), \(x) !identical(arglist[[x]], def_args[[x]]) )] #remove args that are in default list
- if(length(arglist)>0){
- arglist <- paste(deparse(arglist), collapse = "") %>% stringr::str_replace("^list\\(","") %>%
- stringr::str_replace_all("(\\d+)L","\\1") %>% stringr::str_replace_all(" +"," ")
- codeStatement <- paste0(Name, arglist)
- } else {
- codeStatement <- paste0(Name, ")")
- }
-
- p <- do.call(plot, args)
- if(code){
- return(codeStatement)
- } else {
- return(p)
- }
-
- } #end PM_model
-
- return(NULL) #plot method not defined
-
- } #end makePMplot
-
-
-
- ####################################################
- ############### Build the Page #####################
- ####################################################
-
- output$help <- renderText({
- if(inherits(get(input$data),"PM_cov")){return("To get help with this plot in R, type ?plot.PMcov.")}
- if(inherits(get(input$data),"PM_final")){return("To get help with this plot in R, type ?plot.PMfinal.")}
- if(inherits(get(input$data),"PM_op")){return("To get help with this plot in R, type ?plot.PMop.")}
- if(inherits(get(input$data),"PMcycle")){return("To get help with this plot in R, type ?plot.PMcycle.")}
- if(inherits(get(input$data),"PMmatrix")){return("To get help with this plot in R, type ?plot.PMmatrix.")}
- if(inherits(get(input$data),"PMsim")){return("To get help with this plot in R, type ?plot.PMsim.")}
-
- })
-
- #Set up the inputs
- output$DataControls <- renderUI({makeDataControls()})
- output$FormatControls <- renderUI({makeFormatControls()})
- output$AxesControls <- renderUI({makeAxisControls()})
-
-
- #Build the Pmetrics plot statements
- output$plotCode <- renderText({makePMplot(code = TRUE)})
-
- #Make the plot call
- output$plotPM <- renderUI({
- if(!is.null(input$data) &&
- (inherits(get(input$data),"PM_model") ||
- (inherits(get(input$data),"PM_result") &&
- !is.null(input$res_sub) && input$res_sub == "mod"))){
- renderPlot({makePMplot()})
- } else {
- p <- makePMplot()
- if(inherits(p, "plotly")){ #need this to avoid warning message
- renderPlotly({p})
- }
- }
- })
-
-
-
-
-
- } #end shinyServer
-
- ) #end shiny App
-
-} #end function
-
-#shinyApp(ui, server)
diff --git a/R/makeValid.R b/R/makeValid.R
index d521fdca..c7776bca 100644
--- a/R/makeValid.R
+++ b/R/makeValid.R
@@ -57,8 +57,8 @@
make_valid <- function(result, tad = F, binCov, doseC, timeC, tadC, limits, ...) {
# verify packages used in this function
- if(!requireNamespace("mclust", quietly = TRUE)){
- stop("Install mclust package to perform clustering for validation.\n")
+ if(!checkRequiredPackages(c("mclust", "npde"), quietly = FALSE)){
+ return(invisible(NULL))
}
# save current wd
diff --git a/R/plot.PM_model.R b/R/plotPM_model.R
similarity index 99%
rename from R/plot.PM_model.R
rename to R/plotPM_model.R
index 3d4501b1..9154a1d1 100644
--- a/R/plot.PM_model.R
+++ b/R/plotPM_model.R
@@ -58,6 +58,9 @@
plot.PM_model <- function(x, marker = TRUE, line = TRUE, explicit, implicit,...) {
+ if(!checkRequiredPackages("PmetricsApps", repos = "LAPKB/PmetricsApps", quietly = FALSE)){
+ return(invisible(NULL))
+ }
model <- x
marker <- if(is.list(marker) || marker){
amendMarker(marker, default = list(color = "dodgerblue", size = 0.25, line = list(width = 0.5)))
diff --git a/R/plotPMcov.R b/R/plotPMcov.R
index ef2ea766..00bd28d8 100644
--- a/R/plotPMcov.R
+++ b/R/plotPMcov.R
@@ -306,7 +306,7 @@ plot.PM_cov <- function(x,
n_colors <- length(unique(dat$id))
- if(requireNamespace("RColorBrewer", quietly = TRUE)){
+ if(checkRequiredPackages("RColorBrewer")){
palettes <- RColorBrewer::brewer.pal.info %>% mutate(name = rownames(.))
max_colors <- palettes$maxcolors[match(colors, palettes$name)]
# expand colors as needed
diff --git a/R/plotPMmatrix.R b/R/plotPMmatrix.R
index 4098293f..89330823 100644
--- a/R/plotPMmatrix.R
+++ b/R/plotPMmatrix.R
@@ -324,7 +324,7 @@ plot.PM_data <- function(x,
if (!all(is.na(allsub$group)) && any(allsub$group != "")) { # there was grouping
n_colors <- length(levels(allsub$group))
- if(requireNamespace("RColorBrewer", quietly = TRUE)){
+ if(checkRequiredPackages("RColorBrewer")){
palettes <- RColorBrewer::brewer.pal.info %>% mutate(name = rownames(.))
if (length(colors) == 1 && colors %in% palettes$name) {
max_colors <- palettes$maxcolors[match(colors, palettes$name)]
@@ -402,7 +402,8 @@ plot.PM_data <- function(x,
p <- dataPlot(allsub, overlay = TRUE, includePred)
print(p)
} else { # overlay = FALSE, ie. split them
- if(!requireNamespace("trelliscopejs", quietly = TRUE)){
+
+ if(!checkRequiredPackages("trelliscopejs")){
stop(paste0("Package trelliscopejs required to plot when overlay = ", crayon::red("FALSE")))
}
sub_split <- allsub %>%
diff --git a/R/plotPMvalid.R b/R/plotPMvalid.R
index 868a5e72..08a43b74 100644
--- a/R/plotPMvalid.R
+++ b/R/plotPMvalid.R
@@ -353,7 +353,9 @@ plot.PM_valid <- function(x,
}
if (type == "npde") {
- requireNamespace("npde", quietly = TRUE)
+ if(!checkRequiredPackages("npde", quietly = FALSE)){
+ return(invisible(NULL))
+ }
if (!tad) {
if (is.null(x$npde)) stop("No npde object found. Re-run $validate or make_valid.\n")
if (inherits(x$npde[[outeq]], "NpdeObject")) {
diff --git a/R/plotly_Utils.R b/R/plotly_Utils.R
index 021f98a1..2afa0420 100644
--- a/R/plotly_Utils.R
+++ b/R/plotly_Utils.R
@@ -825,9 +825,22 @@ sub_plot <- function(...,
}
-#get RColorBrewerPalettes
+#' @title Get color palette
+#' @description
+#' `r lifecycle::badge("stable")`
+#'
+#' Generate list of palettes for plots.
+#' @details
+#' If RColorBrewer package is installed, will return the list of palette names from
+#' RColorBrewer::brewer.pal.info. If not, will return the current list as of April 2024.
+#' @return A character vector of palette names.
+#' @export
+#' @examples
+#' getPalettes()
+#' @author Michael Neely
+
getPalettes <- function(){
- if (requireNamespace("RColorBrewer", quietly = TRUE)) {
+ if (checkRequiredPackages("RColorBrewer")) {
palettes <- rownames(RColorBrewer::brewer.pal.info)
} else {
palettes <- c("BrBG", "PiYG", "PRGn", "PuOr", "RdBu", "RdGy", "RdYlBu",
@@ -840,7 +853,23 @@ getPalettes <- function(){
return(palettes)
}
-#create list of n default colors
+
+#' @title Get a list of default colors
+#' @description
+#' `r lifecycle::badge("stable")`
+#'
+#' Generate list of default color names.
+#' @details
+#' Used for Pmetrics plots. The following list is recycled as necessary to generate the
+#' requested number of colors.
+#' `c("red", "green", "blue", "brown", "black", "purple", "pink", "gold", "orange", "grey60")`
+#' @param n The number of colors to return from the list.
+#' @return A character vector of color names, which is recycled as needed.
+#'
+#' @export
+#' @examples
+#' getDefaultColors(6)
+#' @author Michael Neely
getDefaultColors <- function(n){
choices <- c("red", "green", "blue", "brown", "black", "purple", "pink", "gold", "orange", "grey60")
selection <- rep(choices, n)[1:n]
diff --git a/R/zzz.R b/R/zzz.R
index 2004db9f..4bab69f2 100644
--- a/R/zzz.R
+++ b/R/zzz.R
@@ -58,7 +58,7 @@
# check for PmetricsData
if (!suppressWarnings(suppressMessages(requireNamespace("PmetricsData")))) {
- packageStartupMessage(paste0(crayon::green("Important: "), "PmetricsData package required for examples. Run getPMdata() to install from github.\n"))
+ packageStartupMessage(paste0(crayon::green("Important: "), "PmetricsData package required for examples. Run remotes::install_github('LAPKB/PmetricsData') to install.\n"))
}
# set user options for the session
diff --git a/_pkgdown.yml b/_pkgdown.yml
index 10f606be..e4b22813 100644
--- a/_pkgdown.yml
+++ b/_pkgdown.yml
@@ -65,8 +65,6 @@ reference:
- fixed
- msd
- proportional
- - build_model
- - build_plot
- title: Make functions
desc: Functions for making Pmetrics objects
- contents:
@@ -96,10 +94,9 @@ reference:
desc: Run functions for modeling or simulating data
- contents: ends_with("run")
- title: Parse/load
- desc: Parse functions for loading modeled or simulated data
+ desc: Parse functions for modeled or simulated data
- contents:
- ends_with("parse")
- - PMload
- title: Auxilliary
desc: Auxilliary functions
- contents:
@@ -107,7 +104,7 @@ reference:
- zBMI
- ss.PK
- mtsknn.eq
- - PMcompare
+ - PM_compare
- PMgetCRCL
- PMstep
- title: Datasets
@@ -133,11 +130,9 @@ reference:
- PMlogout
- PMpatch
- PMregister
- - PMreport
- ERRreport
- PMsave
- PMtest
- - PMupdate
- getPMoptions
- setPMoptions
- editPMoptions
diff --git a/man/PMupdate.Rd b/man/PMupdate.Rd
deleted file mode 100644
index 66cf3db7..00000000
--- a/man/PMupdate.Rd
+++ /dev/null
@@ -1,22 +0,0 @@
-% Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/PMupdate.R
-\name{PMupdate}
-\alias{PMupdate}
-\title{Download and install Pmetrics updates}
-\usage{
-PMupdate(force = F)
-}
-\arguments{
-\item{force}{Boolean operator to force downloading and installing. Default is false.}
-}
-\value{
-The latest system-specific Pmetrics update will be downloaded to a temporary
-folder and then installed. You need to restart R (Rstudio) and then reload Pmetrics with
-the \code{library(Pmetrics)} command to complete the installation.
-}
-\description{
-Download and install Pmetrics updates from LAPK website
-}
-\author{
-Michael Neely
-}
diff --git a/man/build_model.Rd b/man/build_model.Rd
deleted file mode 100644
index 536a67f6..00000000
--- a/man/build_model.Rd
+++ /dev/null
@@ -1,27 +0,0 @@
-% Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/build_model.R
-\name{build_model}
-\alias{build_model}
-\title{Launch Model Builder app}
-\usage{
-build_model(...)
-}
-\arguments{
-\item{...}{Optional \link{PM_data} and/or \link{PM_model} object(s). \emph{PM_data} objects
-supply covariates. \emph{PM_model} objects supply any other defined model element,
-and covariates only if there is no \emph{PM_data} object or it has no covariates.
-If the \emph{PM_model} object contains covariates, they will be superseded by those in
-the \emph{PM_data} object, if supplied.}
-}
-\value{
-Launches the shiny app.
-}
-\description{
-Open the shiny model builder app.
-}
-\details{
-The app will open in a separate window.
-}
-\author{
-Michael Neely
-}
diff --git a/man/build_plot.Rd b/man/build_plot.Rd
deleted file mode 100644
index 565b6224..00000000
--- a/man/build_plot.Rd
+++ /dev/null
@@ -1,25 +0,0 @@
-% Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/build_plot.R
-\name{build_plot}
-\alias{build_plot}
-\title{Launch Plot Builder app}
-\usage{
-build_plot(x, ...)
-}
-\arguments{
-\item{x}{Optional object to plot}
-
-\item{\dots}{Not currently used}
-}
-\value{
-Launches the shiny app.
-}
-\description{
-Open the shiny plot builder app.
-}
-\details{
-The app will open in a separate window.
-}
-\author{
-Michael Neely
-}
diff --git a/man/getCov.Rd b/man/getCov.Rd
new file mode 100644
index 00000000..53f03455
--- /dev/null
+++ b/man/getCov.Rd
@@ -0,0 +1,31 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/PMutilities.R
+\name{getCov}
+\alias{getCov}
+\title{Extract covariate information}
+\usage{
+getCov(mdata)
+}
+\arguments{
+\item{mdata}{A \link{PM_data} or \emph{PMmatrix} object}
+}
+\value{
+A list with named items: \emph{ncov, covnames, covstart, covend}.
+}
+\description{
+\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#stable}{\figure{lifecycle-stable.svg}{options: alt='[Stable]'}}}{\strong{[Stable]}}
+
+Extracts covariate information from a Pmetrics data objects.
+}
+\details{
+When given a \link{PM_data} or \emph{PMmatrix} object, will return a list
+with the number of covariates, their names, and the starting and
+ending column numbers
+}
+\examples{
+library(PmetricsData)
+getCov(dataEx)
+}
+\author{
+Michael Neely
+}
diff --git a/man/getDefaultColors.Rd b/man/getDefaultColors.Rd
new file mode 100644
index 00000000..b7c64b3b
--- /dev/null
+++ b/man/getDefaultColors.Rd
@@ -0,0 +1,30 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/plotly_Utils.R
+\name{getDefaultColors}
+\alias{getDefaultColors}
+\title{Get a list of default colors}
+\usage{
+getDefaultColors(n)
+}
+\arguments{
+\item{n}{The number of colors to return from the list.}
+}
+\value{
+A character vector of color names, which is recycled as needed.
+}
+\description{
+\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#stable}{\figure{lifecycle-stable.svg}{options: alt='[Stable]'}}}{\strong{[Stable]}}
+
+Generate list of default color names.
+}
+\details{
+Used for Pmetrics plots. The following list is recycled as necessary to generate the
+requested number of colors.
+\code{c("red", "green", "blue", "brown", "black", "purple", "pink", "gold", "orange", "grey60")}
+}
+\examples{
+getDefaultColors(6)
+}
+\author{
+Michael Neely
+}
diff --git a/man/getFixedColNames.Rd b/man/getFixedColNames.Rd
new file mode 100644
index 00000000..d5352a96
--- /dev/null
+++ b/man/getFixedColNames.Rd
@@ -0,0 +1,23 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/PMconfig.R
+\name{getFixedColNames}
+\alias{getFixedColNames}
+\title{Names of fixed columns}
+\usage{
+getFixedColNames()
+}
+\value{
+A vector of fixed column names:
+\code{c("id", "evid", "time", "dur", "dose", "addl", "ii", "input", "out", "outeq", "c0", "c1", "c2", "c3")}
+}
+\description{
+\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#stable}{\figure{lifecycle-stable.svg}{options: alt='[Stable]'}}}{\strong{[Stable]}}
+
+Returns the names of fixed columns (non-covariate) in Pmetrics data objects.
+}
+\examples{
+getFixedColNames()
+}
+\author{
+Michael Neely
+}
diff --git a/man/getFixedColNum.Rd b/man/getFixedColNum.Rd
new file mode 100644
index 00000000..c5d11606
--- /dev/null
+++ b/man/getFixedColNum.Rd
@@ -0,0 +1,22 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/PMconfig.R
+\name{getFixedColNum}
+\alias{getFixedColNum}
+\title{Number of fixed columns}
+\usage{
+getFixedColNum()
+}
+\value{
+An integer with the number of fixed columns.
+}
+\description{
+\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#stable}{\figure{lifecycle-stable.svg}{options: alt='[Stable]'}}}{\strong{[Stable]}}
+
+Returns the number of fixed columns (non-covariate) in Pmetrics data objects.
+}
+\examples{
+getFixedColNum()
+}
+\author{
+Michael Neely
+}
diff --git a/man/getPMdata.Rd b/man/getPMdata.Rd
deleted file mode 100644
index 491f0647..00000000
--- a/man/getPMdata.Rd
+++ /dev/null
@@ -1,18 +0,0 @@
-% Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/PMutilities.R
-\name{getPMdata}
-\alias{getPMdata}
-\title{Get Pmetrics package example data}
-\usage{
-getPMdata()
-}
-\description{
-\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#stable}{\figure{lifecycle-stable.svg}{options: alt='[Stable]'}}}{\strong{[Stable]}}
-
-Get the data and examples for the Pmetrics package.
-}
-\details{
-This function installs the \strong{PmetricsData} package available on github.
-The repository URL is \url{https://github.com/LAPKB/PmetricsData}. These data
-are used in all Pmetrics examples.
-}
diff --git a/man/getPalettes.Rd b/man/getPalettes.Rd
new file mode 100644
index 00000000..222c0f87
--- /dev/null
+++ b/man/getPalettes.Rd
@@ -0,0 +1,26 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/plotly_Utils.R
+\name{getPalettes}
+\alias{getPalettes}
+\title{Get color palette}
+\usage{
+getPalettes()
+}
+\value{
+A character vector of palette names.
+}
+\description{
+\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#stable}{\figure{lifecycle-stable.svg}{options: alt='[Stable]'}}}{\strong{[Stable]}}
+
+Generate list of palettes for plots.
+}
+\details{
+If RColorBrewer package is installed, will return the list of palette names from
+RColorBrewer::brewer.pal.info. If not, will return the current list as of April 2024.
+}
+\examples{
+getPalettes()
+}
+\author{
+Michael Neely
+}
diff --git a/man/plot.PM_model.Rd b/man/plot.PM_model.Rd
index 083db579..4aa29913 100644
--- a/man/plot.PM_model.Rd
+++ b/man/plot.PM_model.Rd
@@ -1,5 +1,5 @@
% Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/plot.PM_model.R
+% Please edit documentation in R/plotPM_model.R
\name{plot.PM_model}
\alias{plot.PM_model}
\title{Plot PM_model objects}
diff --git a/vignettes/articles/models.Rmd b/vignettes/articles/models.Rmd
index 21bbab0f..d098da17 100644
--- a/vignettes/articles/models.Rmd
+++ b/vignettes/articles/models.Rmd
@@ -37,7 +37,12 @@ the three model pathways, and we'll cover the details in this document.
### Model Builder App
-To launch the app, type the following into your console: `build_model()`.
+To launch the app, type the following into your console:
+
+```{r echo = T, eval = F}
+library(PmetricsApps)
+build_model()
+```
You can supply a `PM_data` and/or a `PM_model` as optional arguments to
the function, e.g. `build_model(NPex$data)` or `build_model(NPex$model)` or
even `build_model(NPex$data, NPex$model)`. The order of data and/or model