shinystan/ 0000755 0001762 0000144 00000000000 13271757566 012315 5 ustar ligges users shinystan/inst/ 0000755 0001762 0000144 00000000000 13271714530 013252 5 ustar ligges users shinystan/inst/ShinyStan/ 0000755 0001762 0000144 00000000000 13137732221 015170 5 ustar ligges users shinystan/inst/ShinyStan/ui.R 0000644 0001762 0000144 00000003007 13035516434 015733 0 ustar ligges users source("global_utils.R", local = TRUE)
source("ui_utils.R", local = TRUE)
# Begin shinyUI -----------------------------------------------------------
# _________________________________________________________________________
tagList(
tags$noscript(
style = "color: orange; font-size: 30px; text-align: center;",
"Please enable JavaScript to use ShinyStan."
),
shinyjs::useShinyjs(),
includeCSS("css/ShinyStan.css"),
navbarPage(
save_and_close_button(), # title = NULL
id = "nav",
position = "fixed-top",
collapsible = TRUE,
theme = shinythemes::shinytheme("flatly"),
windowTitle = "ShinyStan",
#### HOME ####
tabPanel(
title = strong(style = "color: #B2011D;", "ShinyStan"),
value = "home",
source_ui("PAGE_home.R")
),
#### DIAGNOSE ####
tabPanel(
title = "Diagnose",
icon = icon("medkit"),
source_ui("PAGE_diagnose.R")
),
#### ESTIMATE ####
tabPanel(
title = "Estimate",
icon = icon("stats", lib = "glyphicon"),
withMathJax(),
source_ui("PAGE_estimate.R")
),
#### EXPLORE ####
tabPanel(
title = "Explore",
icon = icon("eye-open", lib = "glyphicon"),
source_ui("PAGE_explore.R")
),
#### More ####
source_ui("PAGE_more_menu.R")
) # End navbarPage
) # End tagList
# End shinyUI -------------------------------------------------------------
# -------------------------------------------------------------------------
shinystan/inst/ShinyStan/server.R 0000644 0001762 0000144 00000007445 13035516434 016636 0 ustar ligges users if (exists(".SHINYSTAN_OBJECT")) {
object <- .SHINYSTAN_OBJECT
} else {
object <- get(".SHINYSTAN_OBJECT", envir = shinystan:::.sso_env)
}
path_to_extract_sso <- file.path("server_files","utilities","extract_sso.R")
server_files <- list.files("server_files", full.names = TRUE, recursive = TRUE)
SERVER_FILES <- server_files[!server_files %in% path_to_extract_sso]
source("global_utils.R", local = TRUE)
source("server_utils.R", local = TRUE)
source(path_to_extract_sso, local = TRUE)
# BEGIN server ------------------------------------------------------
# ___________________________________________________________________
function(input, output, session) {
# If not running on server then automatically stop app whenever browser tab
# (or any session) is closed
if (!nzchar(Sys.getenv("SHINY_PORT"))) {
session$onSessionEnded(function() stopApp(object))
}
# Stop the app when "Save & Close" button is clicked
observeEvent(
input$save_and_close_button,
stopApp(object)
)
# Source all files from server_files directory and subdirectories
for (f in SERVER_FILES)
source(f, local = TRUE)
# Link to pages from home page table of contents
toc_entries <- c("Estimate", "Diagnose", "Explore", "Model Code")
observe({
local({
lapply(toc_entries, function(x) {
id <- paste0("toc_", if (x == "Model Code") "more" else tolower(x))
shinyjs::onclick(id, updateTabsetPanel(session, "nav", selected = x))
})
})
})
# Toggle options dropdowns
options_trigger_ids <- c("table", "multiparam", "autocorr", "rhat_warnings",
"bivariate", "trivariate", "density", "hist")
observe({
lapply(seq_along(options_trigger_ids), function(j) {
shinyjs::onclick(
id = paste0(options_trigger_ids[j], "_options_show"),
shinyjs::toggle(
id = paste0(options_trigger_ids[j], "_options"),
anim = TRUE,
animType = "slide",
time = 0.4
)
)
})
})
# Enable/disable individual options
density_trigger_ids <-
c("point_est", "ci", "x_breaks", "fill_color", "line_color")
observe({
lapply(seq_along(density_trigger_ids), function(j) {
shinyjs::toggleState(
id = paste0("dens_", density_trigger_ids[j]),
condition = input$dens_chain_split == "Together"
)
})
shinyjs::toggleState(id = "ac_flip", condition = input$ac_combine == FALSE)
})
# Links to glossary
observe({
shinyjs::onclick(
"open_glossary_from_table",
updateTabsetPanel(session, "nav", selected = "Glossary")
)
shinyjs::onclick(
"open_glossary_from_nuts_table",
updateTabsetPanel(session, "nav", selected = "Glossary")
)
})
# Enable/disable diagnostic plots
diagnostic_trigger_ids <-
paste0("diagnostic_", c("param", "param_transform", "param_transform_go"))
observe({
diag_nav <- input$diagnostics_navlist
local({
if (diag_nav != 'By model parameter')
lapply(diagnostic_trigger_ids, function(x)
shinyjs::disable(id = x))
else
lapply(diagnostic_trigger_ids, function(x)
shinyjs::enable(id = x))
})
})
# Links to quick definitions
observeEvent(
input$open_quick_rhat,
shinyjs::info(includeText("text/quick_rhat.txt"))
)
observeEvent(
input$open_quick_neff,
shinyjs::info(includeText("text/quick_neff.txt"))
)
observeEvent(
input$open_quick_mcse,
shinyjs::info(includeText("text/quick_mcse.txt"))
)
# Show/hide citation
observeEvent(
input$shinystan_citation_show,
shinyjs::toggle(
id = "citation_div",
anim = TRUE,
animType = "fade"
)
)
}
# END server ------------------------------------------------------
# _________________________________________________________________
shinystan/inst/ShinyStan/server_files/ 0000755 0001762 0000144 00000000000 13271714530 017662 5 ustar ligges users shinystan/inst/ShinyStan/server_files/tooltips/ 0000755 0001762 0000144 00000000000 13035516434 021540 5 ustar ligges users shinystan/inst/ShinyStan/server_files/tooltips/tooltips.R 0000644 0001762 0000144 00000003641 13035516434 023544 0 ustar ligges users # # This file is part of shinyStan
# # Copyright (C) 2015 Jonah Sol Gabry & Stan Development Team
# #
# # shinyStan is free software; you can redistribute it and/or modify it under the
# # terms of the GNU General Public License as published by the Free Software
# # Foundation; either version 3 of the License, or (at your option) any later
# # version.
# #
# # shinyStan is distributed in the hope that it will be useful, but WITHOUT ANY
# # WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
# # A PARTICULAR PURPOSE. See the GNU General Public License for more details.
# #
# # You should have received a copy of the GNU General Public License along with
# # this program; if not, see .
#
# tooltip_ids <- c(
# "download_multiview",
# "dynamic_trace_stack",
# "download_all_summary",
# "tex_options",
# "dens_transform_x", "hist_transform_x", "bivariate_transform_x", "trivariate_transform_x",
# "bivariate_transform_y", "trivariate_transform_y",
# "trivariate_transform_z"
# )
#
# tooltip_msgs <- c(
# "Will be a list with three elements corresponding the the ggplot2 objects for the three plots.",
# "If 'Stacked' is selected, the chains will be stacked on top of one another rather than drawing them independently. The first series specified in the input data will wind up on top of the chart and the last will be on bottom. Note that the y-axis values no longer correspond to the true values when this option is enabled.",
# "Save as data.frame (.RData)",
# "Print latex table to R console",
# rep("A function of x, e.g. log(x), sqrt(x), x^2, 1/x, etc. Should be a valid R expression.", 4),
# rep("A function of y, e.g. log(y), sqrt(y), y^2, 1/y, etc. Should be a valid R expression.", 2),
# "A function of z, e.g. log(z), sqrt(z), z^2, 1/z, etc. Should be a valid R expression."
# )
# tooltip_placements <- c(rep("right", 4), rep("top", 7))
shinystan/inst/ShinyStan/server_files/debounce.R 0000644 0001762 0000144 00000003346 13035516434 021600 0 ustar ligges users # From: https://gist.github.com/jcheng5/6141ea7066e62cafb31c
# Returns a reactive that debounces the given expression by the given time in
# milliseconds.
#
# This is not a true debounce in that it will not prevent \code{expr} from being
# called many times (in fact it may be called more times than usual), but
# rather, the reactive invalidation signal that is produced by expr is debounced
# instead. This means that this function should be used when \code{expr} is
# cheap but the things it will trigger (outputs and reactives that use
# \code{expr}) are expensive.
debounce <- function(expr,
millis,
env = parent.frame(),
quoted = FALSE,
domain = getDefaultReactiveDomain()) {
force(millis)
f <- exprToFunction(expr, env, quoted)
label <- sprintf("debounce(%s)", paste(deparse(body(f)), collapse = "\n"))
v <- reactiveValues(
trigger = NULL,
when = NULL # the deadline for the timer to fire; NULL if not scheduled
)
# Responsible for tracking when f() changes.
observeEvent(f(), {
# The value changed. Start or reset the timer.
v$when <- Sys.time() + millis / 1000
}, ignoreNULL = FALSE)
# This observer is the timer. It rests until v$when elapses, then touches
# v$trigger.
observe({
if (is.null(v$when))
return()
now <- Sys.time()
if (now >= v$when) {
v$trigger <- runif(1)
v$when <- NULL
} else {
invalidateLater((v$when - now) * 1000, domain)
}
})
# This is the actual reactive that is returned to the user. It returns the
# value of f(), but only invalidates/updates when v$trigger is touched.
eventReactive(v$trigger, {
f()
}, ignoreNULL = FALSE)
}
shinystan/inst/ShinyStan/server_files/pages/ 0000755 0001762 0000144 00000000000 13035516434 020762 5 ustar ligges users shinystan/inst/ShinyStan/server_files/pages/explore/ 0000755 0001762 0000144 00000000000 13035516434 022440 5 ustar ligges users shinystan/inst/ShinyStan/server_files/pages/explore/ui/ 0000755 0001762 0000144 00000000000 13035516434 023055 5 ustar ligges users shinystan/inst/ShinyStan/server_files/pages/explore/ui/ui_trivariate_select_x.R 0000644 0001762 0000144 00000000330 13035516434 027731 0 ustar ligges users output$ui_trivariate_select_x <- renderUI({
selectizeInput(
"trivariate_param_x",
label = strong_bl("x-axis"),
choices = .make_param_list(object),
selected = input$param,
multiple = FALSE
)
}) shinystan/inst/ShinyStan/server_files/pages/explore/server/ 0000755 0001762 0000144 00000000000 13035516434 023746 5 ustar ligges users shinystan/inst/ShinyStan/server_files/pages/explore/server/multiview.R 0000644 0001762 0000144 00000004175 13137733210 026121 0 ustar ligges users multiview_samps <- reactive({
validate(
need(input$param, message = FALSE),
need(!is.null(input$multiview_warmup), message = "Loading...")
)
if (!input$multiview_warmup)
par_samps_post_warmup()
else
par_samps_all()
})
dynamic_trace_plot_multiview <- reactive({
if (input$param == "")
return()
stack <- FALSE
chain <- 0
do.call(
".param_trace_dynamic",
args = list(
param_samps = multiview_samps(),
chain = chain,
stack = stack,
warmup_val = N_WARMUP,
warmup_shade = isTRUE(input$multiview_warmup) && N_WARMUP > 0,
x_lab = "Iteration",
y_lab = input$param
)
)
})
autocorr_plot_multiview <- reactive({
lags <- min(25, round((N_ITER - N_WARMUP) / 2))
do.call(
".autocorr_single_plot",
args = list(
samps = multiview_samps(),
lags = lags
)
)
})
density_plot_multiview <- reactive({
do.call(
".param_dens",
args = list(
param = input$param,
dat = multiview_samps(),
chain = 0,
chain_split = FALSE,
fill_color = base_fill,
line_color = vline_base_clr,
point_est = "None",
CI = "None",
x_breaks = "Some",
title = FALSE
)
)
})
output$multiview_param_name <-
renderUI(strong(style = "font-size: 250%; color: #f9dd67;", input$param))
output$multiview_trace_out <-
dygraphs::renderDygraph(dynamic_trace_plot_multiview())
output$multiview_density_out <-
renderPlot(density_plot_multiview(), bg = "transparent")
output$multiview_autocorr_out <-
renderPlot(autocorr_plot_multiview(), bg = "transparent")
# download multiview plot
# output$download_multiview <- downloadHandler(
# filename = 'shinystan_multiview.RData',
# content = function(file) {
# param_name <- input$param
# shinystan_multiview <- list()
# shinystan_multiview[[paste0("trace_", param_name)]] <- trace_plot_multiview()
# shinystan_multiview[[paste0("density", param_name)]] <- density_plot_multiview()
# shinystan_multiview[[paste0("ac_", param_name)]] <- autocorr_plot_multiview()
# save(shinystan_multiview, file = file)
# }
# )
shinystan/inst/ShinyStan/server_files/pages/explore/server/histogram.R 0000644 0001762 0000144 00000002331 13035516434 026065 0 ustar ligges users # histogram
hist_transform_x <- eventReactive(input$hist_transform_x_go > 0,
input$hist_transform_x)
histogram_plot <- reactive({
validate(
need(input$param, message = FALSE),
need(!is.null(input$hist_chain), message = FALSE)
)
chain <- input$hist_chain
if (is.na(chain))
chain <- 0
binwd <- input$hist_binwd
if (is.na(binwd))
binwd <- 0
do.call(
".param_hist",
args = list(
param = input$param,
dat = par_samps_post_warmup(),
chain = chain,
binwd = binwd,
fill_color = input$hist_fill_color,
line_color = input$hist_line_color,
transform_x = hist_transform_x()
)
)
})
output$hist_plot_out <- renderPlot({
x <- histogram_plot()
suppress_and_print(x)
}, bg = "transparent")
# download plot
output$download_histogram <- downloadHandler(
filename = 'shinystan-histogram-gg.RData',
content = function(file) {
shinystan_histogram_gg <- histogram_plot()
save(shinystan_histogram_gg, file = file)
}
)
output$save_pdf_histogram = downloadHandler(
filename = "shinstan-histogram.pdf",
content = function(file) {
ggsave(file, plot = histogram_plot(), device = pdf)
}
)
shinystan/inst/ShinyStan/server_files/pages/explore/server/density.R 0000644 0001762 0000144 00000006102 13035516434 025547 0 ustar ligges users # kernel density plot
dens_transform_x <- eventReactive(
input$dens_transform_x_go > 0,
input$dens_transform_x
)
user_xlim <- function(lim) {
xz <- strsplit(lim, split = "c(", fixed = TRUE)[[1L]][2]
xz <- strsplit(xz, split = ",", fixed = TRUE)[[1L]]
if (identical(xz, NA_character_))
return(FALSE)
x_lim <- unlist(strsplit(xz, split = ")", fixed = TRUE))
x_lim <- gsub(" ", "", x_lim)
if (x_lim[1L] == "min")
x_lim[1L] <- NA
if (x_lim[2L] == "max")
x_lim[2L] <- NA
as.numeric(x_lim)
}
density_plot <- reactive({
xzoom <- input$dens_xzoom
if (xzoom == "")
return(last_plot())
validate(
need(input$param, message = FALSE),
need(!is.null(input$dens_chain), message = FALSE),
need(xzoom, message = FALSE)
)
x_lim <- if (xzoom == "c(min, max)") {
NULL
} else {
check <- try(user_xlim(xzoom))
validate(need(check, message = "Invalid input"))
check
}
chain <- input$dens_chain
if (is.na(chain))
chain <- 0
prior_fam <- input$dens_prior
prior_params <- if (prior_fam == "None") {
NULL
} else if (prior_fam == "Normal") {
list(
mean = input$dens_prior_normal_mu,
sd = input$dens_prior_normal_sigma
)
} else if (prior_fam == "t") {
list(
df = input$dens_prior_t_df,
location = input$dens_prior_t_mu,
scale = input$dens_prior_t_sigma
)
} else if (prior_fam == "Cauchy") {
list(
location = input$dens_prior_cauchy_mu,
scale = input$dens_prior_cauchy_sigma
)
} else if (prior_fam == "Beta") {
list(
shape1 = input$dens_prior_beta_shape1,
shape2 = input$dens_prior_beta_shape2
)
} else if (prior_fam == "Exponential") {
list(rate = input$dens_prior_expo_rate)
} else if (prior_fam == "Gamma") {
list(
shape = input$dens_prior_gamma_shape,
rate = input$dens_prior_gamma_rate
)
} else if (prior_fam == "Inverse Gamma") {
list(
shape = input$dens_prior_inversegamma_shape,
scale = input$dens_prior_inversegamma_scale
)
} else {
NULL
}
do.call(
".param_dens",
args = list(
param = input$param,
dat = par_samps_post_warmup(),
chain = chain,
chain_split = input$dens_chain_split == "Separate",
fill_color = input$dens_fill_color,
line_color = input$dens_line_color,
point_est = input$dens_point_est,
CI = input$dens_ci,
# y_breaks = input$dens_y_breaks,
x_breaks = input$dens_x_breaks,
x_lim = x_lim,
prior_fam = prior_fam,
prior_params = prior_params,
transform_x = dens_transform_x()
)
)
})
output$density_plot_out <- renderPlot({
suppress_and_print(density_plot())
}, bg = "transparent")
# download plot
output$download_density <- downloadHandler(
filename = 'shinystan-density-gg.RData',
content = function(file) {
shinystan_density_gg <- density_plot()
save(shinystan_density_gg, file = file)
}
)
output$save_pdf_density = downloadHandler(
filename = "shinstan-density.pdf",
content = function(file) {
ggsave(file, plot = density_plot(), device = pdf)
}
)
shinystan/inst/ShinyStan/server_files/pages/explore/server/bivariate.R 0000644 0001762 0000144 00000005220 13035516434 026036 0 ustar ligges users # bivariate scatterplot
bivariate_transform_x <-
eventReactive(input$bivariate_transform_go > 0, input$bivariate_transform_x)
bivariate_transform_y <-
eventReactive(input$bivariate_transform_go > 0, input$bivariate_transform_y)
bivariate_plot <- reactive({
validate(
need(input$param, message = FALSE),
need(input$bivariate_ellipse_lev, message = FALSE),
need(input$bivariate_param_y, message = FALSE)
)
if (!is.null(input$bivariate_ellipse_lev)) {
validate(
need(is.numeric(input$bivariate_pt_size), message = "Point size must be numeric"),
need(is.numeric(input$bivariate_pt_shape), message = "Point shape must be numeric")
)
if (input$bivariate_ellipse_lev != "None") {
validate(
need(
input$param != input$bivariate_param_y,
"For this option the x and y can't be the same parameter."
),
need(
is.numeric(input$bivariate_ellipse_lwd),
message = "Ellipse size must be numeric"
),
need(
is.numeric(input$bivariate_ellipse_lty),
message = "Ellipse shape must be numeric"
)
)
}
}
do.call(
".bivariate_plot",
args = list(
samps = SAMPS_post_warmup,
sp = if (!identical(SAMPLER_PARAMS_post_warmup, FALSE) && STAN_ALGORITHM == "NUTS")
SAMPLER_PARAMS_post_warmup else NULL,
max_td = if ("max_td" %in% names(MISC)) MISC$max_td else NULL,
param = input$param,
param2 = input$bivariate_param_y,
pt_alpha = input$bivariate_pt_alpha,
pt_size = input$bivariate_pt_size,
pt_shape = input$bivariate_pt_shape,
pt_color = input$bivariate_pt_color,
ellipse_lev = input$bivariate_ellipse_lev,
ellipse_color = input$bivariate_ellipse_color,
ellipse_lty = input$bivariate_ellipse_lty,
ellipse_lwd = input$bivariate_ellipse_lwd,
ellipse_alpha = input$bivariate_ellipse_alpha,
lines = input$bivariate_lines,
lines_color = input$bivariate_lines_color,
lines_alpha = input$bivariate_lines_alpha,
transform_x = bivariate_transform_x(),
transform_y = bivariate_transform_y()
)
)
})
output$bivariate_plot_out <- renderPlot({
x <- bivariate_plot()
suppressWarnings(print(x))
}, bg = "transparent")
# download
output$download_bivariate <- downloadHandler(
filename = 'shinystan-bivariate-gg.RData',
content = function(file) {
shinystan_bivariate_gg <- bivariate_plot()
save(shinystan_bivariate_gg, file = file)
}
)
output$save_pdf_bivariate = downloadHandler(
filename = "shinstan-bivariate.pdf",
content = function(file) {
ggsave(file, plot = bivariate_plot(), device = pdf)
}
)
shinystan/inst/ShinyStan/server_files/pages/explore/server/summary_stats_param.R 0000644 0001762 0000144 00000001551 13035516434 030166 0 ustar ligges users # posterior summary statistics for a single parameter
parameter_summary <- reactive({
validate(need(input$param != "", message = FALSE))
do.call(
".param_summary",
args = list(
param = input$param,
summary = SUMMARY
)
)
})
output$param_name <- renderText({
input$param
})
output$parameter_summary_out <- DT::renderDataTable({
DT::datatable({
as.data.frame(round(parameter_summary(), 2))
},
rownames = FALSE,
options = list(
paging = FALSE,
searching = FALSE,
info = FALSE,
ordering = FALSE,
autoWidth = TRUE,
columnDefs = list(list(sClass="alignRight", targets ="_all")),
initComplete = htmlwidgets::JS( # change background color of table header
'function(settings, json) {
$(this.api().table().header()).css({"background-color": "transparent", "color": "black"});
}')
))
})
shinystan/inst/ShinyStan/server_files/pages/explore/server/trivariate.R 0000644 0001762 0000144 00000002503 13035516434 026243 0 ustar ligges users # trivariate scatterplot
trivariate_transform_x <-
eventReactive(input$trivariate_transform_go > 0,
input$trivariate_transform_x)
trivariate_transform_y <-
eventReactive(input$trivariate_transform_go > 0,
input$trivariate_transform_y)
trivariate_transform_z <-
eventReactive(input$trivariate_transform_go > 0,
input$trivariate_transform_z)
trivariate_plot <- reactive({
validate(
need(input$trivariate_flip, message = "Loading..."),
need(input$trivariate_param_x, message = "Waiting for x ..."),
need(input$trivariate_param_y, message = "Waiting for y ..."),
need(input$trivariate_param_z, message = "Waiting for z ...")
)
x <- input$trivariate_param_x
y <- input$trivariate_param_y
z <- input$trivariate_param_z
samps <- SAMPS_post_warmup
do.call(
".param_trivariate",
args = list(
params = c(x, y, z),
samps = samps,
pt_color = input$trivariate_pt_color,
pt_size = input$trivariate_pt_size,
show_grid = input$trivariate_grid == "show",
flip_y = input$trivariate_flip == "flip",
transform_x = trivariate_transform_x(),
transform_y = trivariate_transform_y(),
transform_z = trivariate_transform_z()
)
)
})
output$trivariate_plot_out <- threejs::renderScatterplotThree({
trivariate_plot()
})
shinystan/inst/ShinyStan/server_files/pages/more/ 0000755 0001762 0000144 00000000000 13035516434 021724 5 ustar ligges users shinystan/inst/ShinyStan/server_files/pages/more/notes_and_code.R 0000644 0001762 0000144 00000001537 13035516434 025021 0 ustar ligges users # output$hamiltonian_gif <- renderImage({
# list(src="www/ham-sim-stepsize-ok.gif")
# }, deleteFile = FALSE)
output$user_text_saved <- renderText({
if (input$save_user_model_info > 0) {
paste("Saved", format(Sys.time(), "%a %b %d %Y %X"))
}
})
output$user_code_saved <- renderText({
if (input$save_user_model_code > 0) {
paste("Saved", format(Sys.time(), "%a %b %d %Y %X"))
}
})
observeEvent(input$save_user_model_info, handlerExpr = {
model_info <- input$user_model_info
if (model_info == "")
model_info <- "Use this space to store notes about your model"
slot(object, "user_model_info") <<- model_info
})
observeEvent(input$save_user_model_code, handlerExpr = {
model_code <- input$user_model_code
if (model_code == "")
model_code <- "Use this space to store your model code"
slot(object, "model_code") <<- model_code
})
shinystan/inst/ShinyStan/server_files/pages/diagnose/ 0000755 0001762 0000144 00000000000 13035516434 022553 5 ustar ligges users shinystan/inst/ShinyStan/server_files/pages/diagnose/ui/ 0000755 0001762 0000144 00000000000 13035516434 023170 5 ustar ligges users shinystan/inst/ShinyStan/server_files/pages/diagnose/ui/multitrace_customize.R 0000644 0001762 0000144 00000004676 13035516434 027603 0 ustar ligges users #
# output$ui_multitrace_customize <- renderUI({
# my_palette <- "Default"
# my_rect <- "Warmup"
# my_rect_alpha <- 0.15
# my_layout <- "Long"
#
# absolutePanel(id = "controls_multitrace",
# class = "draggable_controls",
# fixed = TRUE,
# # top = 175, right = 20, width = 270,
# top = 300, right = 20, width = 270,
# draggable = TRUE,
# shinyjs::hidden(
# div(id = "multitrace_options",
# wellPanel(
# class = "optionswell",
# strongBig("Parameter estimates"),
# hr(class = "hroptions"),
# selectInput("multitrace_options_display", label = strongBig("Control"),
# choices = c("Options", "Aesthetics"),
# selected = "Options", width = "100%"),
# conditionalPanel(condition = "input.multitrace_options_display == 'Options'",
# numericInput("multitrace_chain", label = "Chain (0 = all chains)", min = 0, max = object@nChains, step = 1, value = 0),
# radioButtons("multitrace_layout", label = "Layout",
# choices = c("Long", "Grid"), selected = my_layout, inline = TRUE),
# downloadButton("download_multitrace", "Save as ggplot2 object")
# ),
# conditionalPanel(condition = "input.multitrace_options_display == 'Aesthetics'",
# selectizeInput("multitrace_palette", "Color palette", choices = c("Default", "Brewer (spectral)", "Rainbow", "Gray"), selected = my_palette),
# # selectInput("multitrace_rect", label = "Shading", choices = c("None", "Samples", "Warmup"), selected = my_rect, size = 2, selectize = FALSE),
# radioButtons("multitrace_rect", label = "Shading", choices = c("None", "Samples", "Warmup"), selected = my_rect, inline = TRUE),
# sliderInput("multitrace_rect_alpha", "Shading opacity", value = my_rect_alpha, min = 0, max = 1, step = 0.01)
# )
# )
# )
# )
# )
# })
shinystan/inst/ShinyStan/server_files/pages/diagnose/server/ 0000755 0001762 0000144 00000000000 13137732214 024060 5 ustar ligges users shinystan/inst/ShinyStan/server_files/pages/diagnose/server/summary_stats_sampler.R 0000644 0001762 0000144 00000001643 13044376075 030653 0 ustar ligges users # summary statistics for sampler parameters -------------------------------
summary_stats_sampler <- reactive({
validate(
need(STAN_ALGORITHM %in% c("NUTS", "HMC"), message = "Only available for algorithm = NUTS or HMC"),
need(input$sampler_warmup, message = "Loading...")
)
sp <- if (input$sampler_warmup == "include")
SAMPLER_PARAMS else SAMPLER_PARAMS_post_warmup
do.call(
".sampler_summary",
args = list(
sampler_params = sp,
warmup_val = N_WARMUP,
report = input$sampler_report,
digits = input$sampler_digits
)
)
})
output$sampler_summary <- DT::renderDataTable({
DT::datatable({
summary_stats_sampler()
}, options = list(
# rownames = FALSE,
processing = TRUE,
deferRender = TRUE,
scrollX = TRUE,
scrollY = "200px",
scrollCollapse = TRUE,
paging = FALSE,
searching = FALSE,
info = FALSE
))
})
shinystan/inst/ShinyStan/server_files/pages/diagnose/server/autocorr.R 0000644 0001762 0000144 00000002577 13035516434 026055 0 ustar ligges users calc_height_autocorr_plot <- reactive({
params <- input$ac_params
params <- .update_params_with_groups(params, PARAM_NAMES)
LL <- length(params)
LL <- ifelse(LL < 8, 8, LL)
round(60 * LL)
})
autocorr_plot <- reactive({
validate(
need(input$ac_lags, message = "Loading..."),
need(!is.null(input$ac_warmup), message = "Loading...")
)
samps <- if (!input$ac_warmup)
SAMPS_post_warmup else SAMPS_all
params <- .update_params_with_groups(input$ac_params, PARAM_NAMES)
if (!length(params))
params <- dimnames(samps)$parameters[1] # default to first parameter
params <- unique(params)
samps <- samps[, , params, drop = FALSE]
do.call(
".autocorr_plot",
args = list(
samps = samps,
lags = input$ac_lags,
flip = input$ac_flip,
combine_chains = input$ac_combine,
partial = input$ac_partial
)
)
})
output$autocorr_plot_out <- renderPlot({
autocorr_plot()
}, bg = "transparent")
# download the plot
output$download_autocorr <- downloadHandler(
filename = paste0('shinystan-autocorr-gg.RData'),
content = function(file) {
shinystan_autocorr_gg <- autocorr_plot()
save(shinystan_autocorr_gg, file = file)
})
output$save_pdf_autocorr = downloadHandler(
filename = "shinstan-autocorr.pdf",
content = function(file) {
ggsave(file, plot = autocorr_plot(), device = pdf)
})
shinystan/inst/ShinyStan/server_files/pages/diagnose/server/diagnostics.R 0000644 0001762 0000144 00000037440 13137732214 026522 0 ustar ligges users lp_name <- "log-posterior"
lp_lab <- "Log Posterior"
metrop_lab <- "Mean Metrop. Acceptance"
stepsize_lab <- "Sampled Step Size"
treedepth_lab <- "Treedepth"
ndivergent_lab <- "Divergent"
sp_nuts_check <- reactive({
validate(
need(STAN_ALGORITHM == "NUTS", message = "Only available for algorithm = NUTS"),
need(input$diagnostic_chain, message = "Loading...")
)
})
lp_check <- reactive({
validate(
need(lp_name %in% dimnames(SAMPS_post_warmup)[[3]],
message = "Plot not displayed\n(Draws for 'lp__' or 'log-posterior' not found)")
)
})
diagnostic_chain <- reactive({
validate(need(input$diagnostic_chain, message = "Waiting for chain (0 for all)"))
input$diagnostic_chain
})
diagnostic_param <- reactive({
validate(need(input$diagnostic_param, message = "Waiting for parameter"))
input$diagnostic_param
})
diagnostic_param_transform <-
eventReactive(input$diagnostic_param_transform_go > 0,
input$diagnostic_param_transform)
selected_range <- debounce({
panel <- input$diagnostics_navlist
nm <- switch(
panel,
"By model parameter" = "parameter",
"Sample information" = "lp",
"Treedepth information" = "treedepth",
"Step size information" = "stepsize",
"Divergence information" = "divergent"
)
input_nm <- paste0("dynamic_trace_diagnostic_", nm, "_out_date_window")
validate(need(input[[input_nm]], "Updating selected range"))
sel <- input[[input_nm]]
high <- as.integer(strsplit(sel[[2]], "[-]")[[1]][1])
low <- as.integer(if (is.nan(sel[[1]])) "1" else strsplit(sel[[1]], "[-]")[[1]][1])
low:high
}, millis = 125)
# stepsize ----------------------------------------------------------------
dynamic_trace_diagnostic_stepsize <- reactive({
sp_nuts_check()
chain <- diagnostic_chain()
samps <- .stepsize_pw[,-1]
lab <- "Sampled Step Size"
stack <- FALSE
`%>%` <- dygraphs::`%>%`
graph <- do.call(
".dynamic_trace_diagnostics",
args = list(
param_samps = samps,
param_name = lab,
chain = chain,
stack = stack,
group = "stepsize_information"
)
)
graph %>% dygraphs::dyAxis("y", pixelsPerLabel = 40)
})
stepsize_vs_lp <- reactive({
sp_nuts_check()
lp_check()
chain <- diagnostic_chain()
sel <- selected_range()
stepsize <- .stepsize_pw[if (!is.null(sel)) sel,-1L, drop = FALSE] # drop iterations column
lp <- SAMPS_post_warmup[if (!is.null(sel)) sel, , lp_name]
.sampler_param_vs_param(
p = lp,
sp = stepsize,
p_lab = lp_lab,
sp_lab = stepsize_lab,
chain = chain,
violin = TRUE
)
})
stepsize_vs_accept_stat <- reactive({
sp_nuts_check()
chain <- diagnostic_chain()
sel <- selected_range()
df_ss <- .stepsize_pw[if (!is.null(sel)) sel,-1L, drop = FALSE] # drop iterations column
df_as <- .accept_stat_pw[if (!is.null(sel)) sel,-1L, drop = FALSE]
.sampler_param_vs_sampler_param_violin(
round(df_ss, 4),
df_as,
lab_x = stepsize_lab,
lab_y = metrop_lab,
chain = chain
)
})
# sample (accept_stat, lp) ------------------------------------------------
dynamic_trace_diagnostic_lp <- reactive({
sp_nuts_check()
lp_check()
chain <- diagnostic_chain()
samps <- SAMPS_post_warmup[, , lp_name]
lab <- "Log Posterior"
stack <- FALSE
do.call(
".dynamic_trace_diagnostics",
args = list(
param_samps = samps,
param_name = lab,
chain = chain,
stack = stack,
group = "sample_information"
)
)
})
dynamic_trace_diagnostic_accept_stat <- reactive({
sp_nuts_check()
chain <- diagnostic_chain()
samps <- .accept_stat_pw[,-1]
stack <- FALSE
do.call(
".dynamic_trace_diagnostics",
args = list(
param_samps = samps,
param_name = metrop_lab,
chain = chain,
stack = stack,
group = "sample_information"
)
)
})
lp_hist <- reactive({
sp_nuts_check()
lp_check()
chain <- diagnostic_chain()
sel <- selected_range()
lp <- SAMPS_post_warmup[if (!is.null(sel)) sel,, lp_name]
df <- as.data.frame(cbind(iterations = 1:NROW(lp), lp))
.p_hist(df, lab = lp_lab, chain)
})
accept_stat_hist <- reactive({
sp_nuts_check()
sel <- selected_range()
df <- .accept_stat_pw[if (!is.null(sel)) sel,, drop=FALSE]
chain <- diagnostic_chain()
.p_hist(df, lab = metrop_lab, chain) + xlim(0,1)
})
accept_stat_vs_lp <- reactive({
sp_nuts_check()
lp_check()
sel <- selected_range()
metrop <- .accept_stat_pw[if (!is.null(sel)) sel, -1L, drop = FALSE] # drop iterations column
lp <- SAMPS_post_warmup[if (!is.null(sel)) sel, , lp_name]
chain <- input$diagnostic_chain
divergent <- .ndivergent_pw[if (!is.null(sel)) sel, -1L, drop = FALSE]
td <- .treedepth_pw[if (!is.null(sel)) sel, -1L, drop = FALSE]
hit_max_td <- apply(td, 2L, function(y) as.numeric(y == MISC$max_td))
.sampler_param_vs_param(
p = lp,
sp = metrop,
divergent = divergent,
hit_max_td = as.data.frame(hit_max_td),
p_lab = lp_lab,
sp_lab = metrop_lab,
chain = chain
)
})
# treedepth ---------------------------------------------------------------
dynamic_trace_diagnostic_treedepth <- reactive({
sp_nuts_check()
chain <- diagnostic_chain()
samps <- .treedepth_pw[, -1]
max_td <- MISC$max_td
lab <- treedepth_lab
stack <- FALSE
graph <- do.call(
".dynamic_trace_diagnostics",
args = list(
param_samps = samps,
param_name = lab,
chain = chain,
stack = stack,
group = "treedepth_information"
)
)
`%>%` <- dygraphs::`%>%`
graph %>%
dygraphs::dyLimit(
limit = max_td,
label = "max_treedepth",
color = "black",
labelLoc = "right",
strokePattern = "solid"
) %>%
dygraphs::dyAxis(
"y",
valueRange = c(0, max_td * 8 / 7),
pixelsPerLabel = 20,
drawGrid = FALSE
)
})
treedepth_ndivergent_hist <- reactive({
sp_nuts_check()
chain <- diagnostic_chain()
sel <- selected_range()
df_td <- .treedepth_pw[if (!is.null(sel)) sel, , drop=FALSE]
df_nd <- .ndivergent_pw[if (!is.null(sel)) sel, , drop=FALSE]
.treedepth_ndivergent_hist(df_td, df_nd, chain = chain, divergent = "All")
})
treedepth_ndivergent0_hist <- reactive({
sp_nuts_check()
chain <- diagnostic_chain()
sel <- selected_range()
df_td <- .treedepth_pw[if (!is.null(sel)) sel, , drop=FALSE]
df_nd <- .ndivergent_pw[if (!is.null(sel)) sel, , drop=FALSE]
.treedepth_ndivergent_hist(df_td, df_nd, chain = chain, divergent = 0)
})
treedepth_ndivergent1_hist <- reactive({
sp_nuts_check()
chain <- diagnostic_chain()
sel <- selected_range()
df_td <- .treedepth_pw[if (!is.null(sel)) sel, , drop=FALSE]
df_nd <- .ndivergent_pw[if (!is.null(sel)) sel, , drop=FALSE]
.treedepth_ndivergent_hist(df_td, df_nd, chain = chain, divergent = 1)
})
treedepth_vs_lp <- reactive({
sp_nuts_check()
lp_check()
chain <- diagnostic_chain()
sel <- selected_range()
treedepth <- .treedepth_pw[if (!is.null(sel)) sel,-1L, drop = FALSE] # drop iterations column
lp <- SAMPS_post_warmup[if (!is.null(sel)) sel, , lp_name]
.sampler_param_vs_param(
p = lp,
sp = treedepth,
p_lab = lp_lab,
sp_lab = treedepth_lab,
chain = chain,
violin = TRUE
)
})
treedepth_vs_accept_stat <- reactive({
sp_nuts_check()
chain <- diagnostic_chain()
sel <- selected_range()
df_td <- .treedepth_pw[if (!is.null(sel)) sel,-1L, drop = FALSE] # drop iterations column
df_as <- .accept_stat_pw[if (!is.null(sel)) sel,-1L, drop = FALSE]
.sampler_param_vs_sampler_param_violin(
df_td,
df_as,
lab_x = treedepth_lab,
lab_y = metrop_lab,
chain = chain
)
})
# N divergent -------------------------------------------------------------
dynamic_trace_diagnostic_ndivergent <- reactive({
sp_nuts_check()
chain <- diagnostic_chain()
samps <- .ndivergent_pw[,-1]
stack <- FALSE
graph <- do.call(
".dynamic_trace_diagnostics",
args = list(
param_samps = samps,
param_name = ndivergent_lab,
chain = chain,
stack = stack,
group = "ndivergent_information"
)
)
`%>%` <- dygraphs::`%>%`
graph %>% dygraphs::dyAxis(
"y",
valueRange = c(0, 1.1),
pixelsPerLabel = 1e4,
drawGrid = FALSE
)
})
ndivergent_vs_lp <- reactive({
sp_nuts_check()
lp_check()
chain <- diagnostic_chain()
sel <- selected_range()
ndivergent <- .ndivergent_pw[if (!is.null(sel)) sel,-1L, drop = FALSE] # drop iterations column
lp <- SAMPS_post_warmup[if (!is.null(sel)) sel, , lp_name]
.sampler_param_vs_param(
p = lp,
sp = ndivergent,
p_lab = lp_lab,
sp_lab = ndivergent_lab,
chain = chain,
violin = TRUE
)
})
ndivergent_vs_accept_stat <- reactive({
sp_nuts_check()
chain <- diagnostic_chain()
sel <- selected_range()
df_nd <- .ndivergent_pw[if (!is.null(sel)) sel,-1L, drop = FALSE] # drop iterations column
df_as <- .accept_stat_pw[if (!is.null(sel)) sel,-1L, drop = FALSE]
.sampler_param_vs_sampler_param_violin(
df_nd,
df_as,
lab_x = ndivergent_lab,
lab_y = metrop_lab,
chain = chain
)
})
# energy ------------------------------------------------------------------
energy_hist <- reactive({
sp_nuts_check()
chain <- diagnostic_chain()
np <- bayesplot::nuts_params(SAMPLER_PARAMS_post_warmup, pars = "energy__")
if (chain != 0)
np <- subset(np, Chain == chain)
schm <- unlist(bayesplot::color_scheme_get("brightblue"))
schm["light"] <- base_fill
schm["mid"] <- overlay_fill
schm["light_highlight"] <- vline_base_clr
schm["mid_highlight"] <- pt_outline_clr
bayesplot::color_scheme_set(unname(schm))
bayesplot::mcmc_nuts_energy(np, merge_chains = isTRUE(chain != 0)) +
ggplot2::facet_wrap(~ Chain, labeller = "label_both") +
thm_no_yaxs +
bayesplot::facet_bg(FALSE) +
bayesplot::facet_text(size = rel(1)) +
bayesplot::legend_move("right") +
theme(legend.text.align = 0, legend.text = element_text(size = rel(1.5)))
})
# model parameter ---------------------------------------------------------
dynamic_trace_diagnostic_parameter <- reactive({
sp_nuts_check()
chain <- diagnostic_chain()
param <- diagnostic_param()
transform_x <- diagnostic_param_transform()
samps <- SAMPS_post_warmup[, , param]
lab <- param
if (transform_x != "identity") {
t_x <- get(transform_x)
samps <- t_x(samps)
lab <- paste0(transform_x, "(", param, ")")
}
stack <- FALSE
do.call(
".dynamic_trace_diagnostics",
args = list(
param_samps = samps,
param_name = paste("Parameter:", lab),
chain = chain,
stack = stack
)
)
})
param_vs_lp <- reactive({
sp_nuts_check()
lp_check()
param <- diagnostic_param()
chain <- diagnostic_chain()
sel <- selected_range()
lp <- SAMPS_post_warmup[if (!is.null(sel)) sel, , lp_name]
transform_x <- diagnostic_param_transform()
samps <- SAMPS_post_warmup[if (!is.null(sel)) sel, , param, drop = FALSE]
divergent <- .ndivergent_pw[if (!is.null(sel)) sel,-1L, drop = FALSE]
td <- .treedepth_pw[if (!is.null(sel)) sel,-1L, drop = FALSE]
hit_max_td <- apply(td, 2L, function(y) as.numeric(y == MISC$max_td))
lab <- param
if (transform_x != "identity") {
t_x <- get(transform_x)
samps <- t_x(samps)
lab <- paste0(transform_x, "(", param, ")")
}
samps <- as.data.frame(samps)
.sampler_param_vs_param(
p = lp,
sp = samps,
divergent = divergent,
hit_max_td = as.data.frame(hit_max_td),
p_lab = lp_lab,
sp_lab = lab,
chain = chain,
violin = FALSE
)
})
param_vs_accept_stat <- reactive({
sp_nuts_check()
chain <- diagnostic_chain()
param <- diagnostic_param()
sel <- selected_range()
metrop <- .accept_stat_pw[if (!is.null(sel)) sel, -1L, drop=FALSE] # drop iterations column
transform_x <- diagnostic_param_transform()
samps <- SAMPS_post_warmup[if (!is.null(sel)) sel,, param]
divergent <- .ndivergent_pw[if (!is.null(sel)) sel, -1L, drop=FALSE]
td <- .treedepth_pw[if (!is.null(sel)) sel, -1L, drop=FALSE]
hit_max_td <- apply(td, 2L, function(y) as.numeric(y == MISC$max_td))
lab <- param
if (transform_x != "identity") {
t_x <- get(transform_x)
samps <- t_x(samps)
lab <- paste0(transform_x, "(", param, ")")
}
graph <- .sampler_param_vs_param(
p = samps,
sp = metrop,
divergent = divergent,
hit_max_td = as.data.frame(hit_max_td),
chain = chain,
p_lab = lab,
sp_lab = metrop_lab
)
graph + coord_flip()
})
param_vs_stepsize <- reactive({
sp_nuts_check()
chain <- diagnostic_chain()
param <- diagnostic_param()
sel <- selected_range()
stepsize <- .stepsize_pw[if (!is.null(sel)) sel, -1L, drop=FALSE] # drop iterations column
transform_x <- diagnostic_param_transform()
samps <- SAMPS_post_warmup[if (!is.null(sel)) sel, , param]
lab <- param
if (transform_x != "identity") {
t_x <- get(transform_x)
samps <- t_x(samps)
lab <- paste0(transform_x, "(", param, ")")
}
.sampler_param_vs_param(
p = samps,
sp = stepsize,
p_lab = lab,
sp_lab = stepsize_lab,
chain = chain,
violin = TRUE
)
})
param_vs_treedepth <- reactive({
sp_nuts_check()
chain <- diagnostic_chain()
param <- diagnostic_param()
sel <- selected_range()
treedepth <- .treedepth_pw[if (!is.null(sel)) sel, -1L, drop=FALSE] # drop iterations column
transform_x <- diagnostic_param_transform()
samps <- SAMPS_post_warmup[if (!is.null(sel)) sel, , param]
lab <- param
if (transform_x != "identity") {
t_x <- get(transform_x)
samps <- t_x(samps)
lab <- paste0(transform_x, "(", param, ")")
}
.sampler_param_vs_param(
p = samps,
sp = treedepth,
p_lab = lab,
sp_lab = treedepth_lab,
chain = chain,
violin = TRUE
)
})
p_hist <- reactive({
sp_nuts_check()
chain <- diagnostic_chain()
param <- diagnostic_param()
sel <- selected_range()
transform_x <- diagnostic_param_transform()
samps <- SAMPS_post_warmup[if (!is.null(sel)) sel,, param]
lab <- param
if (transform_x != "identity") {
t_x <- get(transform_x)
samps <- t_x(samps)
lab <- paste0(transform_x, "(", param, ")")
}
df <- as.data.frame(cbind(iterations = 1:NROW(samps), samps))
.p_hist(df, lab = lab, chain = chain)
})
# outputs ---------------------------------------------------
trace_nms <- c("parameter", "lp", "accept_stat",
"treedepth", "stepsize", "ndivergent")
hmc_plots <- c("accept_stat_trace", "accept_stat_hist","accept_stat_vs_lp",
"lp_trace", "lp_hist", "ndivergent_trace", "treedepth_trace",
"treedepth_ndivergent_hist","treedepth_ndivergent0_hist",
"treedepth_ndivergent1_hist", "treedepth_vs_lp", "ndivergent_vs_lp",
"treedepth_vs_accept_stat", "ndivergent_vs_accept_stat",
"stepsize_vs_lp", "stepsize_vs_accept_stat", "stepsize_trace",
"param_vs_lp", "param_vs_accept_stat", "param_vs_stepsize",
"param_vs_treedepth", "p_trace", "p_hist",
"energy_hist")
for (j in seq_along(trace_nms)) {
local({
fn <- paste0("dynamic_trace_diagnostic_", trace_nms[j])
output[[paste0(fn,"_out")]] <- dygraphs::renderDygraph(do.call(fn, list()))
})
}
for (i in seq_along(hmc_plots)) {
local({
fn <- hmc_plots[i]
output[[paste0(fn, "_out")]] <- renderPlot({
x <- suppressMessages(do.call(fn, list()))
suppress_and_print(x)
})
})
}
output$diagnostic_chain_text <- renderText({
chain <- diagnostic_chain()
if (chain == 0)
return("All chains")
paste("Chain", chain)
})
output$diagnostics_warnings_text <- renderText({
sp_nuts_check()
divs <- sum(.ndivergent_pw[, -1])
hits <- sum(.treedepth_pw[, -1] == MISC$max_td)
d <- divs > 0
h <- hits > 0
if (d && h) {
msg <- paste(
"WARNINGS -- Diverging error:", divs, "iterations.",
"Maximum treedepth reached:", hits, "iterations."
)
} else if (d && !h) {
msg <- paste("WARNINGS -- Diverging error:", divs, "iterations.")
} else if (!d && h) {
msg <- paste("WARNINGS -- Maximum treedepth reached:", hits, "iterations.")
} else {
msg <- NULL
}
msg
})
shinystan/inst/ShinyStan/server_files/pages/diagnose/server/rhat_neff_mcse.R 0000644 0001762 0000144 00000004517 13035516434 027156 0 ustar ligges users vb_check <- function() {
validate(
need(
STAN_METHOD != "variational",
message = "Not available for variational inference"
)
)
}
n_eff_plot <- reactive({
vb_check()
dat <- SUMMARY[, "n_eff"]
N <- prod(dim(SAMPS_post_warmup)[1:2])
dat <- data.frame(parameter = names(dat), x = dat / N)
do.call(".rhat_neff_mcse_hist",
args = list(
dat = dat,
N = nrow(SAMPS_post_warmup),
which = "n_eff"
))
})
rhat_plot <- reactive({
vb_check()
dat <- SUMMARY[, "Rhat"]
dat <- data.frame(parameter = names(dat), x = dat)
do.call(".rhat_neff_mcse_hist", args = list(dat = dat, which = "rhat"))
})
mcse_over_sd_plot <- reactive({
vb_check()
dat <- SUMMARY[, c("se_mean", "sd")]
dat <- dat[, 1] / dat[, 2]
dat <- data.frame(parameter = names(dat), x = dat)
do.call(".rhat_neff_mcse_hist", args = list(dat = dat, which = "mcse"))
})
n_eff_warnings <- reactive({
vb_check()
paste(
.n_eff_warnings(
SUMMARY,
threshold = input$n_eff_threshold,
N_total = length(SAMPS_post_warmup[, , 1L])
),
collapse = "\n"
)
})
rhat_warnings <- reactive({
vb_check()
paste(.rhat_warnings(SUMMARY, threshold = input$rhat_threshold), collapse = "\n")
})
mcse_over_sd_warnings <- reactive({
vb_check()
paste(.mcse_over_sd_warnings(SUMMARY, threshold = input$mcse_threshold), collapse = "\n")
})
output$n_eff_warnings_title <- renderText({
paste0(
"The following parameters have an effective sample size less than ",
input$n_eff_threshold,
"% of the total sample size: "
)
})
output$rhat_warnings_title <- renderText({
paste0(
"The following parameters have an Rhat value above ",
input$rhat_threshold,
": "
)
})
output$mcse_over_sd_warnings_title <- renderText({
paste0(
"The following parameters have a Monte Carlo standard error greater than ",
input$mcse_threshold,
"% of the posterior standard deviation:"
)
})
rhat_neff_mcse <- c("rhat", "n_eff", "mcse_over_sd")
for (i in seq_along(rhat_neff_mcse)) {
local({
fn <- paste0(rhat_neff_mcse[i], "_plot")
output[[paste0(fn, "_out")]] <- renderPlot({
x <- do.call(fn, list())
suppress_and_print(x)
}, bg = "transparent")
})
local({
fn <- paste0(rhat_neff_mcse[i], "_warnings")
output[[fn]] <- renderText(do.call(fn, list()))
})
}
shinystan/inst/ShinyStan/server_files/pages/diagnose/server/multitrace.R 0000644 0001762 0000144 00000003372 13035516434 026362 0 ustar ligges users #
# # multiparameter traceplots -----------------------------------------------
# calc_height_trace_plot <- reactive({
# params <- input$multitrace_params
# grid <- FALSE
# if (!is.null(input$multitrace_layout)) {
# if (input$multitrace_layout == "Grid") grid <- TRUE
# }
# params <- .update_params_with_groups(params, param_names)
# LL <- length(params)
# if (LL == 0) LL <- 4
# if (LL == 1) LL <- 2
# if (grid) {
# if (LL > 5) return(30*LL)
# if (LL < 5) return(60*LL)
# }
# round(100*LL)
# })
#
# # multitrace_plot
# multitrace_plot <- reactive({
# validate(need(!is.null(input$multitrace_rect), message = "Loading..."))
# x1 <- input$multi_xzoom[1]
# x2 <- input$multi_xzoom[2]
# dat <- samps_all[x1:x2,,,drop=FALSE]
# # zoom <- "On"
# do.call(".param_trace_multi", args = list(
# params = input$multitrace_params,
# all_param_names = param_names,
# dat = dat,
# chain = input$multitrace_chain,
# warmup_val = warmup_val,
# palette = input$multitrace_palette ,
# rect = input$multitrace_rect,
# rect_color = "skyblue",
# rect_alpha = input$multitrace_rect_alpha,
# layout = input$multitrace_layout,
# x1 = x1,
# x2 = x2
# ))
# })
#
# output$multitrace_plot_out <- renderPlot({
# x <- multitrace_plot()
# suppressWarnings(print(x)) # this avoids warnings about removing rows when using tracezoom feature
# }, height = calc_height_trace_plot, bg = "transparent")
#
# # download the plot
# output$download_multitrace <- downloadHandler(
# filename = paste0('shinystan_multitrace.RData'),
# content = function(file) {
# shinystan_multitrace <- multitrace_plot()
# save(shinystan_multitrace, file = file)
# }
# )
shinystan/inst/ShinyStan/server_files/pages/diagnose/ppcheck/ 0000755 0001762 0000144 00000000000 13035516434 024170 5 ustar ligges users shinystan/inst/ShinyStan/server_files/pages/diagnose/ppcheck/ui/ 0000755 0001762 0000144 00000000000 13035516434 024605 5 ustar ligges users shinystan/inst/ShinyStan/server_files/pages/diagnose/ppcheck/ui/pp_get_y_and_yrep.R 0000644 0001762 0000144 00000002546 13035516434 030426 0 ustar ligges users output$ui_pp_get_y <- renderUI({
if (is.null(pp_y)) {
div(
h4(
withMathJax("Select \\(\\mathbf{y}\\) (vector of observations)")
),
selectizeInput(
"y_name",
label = "Object from global environment",
choices = c("", objects(envir = .GlobalEnv)),
options = list(placeholder = "Select an object"),
width = "50%"
)
)
} else {
helpText("All set: y found in shinystan object.")
}
})
output$ui_pp_get_yrep <- renderUI({
if (is.null(pp_yrep)) {
choices <- PARAM_NAMES
choices <- strsplit(choices, split = "[", fixed = TRUE)
choices <- lapply(choices, function(i) return(i[1]))
choices <- unique(unlist(choices))
div(h4(
withMathJax(
"Select \\(\\mathbf{y^{rep}}\\) (posterior predictive replications)"
)
),
flowLayout(
selectizeInput(
"yrep_name",
label = "Parameter/generated quantity from model",
choices = c("", choices),
options = list(placeholder = "Select a parameter name")
),
selectizeInput(
"yrep_name2",
label = "Or object from global environment",
choices = c("", objects(envir = .GlobalEnv)),
options = list(placeholder = "Select an object")
)
))
} else {
helpText("All set: yrep found in shinystan object. Select a plot to view.")
}
})
shinystan/inst/ShinyStan/server_files/pages/diagnose/ppcheck/server/ 0000755 0001762 0000144 00000000000 13035516434 025476 5 ustar ligges users shinystan/inst/ShinyStan/server_files/pages/diagnose/ppcheck/server/hists_test_statistics.R 0000644 0001762 0000144 00000005377 13035516434 032300 0 ustar ligges users pp_hists_test_statistics_mean <- reactive({
pp_tests()
y <- get_y()
yrep <- get_yrep()
mean_y <- mean(y)
mean_yrep <- apply(yrep, 1, mean)
do.call(".pp_hists_test_statistics", args = list(
stat_y = mean_y,
stat_yrep = mean_yrep,
which = "mean",
geom = input$pp_hists_test_statistics_type
))
})
pp_hists_test_statistics_sd <- reactive({
pp_tests()
y <- get_y()
yrep <- get_yrep()
sd_y <- sd(y)
sd_yrep <- apply(yrep, 1, sd)
do.call(".pp_hists_test_statistics", args = list(
stat_y = sd_y,
stat_yrep = sd_yrep,
which = "sd",
geom = input$pp_hists_test_statistics_type
))
})
pp_hists_test_statistics_min <- reactive({
pp_tests()
y <- get_y()
yrep <- get_yrep()
min_y <- min(y)
min_yrep <- apply(yrep, 1, min)
do.call(".pp_hists_test_statistics", args = list(
stat_y = min_y,
stat_yrep = min_yrep,
which = "min",
geom = input$pp_hists_test_statistics_type
))
})
pp_hists_test_statistics_max <- reactive({
pp_tests()
y <- get_y()
yrep <- get_yrep()
max_y <- max(y)
max_yrep <- apply(yrep, 1, max)
do.call(".pp_hists_test_statistics", args = list(
stat_y = max_y,
stat_yrep = max_yrep,
which = "max",
geom = input$pp_hists_test_statistics_type
))
})
pp_test_stats <- c("mean", "sd", "min", "max")
for (i in seq_along(pp_test_stats)) {
local({
fn <- paste0("pp_hists_test_statistics_", pp_test_stats[i])
output[[paste0(fn,"_out")]] <- renderPlot({
x <- suppressMessages(do.call(fn, list()))
suppress_and_print(x)
}, bg = "transparent")
})
}
# pp_hists_test_statistics_custom1 <- reactive({
# tests()
# validate(need(input$pp_test_statistics_fun1, message = ""))
# y <- get_y()
# yrep <- get_yrep()
#
# fun <- input$pp_test_statistics_fun1
# if (grepl("function", fun)) {
# f <- eval(parse(text = fun))
# stat_y <- f(y)
# stat_yrep <- apply(yrep, 1, FUN = f)
# } else {
# stat_y <- do.call(fun, args = list(y))
# stat_yrep <- apply(yrep, 1, paste(fun))
# }
#
# do.call(".pp_hists_test_statistics", args = list(
# stat_y = stat_y,
# stat_yrep = stat_yrep,
# which = "f",
# geom = input$pp_hists_test_statistics_type
# ))
# })
# pp_hists_test_statistics_custom2 <- reactive({
# tests()
# if (is.null(input$pp_test_statistics_fun2) | is.na(input$pp_test_statistics_fun2)) {
# return(last_plot())
# }
# y <- get_y()
# yrep <- get_yrep()
# stat_y <- do.call(input$pp_test_statistics_fun2, args = list(y))
# stat_yrep <- apply(yrep, 1, paste(input$pp_test_statistics_fun2))
#
# do.call(".pp_hists_test_statistics", args = list(
# stat_y = stat_y,
# stat_yrep = stat_yrep,
# which = paste(input$pp_test_statistics_fun2),
# geom = input$pp_hists_test_statistics_type
# ))
# }) shinystan/inst/ShinyStan/server_files/pages/diagnose/ppcheck/server/hists_rep_vs_obs.R 0000644 0001762 0000144 00000001460 13035516434 031175 0 ustar ligges users pp_hists_rep_vs_obs <- reactive({
pp_tests()
validate(need(input$pp_hists_rep_vs_obs_type, message = "Loading..."))
y <- get_y()
yrep <- get_yrep()
sample_ids <- sample_ids_for_hist()
yrep_samp <- yrep[sample_ids, ]
rownames(yrep_samp) <- paste("yrep", sample_ids)
geom <- input$pp_hists_rep_vs_obs_type
if (geom == "density" & input$pp_hists_rep_vs_obs_overlay == TRUE) {
x_lim <- range(c(y, yrep))
out <- do.call(".pp_dens_rep_vs_obs", args = list(
y = y,
yrep_samp = yrep_samp,
x_lim = x_lim
))
return(out)
}
graphs <- .pp_hists_rep_vs_obs(y = y, yrep_samp = yrep_samp, geom = geom)
suppressMessages(do.call(gridExtra::grid.arrange, c(graphs, ncol = 3)))
})
output$pp_hists_rep_vs_obs_out <- renderPlot({
pp_hists_rep_vs_obs()
}, bg = "transparent")
shinystan/inst/ShinyStan/server_files/pages/diagnose/ppcheck/server/y_vs_avg_rep.R 0000644 0001762 0000144 00000000501 13035516434 030300 0 ustar ligges users pp_y_vs_avg_rep <- reactive({
pp_tests()
y <- get_y()
yrep <- get_yrep()
zoom <- input$pp_zoom_to_zero
do.call(".pp_y_vs_avg_rep", args = list(
y = y,
colMeans_yrep = colMeans(yrep),
zoom_to_zero = zoom
))
})
output$pp_y_vs_avg_rep_out <- renderPlot({
pp_y_vs_avg_rep()
}, bg = "transparent")
shinystan/inst/ShinyStan/server_files/pages/diagnose/ppcheck/server/rep_vs_resid_rep.R 0000644 0001762 0000144 00000000634 13035516434 031156 0 ustar ligges users pp_avg_rep_vs_avg_resid_rep <- reactive({
pp_tests()
y <- get_y()
yrep <- get_yrep()
rowMeans_resids <- rowMeans(y - yrep)
rowMeans_yrep <- rowMeans(yrep)
do.call(".pp_avg_rep_vs_avg_resid_rep", args = list(
rowMeans_yrep = rowMeans_yrep,
rowMeans_resids = rowMeans_resids
))
})
output$pp_avg_rep_vs_avg_resid_rep_out <- renderPlot({
pp_avg_rep_vs_avg_resid_rep()
}, bg = "transparent")
shinystan/inst/ShinyStan/server_files/pages/diagnose/ppcheck/server/rstanarm.R 0000644 0001762 0000144 00000002057 13035516434 027454 0 ustar ligges users output$pp_rep_vs_obs_out_rstanarm <- renderPlot({
overlay <- input$pp_rep_vs_obs_overlay_rstanarm == "density"
if (overlay)
print(PPC_plots[["pp_check_dens"]])
else
suppress_and_print(PPC_plots[["pp_check_hist"]])
}, bg = "transparent")
output$pp_hists_test_statistics_mean_out_rstanarm <- renderPlot({
suppress_and_print(PPC_plots[["pp_check_stat_mean"]])
}, bg = "transparent")
output$pp_hists_test_statistics_sd_out_rstanarm <- renderPlot({
suppress_and_print(PPC_plots[["pp_check_stat_sd"]])
}, bg = "transparent")
output$pp_hists_test_statistics_min_out_rstanarm <- renderPlot({
suppress_and_print(PPC_plots[["pp_check_stat_min"]])
}, bg = "transparent")
output$pp_hists_test_statistics_max_out_rstanarm <- renderPlot({
suppress_and_print(PPC_plots[["pp_check_stat_max"]])
}, bg = "transparent")
output$pp_y_vs_avg_rep_out_rstanarm <- renderPlot({
print(PPC_plots[["pp_check_scatter"]])
}, bg = "transparent")
output$pp_hist_resids_out_rstanarm <- renderPlot({
suppress_and_print(PPC_plots[["pp_check_resid"]])
}, bg = "transparent")
shinystan/inst/ShinyStan/server_files/pages/diagnose/ppcheck/server/pp_utils.R 0000644 0001762 0000144 00000004535 13035516434 027467 0 ustar ligges users
# validate input tests ----------------------------------------------------
pp_tests <- reactive({
validate(
need(
get_y(),
message = "Waiting for y \n"
),
need(
get_yrep(),
message = "Waiting for y_rep \n"
)
)
})
# y -------------------------------------------------------------------
get_y <- reactive({
if (!is.null(pp_y)) {
return(pp_y)
} else {
validate(need(input$y_name, message = "Waiting for y"))
y <- get(input$y_name)
validate(
need(
!isTRUE(length(dim(y)) > 1),
message = "Error: y should be a vector"
),
need(
is.numeric(y),
message = "Error: y should be a numeric vector"
)
)
return(y)
}
})
# y_rep -------------------------------------------------------------------
has_yrep_name <- reactive({
a <- input$yrep_name # name selected from model parameters / generated quantities
b <- input$yrep_name2 # name of object in global environment
validate(need(a != "" || b != "", message = "Waiting for y_rep"))
if (a != "" && b != "")
validate(need(FALSE, message = "y_rep can only be specified once"))
return(TRUE)
})
get_yrep <- reactive({
if (!is.null(pp_yrep)) {
return(pp_yrep)
} else {
validate(need(has_yrep_name(), message = "Waiting for y_rep"))
if (input$yrep_name2 != "") {
return(get(input$yrep_name2))
} else {
yreps <- grep(paste0("^", input$yrep_name, "\\["), PARAM_NAMES)
out <- SAMPS_post_warmup[, , yreps]
dd <- dim(out)
validate(need(
dd[3] == length(as.vector(get_y())),
message = "ncol(y_rep) should equal length(y)"
))
out <- array(out, dim = c(prod(dd[1:2]), dd[3]))
return(out)
}
}
})
# sample_ids_for_hist ------------------------------------------------------
nrow_yrep <- reactive({
nrow(get_yrep())
})
sample_ids_for_hist <- reactive({
go <- input$resample_hist_go
isolate(sample(nrow_yrep(), 8))
})
# sample_ids_for_dens ------------------------------------------------------
sample_ids_for_dens <- reactive({
go <- input$resample_dens_go
isolate(sample(nrow_yrep(), min(nrow_yrep(), 50)))
})
# sample_id_for_resids ------------------------------------------------------
sample_id_for_resids <- reactive({
go <- input$resample_resids_go
isolate(sample(nrow_yrep(), 1))
})
shinystan/inst/ShinyStan/server_files/pages/diagnose/ppcheck/server/hists_resids.R 0000644 0001762 0000144 00000000541 13035516434 030324 0 ustar ligges users pp_hist_resids <- reactive({
pp_tests()
s <- sample_id_for_resids()
resids <- get_y() - get_yrep()[s,]
names(resids) <- paste0("resids(yrep_", s, ")")
do.call(".pp_hist_resids", args = list(resids = resids))
})
output$pp_hist_resids_out <- renderPlot({
x <- suppressMessages(pp_hist_resids())
suppress_and_print(x)
}, bg = "transparent")
shinystan/inst/ShinyStan/server_files/pages/diagnose/ppcheck/ppcheck_helpers.R 0000644 0001762 0000144 00000007374 13035516434 027465 0 ustar ligges users pp_yrep_clr <- "#487575"
pp_yrep_fill <- "#6B8E8E"
.pp_hists_rep_vs_obs <- function(y, yrep_samp, geom = "histogram") {
thm <- theme_classic() %+replace% (axis_color + axis_labs + fat_axis + no_yaxs + no_lgnd)
graphs <- lapply(1:(1 + nrow(yrep_samp)), function(i) {
if (i == 1)
g <- qplot(x = y, geom = geom, color = I(vline_base_clr),
size = I(0.2), fill = I(base_fill)) + labs(y = "", x = "y")
else
g <- qplot(x = yrep_samp[i-1, ], geom = geom,
color = I(pp_yrep_clr), fill = I(pp_yrep_fill),
size = I(0.2)) + labs(y = "", x = rownames(yrep_samp)[i-1])
g + thm
})
graphs
}
.pp_dens_rep_vs_obs <- function(y, yrep_samp, x_lim) {
dat <- data.frame(t(yrep_samp))
dat <- cbind(y = y, dat)
mdat <- suppressMessages(reshape2::melt(dat))
mdat$which <- "yrep"
mdat$which[mdat$variable == "y"] <- "y"
graph <- ggplot(mdat, aes(x = value, group = variable, fill = which,
color = which, alpha = which, size = which))
graph <- graph +
geom_density() +
scale_color_manual(values = c(vline_base_clr, pp_yrep_clr)) +
scale_fill_manual(values = c(base_fill, pp_yrep_fill)) +
scale_alpha_manual(values = c(3/4, 0)) +
scale_size_manual(values = c(1/3, 1/2)) +
scale_x_continuous(limits = x_lim)
graph + labs(x = "", y = "") +
theme_classic() %+replace% (axis_color + axis_labs + fat_axis + no_yaxs + no_lgnd)
}
.pp_hists_test_statistics <- function(stat_y, stat_yrep, which, geom = "histogram") {
thm <- theme_classic() %+replace% (axis_color + axis_labs + fat_axis + no_yaxs)
graph <- ggplot(data.frame(x = stat_yrep), aes(x = x))
if (geom == "histogram") {
graph <- graph + stat_bin(aes(y=..count../sum(..count..)),
color = pp_yrep_clr, fill = pp_yrep_fill, size = 0.2)
}
if (geom == "density") {
graph <- graph +
geom_density(color = pp_yrep_clr, fill = pp_yrep_fill, size = 0.2)
}
graph +
geom_vline(xintercept = stat_y, color = vline_base_clr, size = 1.5, alpha = 1) +
labs(y = "", x = paste0(which, "(yrep)")) +
thm
}
.pp_hist_resids <- function(resids) {
thm <- theme_classic() %+replace% (axis_color + axis_labs + fat_axis + no_yaxs + no_lgnd)
graph <- ggplot(data.frame(x = resids), aes(x = x)) +
stat_bin(aes(y=..count../sum(..count..)),
color = vline_base_clr, fill = base_fill, size = 0.2)
graph + thm + labs(y = "", x = names(resids))
}
.pp_avg_rep_vs_avg_resid_rep <- function(rowMeans_yrep, rowMeans_resids){
dat <- data.frame(x = rowMeans_yrep, y = rowMeans_resids)
xy_labs <- labs(x = "Average yrep", y = "Average residual")
thm <- theme_classic() %+replace% (axis_color + axis_labs + fat_axis + no_lgnd)
graph <- ggplot(dat, aes(x, y)) +
geom_hline(yintercept = 0, color = vline_base_clr, size = 0.75) +
geom_point(fill = pp_yrep_fill, color = pp_yrep_clr, size = 2.75,
alpha = 0.75, shape = 21) +
xy_labs
graph + xy_labs + thm
}
.pp_y_vs_avg_rep <- function(y, colMeans_yrep, zoom_to_zero = FALSE){
dat <- data.frame(x = y, y = colMeans_yrep, z = abs(y-colMeans_yrep))
xy_labs <- labs(x = "y", y = "Average yrep")
thm <- theme_classic() %+replace% (axis_color + axis_labs + fat_axis)
graph <- ggplot(dat, aes(x, y)) +
geom_abline(intercept = 0, slope = 1, color = vline_base_clr, size = 0.75) +
geom_point(fill = pp_yrep_fill, color = pp_yrep_clr, size = 2.75,
alpha = 0.75, shape = 21) +
xy_labs + thm
if (zoom_to_zero) {
graph <- graph +
geom_hline(yintercept = 0, size = 3, color = axis_line_color) +
geom_vline(xintercept = 0, size = 0.5, color = axis_line_color) +
thm %+replace% theme(axis.line = element_blank())
}
graph
}
shinystan/inst/ShinyStan/server_files/pages/estimate/ 0000755 0001762 0000144 00000000000 13035516434 022575 5 ustar ligges users shinystan/inst/ShinyStan/server_files/pages/estimate/ui/ 0000755 0001762 0000144 00000000000 13035516434 023212 5 ustar ligges users shinystan/inst/ShinyStan/server_files/pages/estimate/ui/multiparam_selectize.R 0000644 0001762 0000144 00000003267 13035516434 027567 0 ustar ligges users output$ui_multiparam_selectize <- renderUI({
choices <- make_param_list_with_groups_sort()
selected <- c(input$params_to_plot)
selectizeInput(
"params_to_plot",
label = h5("Select or enter parameter names"),
width = '100%',
choices = choices,
multiple = TRUE
)
})
# updating the choices and selected for the selectizeInput input$params_to_plot
# when the sorting option is changed in input$param_plot_sort_j or when
# parameters added by regex search
copy_params_to_plot <- reactive({
copy <- input$params_to_plot
if (is.null(copy) || !length(copy))
NULL
else
copy
})
observe({
x <- input$param_plot_sort_j
choices <- make_param_list_with_groups_sort()
selected <- copy_params_to_plot()
selected <- .update_params_with_groups(selected, PARAM_NAMES)
updateSelectizeInput(
session,
inputId = "params_to_plot",
choices = choices,
selected = selected
)
})
observeEvent(input$param_plot_regex, {
pattern <- input$params_to_plot_regex
if (pattern != "") {
choices <- make_param_list_with_groups_sort()
selected <- copy_params_to_plot()
selected <- .update_params_with_groups(selected, PARAM_NAMES)
if (.test_valid_regex(pattern)) {
selected <- .update_params_with_regex(selected, PARAM_NAMES, pattern)
updateSelectizeInput(
session,
inputId = "params_to_plot",
choices = choices,
selected = selected
)
}
}
})
output$invalid_regex <- renderText({
pattern <- input$params_to_plot_regex
if (length(pattern)) {
msg <- "Invalid regular expression.\nYou might need to add the escape character '\\' ."
validate(need(.test_valid_regex(pattern), message = msg))
}
})
shinystan/inst/ShinyStan/server_files/pages/estimate/server/ 0000755 0001762 0000144 00000000000 13035516434 024103 5 ustar ligges users shinystan/inst/ShinyStan/server_files/pages/estimate/server/summary_stats_latex.R 0000644 0001762 0000144 00000002077 13035516434 030344 0 ustar ligges users summary_stats_latex <- reactive({
params <- unique(.update_params_with_groups(input$tex_params, PARAM_NAMES))
nParams <- length(params)
if (nParams == 0)
params <- PARAM_NAMES
if (nParams == 1) {
x <- do.call(".param_summary", args = list(
param = params,
summary = SUMMARY
))
} else {
x <- do.call(".tex_summary", args = list(
summary = SUMMARY[params,],
cols = input$tex_columns
))
}
pkgs <- input$tex_pkgs
tab_env <- if ("Longtable" %in% pkgs)
"longtable" else getOption("xtable.tabular.environment", "tabular")
caption <- if (nzchar(input$tex_caption))
input$tex_caption else NULL
xt <- xtable::xtable(x, caption = caption)
xtable::digits(xt) <- input$tex_digits
if ("n_eff" %in% colnames(xt))
xtable::display(xt)[1 + which(colnames(xt) == "n_eff")] <- "d"
xtable::print.xtable(
xt,
booktabs = "Booktabs" %in% pkgs,
tabular.environment = tab_env,
include.rownames = FALSE
)
})
output$summary_stats_latex_out <- renderPrint({
input$tex_go
isolate(summary_stats_latex())
})
shinystan/inst/ShinyStan/server_files/pages/estimate/server/summary_stats.R 0000644 0001762 0000144 00000003074 13035516434 027145 0 ustar ligges users summary_stats <- reactive({
`%>%` <- DT::`%>%`
validate(need(input$table_digits, "loading"))
DT::datatable(data = round(TABLE_STATS, digits = input$table_digits),
colnames = c('mcse' = 'se_mean'),
options = list(
colReorder = list(realtime = TRUE),
# dom = 'RBfClrTtip',
dom = "Bflrtip",
buttons = list('copy', 'print', list(
extend = 'collection',
buttons = c('csv', 'pdf'),
text = 'Download'
),
list(extend = 'colvis', columns = 1:ncol(TABLE_STATS))),
pageLength = 10,
pagingType = "full",
processing = TRUE,
deferRender = TRUE,
scrollY = 400,
scrollX = TRUE,
scrollCollapse = FALSE,
language = list(search = "_INPUT_", searchPlaceholder = "Regex searching"),
search = list(regex = TRUE)
),
extensions =
c("Buttons", "ColReorder", "FixedColumns", "Scroller")) %>%
DT::formatStyle(columns = "Rhat",
color = DT::styleInterval(1.1, c("blue", "red"))) %>%
DT::formatRound(columns = "n_eff", digits = 0) # %>%
# DT::formatRound(columns = c("Rhat", "mean", "mcse", "sd", "2.5%", "25%",
# "50%", "75%", "97.5%"), digits = input$table_digits)
})
output$all_summary_out <- DT::renderDataTable({
summary_stats()
})
shinystan/inst/ShinyStan/server_files/pages/estimate/server/multiparameter_plot.R 0000644 0001762 0000144 00000004333 13035516434 030322 0 ustar ligges users calc_height_param_plot <- reactive({
if (!isTRUE(input$param_plot_show_density)) {
"auto"
} else {
params <- input$params_to_plot
params <- .update_params_with_groups(params, PARAM_NAMES)
LL <- length(params)
LL <- ifelse(LL < 8, 8, LL)
if (!is.null(input$param_plot_color_by_rhat)) {
# delay until input is ready
if (input$param_plot_color_by_rhat == TRUE) {
LL <- LL + 1
}
}
round(50 * LL)
}
})
multiparam_plot <- reactive({
validate(need(input$param_plot_fill_color, message = "Loading..."))
if (is.null(input$param_plot_ci_level)) {
# delay until input is ready
return()
}
customize <- !is.null(input$param_plot_show_density)
do.call(
".multiparam_plot",
args = list(
samps = SAMPS_post_warmup,
params = input$params_to_plot,
all_param_names = PARAM_NAMES,
CI.level = input$param_plot_ci_level / 100,
rhat_values = SUMMARY[, "Rhat"],
show_density = ifelse(customize, input$param_plot_show_density, FALSE), # == "yes", FALSE),
show_ci_line = ifelse(customize, input$param_plot_show_ci_line, TRUE), # == "yes", TRUE),
color_by_rhat = ifelse(customize, input$param_plot_color_by_rhat, FALSE), # == "yes", FALSE),
rhat_palette = ifelse(customize, input$param_plot_rhat_palette, "Oranges"),
point_est = ifelse(customize, input$param_plot_point_est, "Median"),
fill_color = ifelse(customize, input$param_plot_fill_color, "gray35"),
outline_color = ifelse(customize, input$param_plot_outline_color, "black"),
est_color = ifelse(customize, input$param_plot_est_color, "black")
)
)
})
output$multiparam_plot_out <- renderPlot({
multiparam_plot()
}, height = calc_height_param_plot, bg = "transparent")
# download the plot
output$download_multiparam_plot <- downloadHandler(
filename = 'shinystan-multiparam-gg.RData',
content = function(file) {
shinystan_multiparam_gg <- multiparam_plot()
save(shinystan_multiparam_gg, file = file)
}
)
output$save_pdf_multiparam = downloadHandler(
filename = "shinstan-multiparam.pdf",
content = function(file) {
ggsave(file, plot = multiparam_plot(), device = pdf)
}
)
shinystan/inst/ShinyStan/server_files/utilities/ 0000755 0001762 0000144 00000000000 13044376075 021703 5 ustar ligges users shinystan/inst/ShinyStan/server_files/utilities/par_samps_reactive.R 0000644 0001762 0000144 00000000442 13035516434 025670 0 ustar ligges users # reactive function to get samples for a single parameter
par_samps_all <- reactive({
param <- input$param
p <- which(PARAM_NAMES == param)
SAMPS_all[, , p]
})
par_samps_post_warmup <- reactive({
param <- input$param
p <- which(PARAM_NAMES == param)
SAMPS_post_warmup[, , p]
})
shinystan/inst/ShinyStan/server_files/utilities/extract_sso.R 0000644 0001762 0000144 00000004762 13044376075 024375 0 ustar ligges users # Extract the contents of the shiny_stan_object slots and do some additional
# processing
MODEL_NAME <- slot(object, "model_name")
PARAM_NAMES <- slot(object, "param_names")
PARAM_DIMS <- slot(object, "param_dims")
SAMPS_all <- slot(object, "posterior_sample")
SAMPLER_PARAMS <- slot(object, "sampler_params")
N_ITER <- slot(object, "n_iter")
N_CHAIN <- slot(object, "n_chain")
N_WARMUP <- slot(object, "n_warmup")
SAMPS_post_warmup <-
SAMPS_all[seq(from = N_WARMUP + 1, to = N_ITER), , , drop = FALSE]
MISC <- slot(object, "misc")
MISC_nms <- names(MISC)
STAN_METHOD <- if ("stan_method" %in% MISC_nms)
MISC$stan_method else "Not Stan"
STAN_ALGORITHM <- if ("stan_algorithm" %in% MISC_nms)
MISC$stan_algorithm else "Not Stan"
pp_yrep <- if ("pp_yrep" %in% MISC_nms)
MISC[["pp_yrep"]] else NULL
pp_y <- if ("pp_y" %in% MISC_nms)
MISC[["pp_y"]] else NULL
SAMPLER_PARAMS_post_warmup <-
if (!is.list(SAMPLER_PARAMS) | identical(SAMPLER_PARAMS, list(NA)))
FALSE else if (!is.matrix(SAMPLER_PARAMS[[1L]]))
FALSE else {
lapply(seq_along(SAMPLER_PARAMS), function(i) {
out <- SAMPLER_PARAMS[[i]]
out <- if (N_WARMUP == 0) out else out[-(1:N_WARMUP), ]
rownames(out) <- seq(from = N_WARMUP + 1, to = N_WARMUP + nrow(out))
out
})
}
if (!identical(FALSE, SAMPLER_PARAMS_post_warmup)) {
.stepsize_pw <-
.sampler_param_pw(SAMPLER_PARAMS_post_warmup,
which = "stepsize__",
warmup_val = N_WARMUP)
.ndivergent_pw <-
.sampler_param_pw(SAMPLER_PARAMS_post_warmup,
which = "divergent__",
warmup_val = N_WARMUP)
.treedepth_pw <-
.sampler_param_pw(SAMPLER_PARAMS_post_warmup,
which = "treedepth__",
warmup_val = N_WARMUP)
.accept_stat_pw <-
.sampler_param_pw(SAMPLER_PARAMS_post_warmup,
which = "accept_stat__",
warmup_val = N_WARMUP)
.energy_pw <-
.sampler_param_pw(SAMPLER_PARAMS_post_warmup,
which = "energy__",
warmup_val = N_WARMUP)
}
SUMMARY <- slot(object, "summary")
TABLE_STATS <- SUMMARY
if (!STAN_METHOD == "variational") {
sel <- colnames(TABLE_STATS) %in% c("Rhat", "n_eff")
TABLE_STATS <- cbind(TABLE_STATS[, sel], TABLE_STATS[,!sel])
sel <- NULL
TABLE_STATS[, "n_eff"] <- round(TABLE_STATS[, "n_eff"])
}
# ppcheck plots from rstanarm
if (isTRUE(MISC$stanreg))
PPC_plots <- MISC$pp_check_plots
shinystan/inst/ShinyStan/server_files/utilities/make_param_list_with_groups_sort.R 0000644 0001762 0000144 00000002503 13035516434 030652 0 ustar ligges users make_param_list_with_groups_sort <- reactive({
validate(need(!is.null(input$param_plot_sort_j), message = "Loading..."))
sort_j <- input$param_plot_sort_j
choices <- list()
param_groups <- names(PARAM_DIMS)
ll <- length(PARAM_DIMS)
LL <- sapply(seq_len(ll), function(i)
length(PARAM_DIMS[[i]]))
choices[seq_len(ll)] <- ""
names(choices) <- param_groups
for(i in seq_len(ll)) {
if (LL[i] == 0) {
choices[[i]] <- list(param_groups[i])
} else {
group <- param_groups[i]
temp <- paste0("^",group,"\\[")
ch <- PARAM_NAMES[grep(temp, PARAM_NAMES)]
# the next line avoids parameters whose names include the group name of a
# different group of parameters being included in the latter group, e.g.
# if we have b_bias[1], b_bias[2], bias[1], bias[2] then we want to avoid
# bias[1] and bias[2] being included in the b_bias group
ch <- ch[which(substr(ch, 1, nchar(group)) == group)]
if (sort_j == TRUE & (LL[i] > 1)) {
# change sorting so e.g. "beta[1,1] beta[1,2] beta[2,1] beta[2,2]"
# instead of "beta[1,1] beta[2,1] beta[1,2] beta[2,2]"
ch <- gtools::mixedsort(ch)
}
ch_out <- c(paste0(group,"_as_shinystan_group"), ch)
names(ch_out) <- c(paste("ALL", group), ch)
choices[[i]] <- ch_out
}
}
choices
})
shinystan/inst/ShinyStan/markdown/ 0000755 0001762 0000144 00000000000 13035516434 017015 5 ustar ligges users shinystan/inst/ShinyStan/markdown/pp_check_tutorial.md 0000644 0001762 0000144 00000006151 13035516434 023041 0 ustar ligges users ## Using Stan and ShinyStan for posterior predictive checking
In this tutorial we do the following:
1. Generate some fake data to play with
2. Write code for a simple Stan model
3. Fit the model using **RStan**
4. Use **ShinyStan** for graphical posterior predictive checks
### Data
First we'll generate some fake data in R to use for this example
# Number of observations
N <- 100
# Model matrix (with column of 1s for intercept and one covariate)
X <- cbind(Const = 1, X1 = rnorm(N))
K <- ncol(X)
# Generate fake outcome y
beta <- c(2, 1/2) # pick intercept and coefficient
sigma <- 1 # standard deviation
y <- rnorm(N, mean = X %*% beta, sd = sigma) # generate data
### Stan code
Now we can write Stan code for a simple linear regression model.
data {
int N ; # integer, number of observations
int K ; # integer, number of columns in model matrix
matrix[N,K] X ; # N by K model matrix
vector[N] y ; # vector of N observations
}
parameters {
real sigma ; # real number > 0, standard deviation
vector[K] beta ; # K-vector of regression coefficients
}
model {
beta ~ normal(0, 5) ; # prior for betas
sigma ~ cauchy(0, 2.5) ; # prior for sigma
y ~ normal(X*beta, sigma) ; # vectorized likelihood
}
generated quantities {
# Here we do the simulations from the posterior predictive distribution
vector[N] y_rep ; # vector of same length as the data y
for (n in 1:N)
y_rep[n] <- normal_rng(X[n]*beta, sigma) ;
}
In this case the posterior predictive distribution we want to simulate from is the normal distribution with mean and standard deviation updated to reflect the posterior draws of `beta` and `sigma`.
The code in the `generated quantities` block will be evaluated for each posterior draw of the parameters. For example, if we have 100 post-warmup iterations then we will have 100 `y_rep` vectors, each of length `N`.
### Fit the model
If we've saved our Stan code in a file called `stan_code.stan` then we can run this model with **RStan** and then launch **ShinyStan** like this:
library(rstan)
library(ShinyStan)
# Prepare the data we'll need as a list
stan_data <- list(y = y, X = X, N = N, K = K)
# Fit the model
stanfit <- stan(file = "stan_code.stan", data = stan_data)
# Launch ShinyStan
launch_shinystan(stanfit)
### Graphical posterior predictive checks with ShinyStan
Once we've launched **ShinyStan** we can navigate to the page for posterior predictive checking. In the dropdown menus it will ask us to select the object containing our data from our R global environment and the name of the paramter from our model containing the posterior predictive replications. So we enter `y` and `y_rep`, respectively.
**ShinyStan** will then generate graphics that will aid in checking the fit of our model including comparisons of the distribution of the observed data to the distributions of the posterior predictive replications, distributions of test statistics, and residual plots.
shinystan/inst/ShinyStan/www/ 0000755 0001762 0000144 00000000000 13035516434 016017 5 ustar ligges users shinystan/inst/ShinyStan/www/wide_ensemble.png 0000644 0001762 0000144 00000417215 13035516434 021341 0 ustar ligges users PNG
IHDR ) bKGD IDATxyxUչ?|s2'̠TQTpPkoõ^