inst/ShinyStan/ui_utils.R

In shinystan: Interactive Visual and Numerical Diagnostics and Posterior Analysis for Bayesian Models

source_ui <- function(...) {
  source(
    file.path("ui_files", ...),
    local = TRUE
  )$value
}

save_and_close_button <- function() {
  tags$button(
    id = 'save_and_close_button',
    type = "button",
    class = "btn action-button",
    onclick = "window.close();",
    "Save & Close"
  )
}

shinystan_version <- function() {
  # prevents error when deployed to shinyapps.io
  ver <- try(utils::packageVersion("shinystan"))
  if (inherits(ver, "try-error"))
    return()
  else
    strong(paste("Version", ver))
}

logo_and_name <- function() {
  div(div(
    img(
      src = "wide_ensemble.png",
      class = "wide-ensemble",
      width = "100%"
    )
  ),
  div(
    style = "margin-top: 25px",
    img(src = "stan_logo.png", class = "stan-logo"),
    div(id = "shinystan-title", "ShinyStan")
  ))
}


# save and close reminder -------------------------------------------------
save_and_close_reminder <- function(id) {
  helpText(
    id = id,
    p(
      "To make sure the changes aren't lost, use the",
      span(class = "save-close-reminder", "Save & Close"),
      "button in the top left corner to exit the app before",
      "closing the browser window."
    )
  )
}


# show/hide options/glossary ---------------------------------------------
a_options <- function(name) {
  lab <- if (name == "table")
    "Table Options" else "Show/Hide Options"
  div(class = "aoptions",
      checkboxInput(
        inputId = paste0(name, "_options_show"),
        label = strong(style = "margin-top: 20px; color: #222222;", lab),
        value = FALSE
      ))
}
a_glossary <- function(id) {
  div(class = "aoptions",
      actionLink(
        inputId = id,
        label = strong(style = "margin-top: 20px; color: #222222;", "Glossary"),
        icon = icon("book", lib = "glyphicon")
      ))
}



# plotOutput generators ---------------------------------------------------
dygraphOutput_175px <- function(id)
  dygraphs::dygraphOutput(id, height = "175px")
plotOutput_200px <- function(id, ...)
  plotOutput(id, height = "200px")
plotOutput_400px <- function(id, ...)
  plotOutput(id, height = "400px")



# conditionalPanel generator for EXPLORE/density  -------------------------
condPanel_dens_together <- function(...) {
  conditionalPanel(condition = "input.dens_chain_split == 'Together'", ...)
}
condPanel_dens_prior <- function(dist, ...) {
  cond <- paste0("input.dens_prior ==","'", dist,"'")
  conditionalPanel(cond, ...)
}


# conditional transparency settings ---------------------------------------
alpha_calc_pt <- function(N) {
  if (N <= 100) return(1)
  else if (N <= 200) return(0.75)
  else if (N >= 1500) return(0.15)
  else 1 - pnorm(N/1500)
}

alpha_calc_lines <- function(N) {
  if (N < 50) return(0.5)
  if (N < 500) return(0.4)
  if (N < 1000) return(0.3)
  if (N < 5000) return(0.2)
  else return(0.1)
}


# transformations ---------------------------------------------------------
transformation_selectInput <- function(id) {
  selectInput(
    id,
    label = NULL,
    choices = transformation_choices,
    selected = "identity"
  )
}

transform_helpText <- function(var = "x") {
  div(
    if (var == "x")
      helpText(style = "font-size: 13px;",
               "To apply a transformation",
               "select a function and click",
               code("Transform"))
    else if (var == "x,y")
      helpText(style = "font-size: 13px;",
               "To apply transformations",
               "select a function for x and/or y",
               "and click", code("Transform"))
    else
      helpText(style = "font-size: 13px;",
               "To apply transformations",
               "select a function for x, y, and/or z",
               "and click", code("Transform"))
  )
}


# diagnostics help text ---------------------------------------------------
hT11 <- function(...)
  helpText(style = "font-size: 11px;", ...)
help_interval <- hT11("Highlighted interval shows \\(\\bar{x} \\pm sd(x)\\)")
help_lines <- hT11("Lines are mean (solid) and median (dashed)")
help_max_td <- hT11("Horizontal line indicates the max_treedepth setting")
help_points <- hT11(
  "Large red points indicate which (if any) iterations",
  "encountered a divergent transition. Yellow indicates",
  "a transition hitting the maximum treedepth."
)
help_dynamic <- hT11(
  "Use your mouse to select a range in the traceplot to zoom into. ",
  "The other plots on the screen will update accordingly. ",
  "Double-click to reset."
)



# ppcheck plot descriptions ----------------------------------------------
plot_descriptions <-
  c(
    plot_hists_rep_vs_obs = "Distributions of observed data and a random sample of replications",
    plot_dens_rep_vs_obs = "Density estimate of observed data (blue) and a random sample of replications",
    plot_obs_vs_avg_y_rep = "Observations vs average simulated value",
    plot_hist_resids = "Residuals",
    plot_avg_rep_vs_avg_resid_rep = "Average simulated value vs average residual",
    plot_test_statistics = "Distributions of test statistics \\(T(y^{rep})\\)"
  )



# stan manual reference ---------------------------------------------------
stan_manual <- function() {
  helpText(
    style = "font-size: 12px;",
    "Glossary entries are compiled (with minor edits) from various excerpts of the",
    a(
      "Stan Modeling Language User's Guide and Reference Manual",
      href = "http://mc-stan.org/documentation/"
    ),
    "(",
    a(href = "http://creativecommons.org/licenses/by/3.0/", "CC BY (v3)"),
    ")"
  )
}


# objects to use in ui.R and ui_files -------------------------------------
if (!exists(".SHINYSTAN_OBJECT")) {
  .SHINYSTAN_OBJECT <- shinystan:::.sso_env[[".SHINYSTAN_OBJECT"]]
}
.model_name <- slot(.SHINYSTAN_OBJECT, "model_name")
.param_names <- slot(.SHINYSTAN_OBJECT, "param_names")
.param_list <- .make_param_list(.SHINYSTAN_OBJECT)
.param_list_with_groups <- .make_param_list_with_groups(.SHINYSTAN_OBJECT)
.nChains <- slot(.SHINYSTAN_OBJECT, "n_chain")
.nIter <- slot(.SHINYSTAN_OBJECT, "n_iter")
.nWarmup <- slot(.SHINYSTAN_OBJECT, "n_warmup")
.model_code <- slot(.SHINYSTAN_OBJECT, "model_code")
.notes <- slot(.SHINYSTAN_OBJECT, "user_model_info")
.has_rstanarm_ppcs <-
  isTRUE(.SHINYSTAN_OBJECT@misc$stanreg) &&
  !is.null(.SHINYSTAN_OBJECT@misc$pp_check_plots)

if (exists("object"))
  rm(object)
if (exists(".SHINYSTAN_OBJECT"))
  rm(.SHINYSTAN_OBJECT)
gc()