diff --git a/.Rbuildignore b/.Rbuildignore index 6d3b4719..7066ea24 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -2,8 +2,8 @@ ^\.Rproj\.user$ LICENSE ^\.travis\.yml$ -^NEWS\.md$ ^README\.md$ .gitignore ^cran-comments\.md$ ^revdep$ +man-roxygen/* diff --git a/.gitignore b/.gitignore index 03553548..d9f5f208 100644 --- a/.gitignore +++ b/.gitignore @@ -1,20 +1,14 @@ -# History files .Rhistory .Rapp.history - -# Example code in package build process *-Ex.R -# R data files from past sessions .Rdata -# RStudio files -.Rproj.user/ -shinyStan.Rproj -# For the Mac -*.DS_Store .Rproj.user +shinystan.Rproj + +*.DS_Store inst/doc ^cran-comments\.md$ - cran-comments.md +revdep/ *.swf diff --git a/.travis.yml b/.travis.yml index a0b60266..dccf4d45 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,33 +1,9 @@ language: r -sudo: required +r: devel +cache: packages -cran: http://cran.rstudio.com/ -r_check_revdep: false -pandoc: false +r_github_packages: + - jimhester/covr -env: - global: - - _R_CHECK_FORCE_SUGGESTS_=false - -r_binary_packages: - - coda - - dygraphs - - ggplot2 - - gtools - - httpuv - - inline - - jsonlite - - knitr - - markdown - - reshape2 - - Rcpp - - RUnit - - shiny - - testthat - - xts - - yaml - -notifications: - email: - on_success: change - on_failure: change +after_success: + - Rscript -e 'covr::codecov(function_exclusions = c("launch$", "launch_shinystan_demo"), line_exclusions = list("R/zzz.R"))' \ No newline at end of file diff --git a/DESCRIPTION b/DESCRIPTION index e17dcd67..863fa760 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,8 +1,8 @@ Package: shinystan Title: Interactive Visual and Numerical Diagnostics and Posterior Analysis for Bayesian Models -Version: 2.1.0 -Date: 2016-01-06 +Version: 2.2.0 +Date: 2016-05-23 Authors@R: c(person("Jonah", "Gabry", role = c("aut", "cre"), email = "jsg2201@columbia.edu"), person(family = "Stan Development Team", role = "ctb"), @@ -16,12 +16,12 @@ Authors@R: c(person("Jonah", "Gabry", role = c("aut", "cre"), person("Dongying", "Song", role = "ctb"), person("Rob", "Trangucci", role = "ctb")) Maintainer: Jonah Gabry -Description: We provide a graphical user interface for interactive Markov chain - Monte Carlo (MCMC) diagnostics and plots and tables helpful for analyzing a - posterior sample. The interface is powered by RStudio's Shiny web application - framework and works with the output of MCMC programs written in any programming - language (and has extended functionality for Stan models fit using the rstan - package and the No-U-Turn sampler). +Description: A graphical user interface for interactive Markov chain Monte + Carlo (MCMC) diagnostics and plots and tables helpful for analyzing a + posterior sample. The interface is powered by RStudio's Shiny web + application framework and works with the output of MCMC programs written + in any programming language (and has extended functionality for Stan models + fit using the rstan and rstanarm packages). URL: https://github.com/stan-dev/shinystan/, http://mc-stan.org/ BugReports: https://github.com/stan-dev/shinystan/issues/ Depends: @@ -32,18 +32,20 @@ LazyData: true Suggests: coda, knitr (>= 1.9), - rstan (>= 2.7), rmarkdown (>= 0.8.1), + rstanarm (>= 2.9.0-3), testthat Imports: DT (>= 0.1), dygraphs (>= 0.4.5), - ggplot2 (>= 2.0.0), + ggplot2 (>= 2.1.0), gridExtra, gtools, markdown (>= 0.7.4), methods, reshape2, + rsconnect (>= 0.4.2), + rstan (>= 2.9.0-3), stats, shinyjs (>= 0.1.0), shinythemes (>= 1.0.1), diff --git a/NAMESPACE b/NAMESPACE index 10bc7112..266a25da 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -2,10 +2,13 @@ export(as.shinystan) export(deploy_shinystan) +export(drop_parameters) export(generate_quantity) +export(is.shinystan) export(launch_shinystan) export(launch_shinystan_demo) export(model_code) +export(model_name) export(notes) export(rename_model) export(retrieve) @@ -24,12 +27,12 @@ importFrom(gridExtra,grid.arrange) importFrom(gtools,mixedsort) importFrom(markdown,markdownToHTML) importFrom(reshape2,melt) +importFrom(rsconnect,deployApp) importFrom(shinyjs,colourInput) importFrom(shinyjs,useShinyjs) importFrom(shinythemes,shinytheme) importFrom(stats,acf) -importFrom(stats,model.frame) -importFrom(stats,model.response) +importFrom(stats,na.omit) importFrom(stats,quantile) importFrom(stats,time) importFrom(stats,var) diff --git a/NEWS.md b/NEWS.md index 9839f4b7..986c40c3 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,19 @@ -# `shinystan news` +### Version 2.2.0 +* Add optional argument `pars` to the `as.shinystan` method for stanfit objects, +allowing a subset of parameters to be selected for inclusion in the resulting +shinystan object. +* Introduce `drop_parameters` function for removing parameters from a shinystan +object (useful for very large objects when you only want to look at a subset of +parameters). +* Add **rstanarm** to Suggests (in the DESCRIPTION file) so `rstanarm::pp_check` +can be called. +* Allow selecting `yrep` from global environment for PPcheck +* Change `as.shinystan` to S4 generic with methods +* Add **rsconnect** to `Imports` in `DESCRIPTION`. +* Rename some of the slots in shinystan objects. The `update_sso` function can +be used to ensure that old shinystan objects have an internal structure +compatible with this release. +* Improve line coverage of api tests ### Version 2.1.0 * Compatibility with recent ggplot2 update @@ -16,13 +31,12 @@ plot ('Estimate' page) Version 2.0.0 has a new look, a new(ish) name, and a lot of new functionality. Many bugs have also been fixed (see GitHub issue tracker). -[Available on CRAN](https://cran.rstudio.com/web/packages/shinystan/index.html). ### New names * The name of the R package is **shinystan** and the app/GUI is **ShinyStan**. ### Deploy ShinyStan apps to shinyapps.io (RStudio's ShinyApps service) -* The 'deploy_shinystan' function lets you easily deploy ShinyStan apps +* The `deploy_shinystan` function lets you easily deploy ShinyStan apps to RStudio's shinyapps.io for any of your models. Each of your apps (i.e. each of your models) will have a unique url. diff --git a/R/array2shinystan.R b/R/array2shinystan.R deleted file mode 100644 index 46eaccc0..00000000 --- a/R/array2shinystan.R +++ /dev/null @@ -1,87 +0,0 @@ -# This file is part of shinystan -# Copyright (C) 2015 Jonah Gabry -# -# 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 . - -# Convert 3D array to shinystan object -# -# @param X A 3D array of posterior simulations with dimensions corresponding to -# iterations, chains, and parameters, in that order. -# @param model_name A character string giving a name for the model -# @param burnin The number of burnin (warmup) iterations. Should only be specified if the -# burnin samples are included in \code{X}. -# @param param_dims Rarely used and never necessary. A named list giving the dimensions for -# all parameters. For scalar parameters use \code{0} as the dimension. -# See Examples in \code{\link[shinyStan]{as.shinystan}}. -# @param model_code A character string with the code you used to run your model. This can -# also be added to your \code{shinystan} object later using the -# \code{\link[shinyStan]{include_model_code}} function. -# See \code{\link[shinyStan]{include_model_code}} for additional formatting instructions. -# After launching the app \code{model_code} will be viewable in the \strong{Model Code} tab. -# -# @return An object of class \code{shinystan} that can be used with -# \code{\link[shinyStan]{launch_shinystan}}. -# - -array2shinystan <- function(X, model_name = "unnamed model", burnin = 0, - param_dims = list(), - model_code) { - - Xname <- deparse(substitute(X)) - if (!is.array(X)) { - stop (paste(Xname, "is not an array")) - } - if (length(dim(X)) != 3) { - stop (paste(Xname, "must be an array with 3 dimensions")) - } - - if (is.null(dimnames(X)[[3]])) { - dimnames(X)[[3]] <- paste0("V", 1:dim(X)[3]) - } - - dimnames(X) <- list(iterations = 1:nrow(X), - chains = paste0("chain:",1:ncol(X)), - parameters = dimnames(X)[[3]]) - param_names <- dimnames(X)[[3]] - param_dims <- param_dims - if (length(param_dims) == 0) { - param_dims <- list() - param_dims[1:length(param_names)] <- NA - names(param_dims) <- param_names - for(i in 1:length(param_names)) { - param_dims[[i]] <- numeric(0) - } - } else { - zeros <- sapply(1:length(param_dims), function(i) { - 0 %in% param_dims[[i]] - }) - for (i in which(zeros)) { - param_dims[[i]] <- numeric(0) - } - } - - slots <- list() - slots$Class <- "shinystan" - slots$model_name <- model_name - slots$param_names <- param_names - slots$param_dims <- param_dims - slots$samps_all <- X - slots$summary <- shinystan_monitor(X, warmup = burnin) - slots$sampler_params <- list(NA) - slots$nChains <- ncol(X) - slots$nIter <- nrow(X) - slots$nWarmup <- burnin - if (!missing(model_code)) slots$model_code <- model_code - - do.call("new", slots) -} diff --git a/R/as.shinystan.R b/R/as.shinystan.R deleted file mode 100644 index 70e27067..00000000 --- a/R/as.shinystan.R +++ /dev/null @@ -1,117 +0,0 @@ -# This file is part of shinystan -# Copyright (C) 2015 Jonah Gabry -# -# 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 . - -#' Create and test shinystan objects -#' -#' @export -#' @param X An object to be converted to a shinystan object. Can be -#' one of the following: -#' \describe{ -#' \item{stanfit}{An object of class stanfit (\pkg{rstan})} -#' \item{stanreg}{An object of class stanreg (\pkg{rstanarm})} -#' \item{mcmc.list}{An object of class \code{mcmc.list} (\pkg{coda})} -#' \item{3D array}{A 3D array of posterior simulations with dimensions corresponding -#' to iterations, chains, and parameters, in that order.} -#' \item{chain list}{A list of matrices/2D arrays each corresponding to a single chain, -#' and with dimensions corresponding to iterations (rows) and parameters (columns). -#' } -#' } -#' @param object An object to test. -#' @param ... Additional arguments. See Details, below. -#' -#' @return For \code{as.shinystan} an object of class shinystan that can be used -#' with \code{\link{launch_shinystan}}. For \code{is.shinystan} a logical value -#' indicating whether the tested object is a shinystan object. -#' -#' @details If \code{X} is a stanfit object then no additional arguments should -#' be specified in \code{...} (they are taken automatically from the stanfit -#' object). -#' -#' If \code{X} is a stanreg object the argument \code{ppd} (logical) -#' can be specified indicating whether to draw from the posterior predictive -#' distribution before launching ShinyStan. The default is \code{TRUE}, -#' although for large objects it can be wise to set it to \code{FALSE} as -#' drawing from the posterior predictive distribution can be time consuming. -#' -#' If \code{X} is not a stanfit or stanreg object then the following arguments -#' can be specified but are not required: -#' -#' \describe{ -#' \item{\code{model_name}}{A character string giving a name for the model.} -#' \item{\code{burnin}}{The number of burnin (warmup) iterations. \code{burnin} -#' should only be specified if the burnin samples are included in \code{X}.} -#' \item{\code{param_dims}}{Rarely used and never necessary. A named list -#' giving the dimensions for all parameters. (For scalar parameters use -#' \code{0} as the dimension.) This allows shinystan to group parameters in -#' vectors/arrays/etc together for certain features. See \strong{Examples}.} -#' \item{\code{model_code}}{A character string with the code for your model.} -#' } -#' -#' @seealso \code{\link{launch_shinystan}}, \code{\link{launch_shinystan_demo}} -#' -#' @examples -#' \dontrun{ -#' ################# -#' ### Example 1 ### -#' ################# -#' -#' # If X is a mcmc.list, 3D array or list of 2D chains then just do: -#' X_sso <- as.shinystan(X, ...) # replace ... with optional arguments or omit it -#' -#' # You can also do the above if X is a stanfit object although it is not -#' # necessary since launch_shinystan accepts stanfit objects. -#' -#' -#' ############################################## -#' ### Example 2: if X is a list of 2D chains ### -#' ############################################## -#' -#' # Generate some fake data -#' chain1 <- cbind(beta1 = rnorm(100), beta2 = rnorm(100), sigma = rexp(100)) -#' chain2 <- cbind(beta1 = rnorm(100), beta2 = rnorm(100), sigma = rexp(100)) -#' X <- list(chain1, chain2) -#' X_sso <- as.shinystan(X) -#' -#' # We can also specify some or all of the optional arguments -#' # note: in order to use param_dims we need to rename 'beta1' and 'beta2' -#' # to 'beta[1]' and 'beta[2]' -#' colnames(chain1) <- colnames(chain2) <- c(paste0("beta[",1:2,"]"), "sigma") -#' X_sso <- as.shinystan(X, param_dims = list(beta = 2, sigma = 0), -#' model_name = "Example", -#' burnin = 0) -#' launch_shinystan(my_shinystan) -#'} - -as.shinystan <- function(X, ...) { - Xname <- deparse(substitute(X)) - if (is.shinystan(X)) { - message(paste0(Xname, " is already a shinystan object.\n", - "You can use launch_shinystan(", Xname, ") to launch ShinyStan.")) - return(X) - } - X_is <- get_type(X) - if (X_is == "stanfit") return(stan2shinystan(X, ...)) - if (X_is == "stanreg") return(stanreg2shinystan(X, ...)) - if (X_is == "mcmclist") return(mcmc2shinystan(X, ...)) - if (X_is == "chainlist") return(chains2shinystan(X, ...)) - if (X_is == "other") { - if (!is.array(X)) - stop(paste(Xname, "is not a valid input type. See ?as.shinystan")) - array2shinystan(X, ...) - } -} - -#' @rdname as.shinystan -is.shinystan <- function(object) inherits(object, "shinystan") diff --git a/R/chains2shinystan.R b/R/chains2shinystan.R deleted file mode 100644 index 0b55fba1..00000000 --- a/R/chains2shinystan.R +++ /dev/null @@ -1,75 +0,0 @@ -# This file is part of shinystan -# Copyright (C) 2015 Jonah Gabry -# -# 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 . - - -# Convert list of chains to shinystan object -# -# @param chain_list A list of 2D-arrays or matrices of iterations (rows) and parameters (columns). -# Each chain in chain_list should have the same number of iterations and the same parameters -# (with the same names and in the same order). -# @param ... Arguments to pass to \code{array2shinystan} -# -# @return An object of class \code{shinystan} that can be used with -# \code{\link[shinyStan]{launch_shinystan}}. -# - -chains2shinystan <- function(chain_list, ...) { - if (!is.list(chain_list)) { - name <- deparse(substitute(chain_list)) - stop(paste(name, "is not a list."), call. = FALSE) - } - nChain <- length(chain_list) - for (i in 1:nChain) { - nms <- colnames(chain_list[[i]]) - if (is.null(nms) || !all(nzchar(nms))) - stop("Some parameters are missing names. ", - "Check the column names for the matrices in your list of chains.") - } - if (nChain > 1) { - nIter <- sapply(chain_list, nrow) - same_iters <- length(unique(nIter)) == 1 - if (!same_iters) - stop("Each chain should contain the same number of iterations.") - cnames <- sapply(chain_list, colnames) - if (is.array(cnames)) { - same_params <- identical(cnames[,1], cnames[,2]) - param_names <- cnames[,1] - } else { - same_params <- length(unique(cnames)) == 1 - param_names <- cnames - } - if (!same_params) - stop("The parameters for each chain should be in the same order ", - "and have the same names.") - nIter <- nIter[1] - } else { - if (nChain == 1) { - nIter <- nrow(chain_list[[1]]) - param_names <- colnames(chain_list[[1]]) - } else { - stop("You don't appear to have any chains.") - } - } - param_names <- unique(param_names) - nParam <- length(param_names) - out <- array(NA, dim = c(nIter, nChain, nParam)) - for(i in 1:nChain) { - out[,i,] <- chain_list[[i]] - } - dimnames(out) <- list(iterations = NULL, - chains = paste0("chain:", 1:nChain), - parameters = param_names) - array2shinystan(out, ...) -} diff --git a/R/convenience.R b/R/convenience.R deleted file mode 100644 index 5ef8868c..00000000 --- a/R/convenience.R +++ /dev/null @@ -1,106 +0,0 @@ -# This file is part of shinystan -# Copyright (C) 2015 Jonah Gabry -# -# 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 . - -retrieve_rhat <- function(sso, pars) { - if (missing(pars)) { - return(sso@summary[,"Rhat"]) - } - sso@summary[pars,"Rhat"] -} - -retrieve_neff <- function(sso, pars) { - if (missing(pars)) { - return(sso@summary[,"n_eff"]) - } - sso@summary[pars,"n_eff"] -} - -retrieve_mcse <- function(sso, pars) { - if (missing(pars)) { - return(sso@summary[,"se_mean"]) - } - sso@summary[pars,"se_mean"] -} - -retrieve_quant <- function(sso, pars) { - cols <- paste0(100*c(0.025, 0.25, 0.5, 0.75, 0.975), "%") - if (missing(pars)) { - return(sso@summary[, cols]) - } - sso@summary[pars, cols] -} - -retrieve_median <- function(sso, pars) { - if (missing(pars)) { - return(retrieve_quant(sso)[,"50%"]) - } - retrieve_quant(sso, pars)[,"50%"] -} - -retrieve_mean <- function(sso, pars) { - if (missing(pars)) { - return(sso@summary[,"mean"]) - } - sso@summary[pars,"mean"] -} - -retrieve_sd <- function(sso, pars) { - if (missing(pars)) { - return(sso@summary[, "sd"]) - } - sso@summary[pars, "sd"] -} - - -sp_check <- function(sso) { - if (identical(sso@sampler_params, list(NA))) - stop("No sampler parameters found", call. = FALSE) -} - -retrieve_max_treedepth <- function(sso, inc_warmup = FALSE) { - sp_check(sso) - rows <- if (inc_warmup) 1:sso@nIter else (sso@nWarmup+1):sso@nIter - max_td <- sapply(sso@sampler_params, - function(x) max(x[rows,"treedepth__"])) - names(max_td) <- paste0("chain", 1:length(max_td)) - max_td -} - -retrieve_prop_divergent <- function(sso, inc_warmup = FALSE) { - sp_check(sso) - rows <- if (inc_warmup) 1:sso@nIter else (sso@nWarmup+1):sso@nIter - prop_div <- sapply(sso@sampler_params, - function(x) mean(x[rows,"n_divergent__"])) - names(prop_div) <- paste0("chain", 1:length(prop_div)) - prop_div -} - -retrieve_avg_stepsize <- function(sso, inc_warmup = FALSE) { - sp_check(sso) - rows <- if (inc_warmup) 1:sso@nIter else (sso@nWarmup+1):sso@nIter - avg_ss <- sapply(sso@sampler_params, - function(x) mean(x[rows,"stepsize__"])) - names(avg_ss) <- paste0("chain", 1:length(avg_ss)) - avg_ss -} - -retrieve_avg_accept <- function(sso, inc_warmup = FALSE) { - sp_check(sso) - rows <- if (inc_warmup) 1:sso@nIter else (sso@nWarmup+1):sso@nIter - avg_accept <- sapply(sso@sampler_params, - function(x) mean(x[rows,"accept_stat__"])) - names(avg_accept) <- paste0("chain", 1:length(avg_accept)) - avg_accept -} diff --git a/R/deploy_shinystan.R b/R/deploy_shinystan.R index ff9a1591..c633bd3d 100644 --- a/R/deploy_shinystan.R +++ b/R/deploy_shinystan.R @@ -1,6 +1,3 @@ -# This file is part of shinystan -# Copyright (C) 2015 Jonah Gabry -# # 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 @@ -16,18 +13,25 @@ #' Deploy a ShinyStan app on the web using shinyapps.io by RStudio #' -#' Requires a (free or paid) shinyapps.io account. Visit -#' \url{http://www.shinyapps.io/} to sign up and for details on how to configure -#' your account on your local system using RStudio's \pkg{rsconnect} package. +#' Requires a (free or paid) ShinyApps account. Visit +#' \url{http://www.shinyapps.io/} to sign up. #' #' @export -#' @param sso A shinystan object. +#' @template args-sso #' @param appName The name to use for the application. Application names must be #' at least four characters long and may only contain letters, numbers, dashes #' and underscores. #' @param account shinyapps.io account username. Only required if more than one #' account is configured on the system. #' @param ... Optional arguments. See Details. +#' @param deploy Should the app be deployed? The only reason for this to be +#' \code{FALSE} is if you just want to check that the preprocessing before +#' deployment is successful. +#' +#' @return \link[=invisible]{Invisibly}, \code{TRUE} if deployment succeeded +#' (did not encounter an error) or, if \code{deploy} argument is set to +#' \code{FALSE}, the path to the temporary directory containing the app ready +#' for deployment (also invisibly). #' #' @details In \code{...}, the arguments \code{ppcheck_data} and #' \code{ppcheck_yrep} can be specified. \code{ppcheck_data} should be a @@ -38,9 +42,13 @@ #' parameter/generated quantity to use for the posterior predictive checking. #' \code{ppcheck_yrep} (but not \code{ppcheck_data}) can also be set #' interactively on shinyapps.io when using the app. +#' +#' @seealso The example in the \emph{Deploying to shinyapps.io} vignette that +#' comes with this package. #' -#' @note See the 'Deploying to shinyapps.io' vignette for a more detailed -#' example. +#' \url{http://www.shinyapps.io/} to sign up for a free or paid ShinyApps +#' account and for details on how to configure your account on your local +#' system using RStudio's \pkg{\link[rsconnect]{rsconnect}} package. #' #' @examples #' \dontrun{ @@ -56,50 +64,136 @@ #' deploy_shinystan(sso, appName = "my-model") #' } #' - -deploy_shinystan <- function(sso, appName, account = NULL, ...) { +#' @importFrom rsconnect deployApp +#' +deploy_shinystan <- function(sso, appName, account = NULL, ..., deploy = TRUE) { sso_check(sso) - if (missing(appName)) - stop("Please specify a name for your app using the 'appName' argument") - + if (missing(appName)) + stop("'appName' is required.") + # copy contents to temporary directory and write necessary additional lines to # ui, server, and global appDir <- tempdir() deployDir <- file.path(appDir, "ShinyStan") contents <- system.file("ShinyStan", package = "shinystan") file.copy(from = contents, to = appDir, recursive = TRUE) - server_pkgs <- c("shiny", "shinyjs", "markdown", "shinythemes") - ui_pkgs <- c(server_pkgs, "ggplot2", "gtools", "reshape2", - "dygraphs", "xts", "xtable", "gridExtra", "DT", "threejs") - server_lines <- paste0("library(", server_pkgs,");") - ui_lines <- paste0("library(", ui_pkgs,");") - global_lines <- paste("load('shinystan_temp_object.RData');", - "if (file.exists('y.RData')) load('y.RData')") + + server_pkgs <- c( + "shiny", + "shinyjs", + "markdown", + "shinythemes" + ) + ui_pkgs <- c( + server_pkgs, + "ggplot2", + "gtools", + "reshape2", + "dygraphs", + "xts", + "xtable", + "gridExtra", + "DT", + "threejs" + ) + server_lines <- paste0("library(", server_pkgs, ");") + ui_lines <- paste0("library(", ui_pkgs, ");") + global_lines <- paste( + "load('sso.RData');", + "if (file.exists('y.RData')) load('y.RData')" + ) for (ff in c("ui", "server", "global")) { file_name <- file.path(deployDir, paste0(ff, ".R")) - fconn <- file(file_name, 'r+') - original_content <- readLines(fconn) + fconn <- file(file_name, 'r+') + original_content <- readLines(fconn) if (ff %in% c("ui", "server")) { - sel <- grep(".shinystan_temp_object", original_content) - original_content <- original_content[-sel] + sel <- grep(".SHINYSTAN_OBJECT", original_content) + original_content <- original_content[-sel] } new_lines <- get(paste0(ff, "_lines")) - writeLines(c(new_lines, original_content), con = fconn) - close(fconn) + writeLines(c(new_lines, original_content), con = fconn) + close(fconn) } - - # save shinystan_object to deployDir + + # save sso to deployDir object <- sso - save(object, file = file.path(deployDir, "shinystan_temp_object.RData")) - deploy <- getFromNamespace("deployApp", "rsconnect") + save(object, file = file.path(deployDir, "sso.RData")) # save ppcheck_data and set ppcheck defaults pp <- list(...) if ("ppcheck_data" %in% names(pp)) { y <- pp$ppcheck_data save(y, file = file.path(deployDir, "y.RData")) if ("ppcheck_yrep" %in% names(pp)) - set_ppcheck_defaults(appDir = deployDir, yrep_name = pp$ppcheck_yrep, - y_name = "y") + set_ppcheck_defaults( + appDir = deployDir, + yrep_name = pp$ppcheck_yrep, + y_name = "y" + ) + } + + if (!deploy) + return(invisible(deployDir)) + + rsconnect::deployApp( + appDir = deployDir, + appName = appName, + account = account, + lint = TRUE + ) +} + + + +# functions to set defaults for ppcheck shiny::selectInput for y and y_rep +set_ppcheck_defaults <- function(appDir, yrep_name, y_name = "y") { + stopifnot(is.character(yrep_name), is.character(y_name), + length(yrep_name) == 1, length(y_name) == 1) + fileDir <- file.path(appDir, "server_files", "pages", "diagnose", "ppcheck", "ui") + y_file <- file.path(fileDir, "pp_y_from_r.R") + yrep_file <- file.path(fileDir, "pp_yrep_from_sso.R") + for (file in c("y_file", "yrep_file")) { + f <- get(file) + if (file.exists(f)) { + file.remove(f) + file.create(f) + } + } + .write_files( + files = c(y_file, yrep_file), + lines = c(.y_lines(y_name), .yrep_lines(yrep_name)) + ) +} + +.write_files <- function(files, lines) { + stopifnot(length(files) == length(lines)) + for (f in seq_along(files)) { + fileConn <- file(files[f]) + writeLines(lines[f], fileConn) + close(fileConn) } - deploy(appDir = deployDir, appName = appName, account = account, lint = TRUE) +} + +.y_lines <- function(y_name = "y") { + paste0( + "output$ui_pp_y_from_r <- renderUI({ + choices <- objects(envir = .GlobalEnv) + selectizeInput('y_name', label = span(style = 'color: #337ab7;', 'y, a vector of observations'), + choices = c('', choices), + selected = '", y_name,"') + })") +} + +.yrep_lines <- function(yrep_name) { + paste0( + "output$ui_pp_yrep_from_sso <- renderUI({ + choices <- param_names + choices <- strsplit(choices, split = '[', fixed = TRUE) + choices <- lapply(choices, function(i) return(i[1])) + choices <- unique(unlist(choices)) + selectizeInput('yrep_name', + label = span(style = 'color: #337ab7;', 'y_rep, posterior predictive replications'), + choices = c('', choices), + selected = '", yrep_name,"') + })" + ) } diff --git a/R/drop_parameters.R b/R/drop_parameters.R new file mode 100644 index 00000000..bd88db9b --- /dev/null +++ b/R/drop_parameters.R @@ -0,0 +1,91 @@ +# 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 . + + +#' Drop parameters from a shinystan object +#' +#' Remove selected parameters from a shinystan object. This is useful if you +#' have a very large shinystan object when you only want to look at a subset of +#' parameters. With a smaller shinystan object, \code{\link{launch_shinystan}} +#' will be faster and you should experience better performance (responsiveness) +#' after launching when using the ShinyStan app. +#' +#' @export +#' @template args-sso +#' @param pars A character vector of parameter names. If the name of a +#' non-scalar (e.g. vector, matrix) parameter is included in \code{pars} all +#' of its elements will be removed. Currently it is not possible to remove +#' only a subset of the elements of a non-scalar parameter. +#' @return \code{sso}, with \code{pars} dropped. +#' +#' @template seealso-generate_quantity +#' +#' @examples +#' # Using example shinystan object 'eight_schools' +#' print(eight_schools@param_names) +#' +#' # Remove the scalar parameters mu and tau +#' sso <- drop_parameters(eight_schools, pars = c("mu", "tau")) +#' print(sso@param_names) +#' +#' # Remove all elements of the parameter vector theta +#' sso <- drop_parameters(sso, pars = "theta") +#' print(sso@param_names) +#' +drop_parameters <- function(sso, pars) { + sso_check(sso) + stopifnot(is.character(pars)) + if (any(c("log-posterior", "lp__") %in% pars)) + stop("log-posterior can't be dropped.") + + any_indiv_els <- any(grepl("[", pars, fixed = TRUE)) + if (any_indiv_els) + stop("Currently, individual elements of non-scalar parameters can't be removed.") + + any_dimnames_in_pars <- any(names(sso@param_dims) %in% pars) + if (any_dimnames_in_pars) { + param_dims <- slot(sso, "param_dims") + param_names <- slot(sso, "param_names") + pd <- which(names(param_dims) %in% pars) + nms <- names(param_dims[pd]) + for (j in seq_along(nms)) { + if (!nms[j] %in% param_names) { + pars <- pars[pars != nms[j]] + tmp <- grep(paste0(nms[j], "["), param_names, fixed = TRUE, value = TRUE) + pars <- c(pars, tmp) + } + } + slot(sso, "param_dims") <- slot(sso, "param_dims")[-pd] + } + + sel <- match(pars, slot(sso, "param_names")) + if (!any_dimnames_in_pars && all(is.na(sel))) { + stop("No matches for 'pars' were found.", call. = FALSE) + } else if (any(is.na(sel))) { + warning(paste( + "Some 'pars' not found and ignored:", + paste(pars[is.na(sel)], collapse = ", ") + )) + } + + .drop_parameters(sso, na.omit(sel)) +} + + +# @param rmv A vector of indices indicating the positions of parameters to be +# removed +.drop_parameters <- function(sso, rmv) { + slot(sso, "param_names") <- slot(sso, "param_names")[-rmv] + slot(sso, "posterior_sample") <- slot(sso, "posterior_sample")[, , -rmv, drop = FALSE] + slot(sso, "summary") <- slot(sso, "summary")[-rmv, , drop = FALSE] + sso +} diff --git a/R/eight_schools.R b/R/eight_schools.R deleted file mode 100644 index d8bc4cfd..00000000 --- a/R/eight_schools.R +++ /dev/null @@ -1,23 +0,0 @@ -# This file is part of shinystan -# Copyright (C) 2015 Jonah Gabry -# -# 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 . - -#' ShinyStan demo: Eight Schools -#' -#' A shinystan object for the Stan "Eight Schools" demo model -#' -#' @seealso \code{\link{launch_shinystan_demo}} -#' @format An S4 object of class \code{shinystan} -#' -"eight_schools" \ No newline at end of file diff --git a/R/generate_quantity.R b/R/generate_quantity.R index dce9ef16..d82ef688 100644 --- a/R/generate_quantity.R +++ b/R/generate_quantity.R @@ -1,6 +1,3 @@ -# This file is part of shinystan -# Copyright (C) 2015 Jonah Gabry -# # 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 @@ -14,90 +11,83 @@ # this program; if not, see . -#' Add to shinystan object a new parameter as a function of one or two -#' existing parameters +#' Add new quantity to shinystan object +#' +#' Add to shinystan object a new parameter as a function of one or two existing +#' parameters. #' #' @export -#' @param sso shinystan object. -#' @param fun Function to call, i.e. \code{function(param1)} or -#' \code{function(param1,param2)}. See \strong{Examples}, below. +#' @template args-sso +#' @param fun Function to call, i.e. \code{function(param1)} or +#' \code{function(param1,param2)}. See Examples, below. #' @param param1 Name of first parameter as character string. #' @param param2 Optional. Name of second paramter as character string. #' @param new_name Name for the new parameter as character string. -#' +#' #' @return sso, updated. See Examples. #' -#' @seealso \code{\link{as.shinystan}} +#' @template seealso-drop_parameters #' #' @examples -#' \dontrun{ -#' ################# -#' ### Example 1 ### -#' ################# -#' -#' # Below, assume X is a shinystan object and two of the -#' # parameters are alpha and beta. -#' -#' # Add parameter gamma = inverse-logit(beta) to X -#' inv_logit <- function(x) 1/(exp(-x) + 1) -#' X <- generate_quantity(sso = X, -#' fun = inv_logit, -#' param1 = "beta", -#' new_name = "gamma") -#' -#' -#' # Add parameter delta = (alpha-beta)^2 to X -#' X <- generate_quantity(sso = X, -#' fun = function(x,y) (x-y)^2, -#' param1 = "alpha", -#' param2 = "beta", -#' new_name = "delta") -#' -#' launch_shinystan(X) -#'} - +#' # Using example shinystan object 'eight_schools' +#' sso <- eight_schools +#' sso <- generate_quantity(sso, fun = function(x) x^2, +#' param1 = "tau", new_name = "tau_sq") +#' sso <- generate_quantity(sso, fun = "-", +#' param1 = "theta[1]", param2 = "theta[2]", +#' new_name = "theta1minus2") +#' generate_quantity <- function(sso, param1, param2, fun, new_name) { sso_check(sso) + if (isTRUE(new_name %in% slot(sso, "param_names"))) + stop(paste("There is already a parameter named", new_name)) - name_exists <- new_name %in% sso@param_names - if (name_exists) stop(paste("There is already a parameter named", new_name)) - - message("\nThis might take a moment for large shinystan objects...\n") + message("\nThis might take a moment for large shinystan objects...") two_params <- !missing(param2) - samps <- sso@samps_all - dim_samps <- dim(samps) - nDim <- length(dim_samps) - if (nDim == 3) { # i.e. multiple chains - x_samps <- samps[, , param1] - if (two_params) y_samps <- samps[, , param2] + posterior <- slot(sso, "posterior_sample") + dims <- dim(posterior) + ndim <- length(dims) + if (ndim == 3) { + # i.e. multiple chains + x_samp <- posterior[, , param1] + if (two_params) + y_samp <- posterior[, , param2] } - if (nDim == 2) { # i.e. only 1 chain - x_samps <- samps[, param1] - if (two_params) y_samps <- samps[, param2] + if (ndim == 2) { + # i.e. only 1 chain + x_samp <- posterior[, param1] + if (two_params) + y_samp <- posterior[, param2] } - arglist <- if (two_params) list(x_samps, y_samps) else list(x_samps) + arglist <- if (two_params) + list(x_samp, y_samp) else list(x_samp) temp <- do.call(fun, args = arglist) - new_dim <- dim_samps - new_dim[[nDim]] <- new_dim[[nDim]] + 1 - new_dim_names <- dimnames(samps) - new_dim_names[[nDim]] <- c(new_dim_names[[nDim]], new_name) - samps <- array(data = c(samps, temp), dim = new_dim, dimnames = new_dim_names) + new_dim <- dims + new_dim[[ndim]] <- new_dim[[ndim]] + 1 + new_dim_names <- dimnames(posterior) + new_dim_names[[ndim]] <- c(new_dim_names[[ndim]], new_name) + posterior <- + array(data = c(posterior, temp), + dim = new_dim, + dimnames = new_dim_names) - param_dims_new <- sso@param_dims + param_dims_new <- slot(sso, "param_dims") param_dims_new[[new_name]] <- numeric(0) - sso_new <- array2shinystan(samps, - model_name = sso@model_name, - burnin = sso@nWarmup, - param_dims = param_dims_new) - sso_new@summary <- shinystan_monitor(samps, warmup = sso@nWarmup) + sso_new <- as.shinystan( + posterior, + model_name = slot(sso, "model_name"), + burnin = slot(sso, "n_warmup"), + param_dims = param_dims_new + ) + slot(sso_new, "summary") <- + shinystan_monitor(posterior, warmup = slot(sso, "n_warmup")) - slot_names <- c("stan_algorithm", "sampler_params", "model_code", "user_model_info") - for (sn in slot_names) { + slot_names <- c("sampler_params", "model_code", "user_model_info", "misc") + for (sn in slot_names) slot(sso_new, sn) <- slot(sso, sn) - } - return(sso_new) + sso_new } diff --git a/R/launch_shinystan.R b/R/launch_shinystan.R index a1490afb..f789c0c3 100644 --- a/R/launch_shinystan.R +++ b/R/launch_shinystan.R @@ -1,6 +1,3 @@ -# This file is part of shinystan -# Copyright (C) 2015 Jonah Gabry -# # 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 @@ -13,21 +10,31 @@ # You should have received a copy of the GNU General Public License along with # this program; if not, see . -#' ShinyStan app + +#' Launch the ShinyStan app +#' +#' Launch the ShinyStan app in the default web browser. RStudio users also have +#' the option of launching the app in RStudio's pop-up Viewer. #' #' @export -#' @param object An object of class shinystan, stanfit, or stanreg. See -#' \code{\link{as.shinystan}} for converting other objects to a shinystan -#' object (sso). -#' @param rstudio Only relevant for RStudio users. The default -#' (\code{rstudio=FALSE}) is to launch the app in the default web browser -#' rather than RStudio's pop-up Viewer. Users can change the default to -#' \code{TRUE} by setting the global option \code{options(shinystan.rstudio = -#' TRUE)}. -#' @param ... Optional arguments to pass to \code{\link[shiny]{runApp}}. -#' @return An S4 shinystan object. -#' -#' @seealso \code{\link{as.shinystan}}, \code{\link{launch_shinystan_demo}} +#' @param object An object of class shinystan, stanfit, or stanreg. To use other +#' types of objects first create a shinystan object using +#' \code{\link{as.shinystan}}. +#' @param rstudio Only relevant for RStudio users. The default (\code{FALSE}) is +#' to launch the app in the user's default web browser rather than RStudio's +#' pop-up Viewer. Users can change the default to \code{TRUE} by setting the +#' global option \code{options(shinystan.rstudio = TRUE)}. +#' @param ... Optional arguments passed to \code{\link[shiny]{runApp}}. +#' +#' @return The \code{launch_shinystan} function is used for the side effect of +#' starting the ShinyStan app, but it also returns a shinystan object, an +#' instance of S4 class \code{"shinystan"}. +#' +#' @template seealso-as.shinystan +#' @template seealso-update_sso +#' @template seealso-demo +#' +#' #' @examples #' \dontrun{ #' ####################################### @@ -68,20 +75,68 @@ #' # Now fit_sso is a shinystan object and so Example 1 (above) applies. #' } #' -launch_shinystan <- function(object, rstudio = getOption("shinystan.rstudio"), +launch_shinystan <- function(object, + rstudio = getOption("shinystan.rstudio"), ...) { - name <- deparse(substitute(object)) - no_name <- substr(name, 1, 12) == "as.shinystan" - if (missing(object)) - stop("Please specify a shinystan or stanfit object.", call. = FALSE) - message("\nLoading... \n", - "Note: for large models ShinyStan may take a few moments to launch.") - - if (inherits(object, "stanreg")) - object <- stanreg2shinystan(object) - if (inherits(object, "stanfit")) - object <- stan2shinystan(object) + if (is.shinystan(object)) { + sso_check(object) + } else if (is.stanreg(object) || is.stanfit(object)) { + message("\nCreating shinystan object...") + object <- as.shinystan(object) + } if (!is.shinystan(object)) - stop(paste(name, "is not a valid input. See ?launch_shinystan")) + stop("'object' is not a valid input. See help('launch_shinystan').") + + message("\nLaunching ShinyStan interface... ", + "for large models this may take some time.") invisible(launch(object, rstudio, ...)) } + + +#' ShinyStan demo +#' +#' @aliases eight_schools +#' @export +#' @inheritParams launch_shinystan +#' @param demo_name The name of the demo. Currently \code{"eight_schools"} is +#' the only option, but additional demos may be available in future releases. +#' \describe{ +#' \item{\code{eight_schools}}{Hierarchical meta-analysis model. See +#' \emph{Meta Analysis} chapter of the Stan manual (chapter 11.2 in version +#' 2.9), \url{http://mc-stan.org/documentation/}.} +#' } +#' @return An S4 shinystan object. +#' +#' @template seealso-launch +#' @template seealso-as.shinystan +#' +#' @examples +#' \dontrun{ +#' # launch demo but don't save a shinystan object +#' launch_shinystan_demo() +#' +#' # launch demo and save the shinystan object for the demo +#' sso_demo <- launch_shinystan_demo() +#' } +#' +launch_shinystan_demo <- function(demo_name = "eight_schools", + rstudio = getOption("shinystan.rstudio"), + ...) { + demo_name <- match.arg(demo_name) + demo_object <- get(demo_name) + invisible(launch(demo_object, rstudio = rstudio, ...)) +} + +# Internal launch function +# @param sso shinystan object +# @param rstudio launch in rstudio viewer instead of web browser? +# @param ... passed to shiny::runApp +launch <- function(sso, rstudio = FALSE, ...) { + launch.browser <- if (!rstudio) + TRUE else getOption("shiny.launch.browser", interactive()) + + .sso_env$.SHINYSTAN_OBJECT <- sso # see zzz.R for .sso_env + on.exit(.sso_env$.SHINYSTAN_OBJECT <- NULL, add = TRUE) + shiny::runApp(system.file("ShinyStan", package = "shinystan"), + launch.browser = launch.browser, ...) +} diff --git a/R/launch_shinystan_demo.R b/R/launch_shinystan_demo.R deleted file mode 100644 index 260358b4..00000000 --- a/R/launch_shinystan_demo.R +++ /dev/null @@ -1,43 +0,0 @@ -# This file is part of shinystan -# Copyright (C) 2015 Jonah Gabry -# -# 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 . - -#' ShinyStan demo -#' -#' @export -#' @param rstudio Only relevant for RStudio users. The default -#' (\code{rstudio=FALSE}) is to launch the app in the default web browser -#' rather than RStudio's pop-up Viewer. Users can change the default to -#' \code{TRUE} by setting the global option \code{options(shinystan.rstudio = -#' TRUE)}. -#' @param ... Optional arguments to pass to \code{\link[shiny]{runApp}}. -#' @return An S4 shinystan object. -#' -#' @seealso \code{\link{launch_shinystan}}, \code{\link{as.shinystan}} -#' -#' @examples -#' \dontrun{ -#' # launch demo but don't save a shinystan object -#' launch_shinystan_demo() -#' -#' # launch demo and save the shinystan object for the demo -#' ssdemo <- launch_shinystan_demo() -#' } -#' - -launch_shinystan_demo <- function(rstudio = getOption("shinystan.rstudio"), - ...) { - demo_name <- "eight_schools" - invisible(launch(get(demo_name), rstudio, ...)) -} diff --git a/R/mcmc2shinystan.R b/R/mcmc2shinystan.R deleted file mode 100644 index fb57ed46..00000000 --- a/R/mcmc2shinystan.R +++ /dev/null @@ -1,91 +0,0 @@ -# This file is part of shinystan -# Copyright (C) 2015 Jonah Gabry -# -# 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 . - -# Convert mcmc.list object to shinystan object -# -# @param X An mcmc.list object (\pkg{coda}) -# @param model_name A character string giving a name for the model -# @param burnin The number of burnin (warmup) iterations. Should only be specified if the -# burnin samples are included in \code{X}. -# @param param_dims Rarely used and never necessary. A named list giving the dimensions for -# all parameters. For scalar parameters use \code{0} as the dimension. -# See Examples in \code{\link[shinyStan]{as.shinystan}}. -# @param model_code A character string with the code you used to run your model. This can -# also be added to your \code{shinystan} object later using the -# \code{\link[shinyStan]{include_model_code}} function. -# See \code{\link[shinyStan]{include_model_code}} for additional formatting instructions. -# After launching the app \code{model_code} will be viewable in the \strong{Model Code} tab. -# -# @return An object of class \code{shinystan} that can be used with -# \code{\link[shinyStan]{launch_shinystan}}. -# - -mcmc2shinystan <- function(X, model_name = "unnamed model", burnin = 0, param_dims = list(), - model_code) { - - coda_check() - Xname <- deparse(substitute(X)) - if (!inherits(X, "mcmc.list")) { - stop (paste(Xname, "is not an mcmc.list.")) - } - - if (length(X) == 1) { - return(chains2shinystan(list(mcmclist2matrix(X)))) - } - - samps_array <- array(NA, dim = c(coda::niter(X), coda::nvar(X), coda::nchain(X)), - dimnames = list(iter = time(X), var = coda::varnames(X), chain = coda::chanames(X))) - for (c in 1:coda::nchain(X)) samps_array[,,c] <- X[[c]] - samps_array <- aperm(drop(samps_array), c(1,3,2)) - dimnames(samps_array) <- list(iterations = 1:nrow(samps_array), - chains = paste0("chain:",1:ncol(samps_array)), - parameters = dimnames(samps_array)[[3]]) - param_names <- dimnames(X[[1]])[[2]] - param_dims <- param_dims - - if (length(param_dims) != 0) { - zeros <- sapply(1:length(param_dims), function(i) { - 0 %in% param_dims[[i]] - }) - for (i in which(zeros)) { - param_dims[[i]] <- numeric(0) - } - } - - if (length(param_dims) == 0) { - param_dims <- list() - param_dims[1:length(param_names)] <- NA - names(param_dims) <- param_groups <- param_names - for(i in 1:length(param_names)) { - param_dims[[i]] <- numeric(0) - } - } else { - param_groups <- names(param_dims) - } - slots <- list() - slots$Class <- "shinystan" - slots$model_name <- model_name - slots$param_names <- param_names - slots$param_dims <- param_dims - slots$samps_all <- samps_array - slots$summary <- shinystan_monitor(samps_array, warmup = burnin) - slots$sampler_params <- list(NA) - slots$nChains <- ncol(samps_array) - slots$nIter <- nrow(samps_array) - slots$nWarmup <- burnin - if (!missing(model_code)) slots$model_code <- model_code - - do.call("new", slots) -} diff --git a/R/misc.R b/R/misc.R index 1995d33c..7f0043e8 100644 --- a/R/misc.R +++ b/R/misc.R @@ -1,6 +1,3 @@ -# This file is part of shinystan -# Copyright (C) 2015 Jonah Gabry -# # 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 @@ -13,149 +10,56 @@ # You should have received a copy of the GNU General Public License along with # this program; if not, see . -sso_check <- function(sso) { - if (!is.shinystan(sso)) - stop("Please specify a shinystan object", call. = FALSE) - else - invisible(TRUE) +# check which shinystan created a shinystan object +sso_version <- function(sso) { + ver <- sso@misc[["sso_version"]] + if (!is.null(ver)) { + package_version(ver) + } else { + package_version("2.0") + } } -is.stanfit <- function(X) inherits(X, "stanfit") -is.stanreg <- function(X) inherits(X, "stanreg") -rstan_check <- function() { - if (!requireNamespace("rstan", quietly = TRUE)) - stop("You need to have the RStan package installed to use this option.", - call. = FALSE) -} -coda_check <- function() { - if (!requireNamespace("coda", quietly = TRUE)) - stop("You need to have the coda package installed to use this option.", - call. = FALSE) +# check object types +sso_check <- function(sso) { + if (!is.shinystan(sso)) { + stop("Please specify a shinystan object.", call. = FALSE) + } else if (sso_version(sso) < utils::packageVersion("shinystan")) { + stop( + "Your shinystan object was created with a previous version of shinystan. ", + "Please use the 'update_sso' function to update your object.", + call. = FALSE + ) + } + invisible(TRUE) } -launch <- function(object, rstudio = FALSE, ...) { - stopifnot(is.shinystan(object)) - launch.browser <- if (!rstudio) - TRUE else getOption("shiny.launch.browser", interactive()) - .sso_env$.shinystan_temp_object <- object - on.exit(.sso_env$.shinystan_temp_object <- NULL, add = TRUE) - shiny::runApp(system.file("ShinyStan", package = "shinystan"), - launch.browser = launch.browser, ...) -} +is.stanfit <- function(x) inherits(x, "stanfit") +is.stanreg <- function(x) inherits(x, "stanreg") -# mcmclist to matrix (adapted from Coda package) -------------------------- -mcmclist2matrix <- function(x) { - out <- matrix(nrow = coda::niter(x) * coda::nchain(x), ncol = coda::nvar(x)) - cols <- 1:coda::nvar(x) - for (i in 1:coda::nchain(x)) { - rows <- (i-1)*coda::niter(x) + 1:coda::niter(x) - out[rows, cols] <- x[[i]] - } - rownames <- character(ncol(out)) - rownames[cols] <- coda::varnames(x, allow.null = FALSE) - dimnames(out) <- list(NULL, rownames) - out + +# check for suggested (not required) packages +check_suggests <- function(pkg) { + if (!requireNamespace(pkg, quietly = TRUE)) + stop( + "You need to have the ", pkg, + " package installed to use this option.", + call. = FALSE + ) } +# grepl with ignore.case defaulting to TRUE grepl_ic <- function(pattern, x, ignore.case = TRUE) { grepl(pattern = pattern, x = x, ignore.case = ignore.case) } -get_type <- function(x) { - if (is.shinystan(x)) return("shinystan") - else if (is.stanfit(x)) return("stanfit") - else if (is.stanreg(x)) return("stanreg") - else if (inherits(x, "mcmc.list")) return("mcmclist") - else if (is.list(x)) return("chainlist") - else return("other") -} - -# functions to set defaults for ppcheck selectInputs for y and y_rep -y_lines <- function(y_name = "y") { - paste0( - "output$ui_pp_y_from_r <- renderUI({ - choices <- objects(envir = .GlobalEnv) - selectizeInput('y_name', label = span(style = 'color: #337ab7;', 'y, a vector of observations'), - choices = c('', choices), - selected = '",y_name,"') - })" - ) -} -yrep_lines <- function(yrep_name) { - paste0( - "output$ui_pp_yrep_from_sso <- renderUI({ - choices <- param_names - choices <- strsplit(choices, split = '[', fixed = TRUE) - choices <- lapply(choices, function(i) return(i[1])) - choices <- unique(unlist(choices)) - selectizeInput('yrep_name', - label = span(style = 'color: #337ab7;', 'y_rep, posterior predictive replications'), - choices = c('', choices), - selected = '",yrep_name,"') - })" +# nocov start +# release reminders (for devtools) +release_questions <- function() { + c( + "Have you updated version numbers in the citation?", + "Have you updated NEWS.md? and inst/NEWS?" ) } - -write_files <- function(files, lines) { - stopifnot(length(files) == length(lines)) - for (f in seq_along(files)) { - fileConn <- file(files[f]) - writeLines(lines[f], fileConn) - close(fileConn) - } -} - -set_ppcheck_defaults <- function(appDir, yrep_name, y_name = "y") { - fileDir <- file.path(appDir, "server_files", "pages", "diagnose", - "ppcheck", "ui") - y_file <- file.path(fileDir, "pp_y_from_r.R") - yrep_file <- file.path(fileDir, "pp_yrep_from_sso.R") - for (file in c("y_file", "yrep_file")) { - f <- get(file) - if (file.exists(f)) { - file.remove(f) - file.create(f) - } - } - write_files( - files = c(y_file, yrep_file), - lines = c(y_lines(y_name), yrep_lines(yrep_name)) - ) -} - -.retrieve <- function(sso, what, ...) { - if (what %in% c("rhat", "rhats", "Rhat", "Rhats", "r_hat", "R_hat")) { - return(retrieve_rhat(sso, ...)) - } - if (what %in% c("N_eff","n_eff", "neff", "Neff", "ess","ESS")) { - return(retrieve_neff(sso, ...)) - } - if (grepl_ic("mean", what)) { - return(retrieve_mean(sso, ...)) - } - if (grepl_ic("sd", what)) { - return(retrieve_sd(sso, ...)) - } - if (what %in% c("se_mean", "mcse")) { - return(retrieve_mcse(sso, ...)) - } - if (grepl_ic("quant", what)) { - return(retrieve_quant(sso, ...)) - } - if (grepl_ic("median", what)) { - return(retrieve_median(sso, ...)) - } - if (grepl_ic("tree", what) | grepl_ic("depth", what)) { - return(retrieve_max_treedepth(sso, ...)) - } - if (grepl_ic("step", what)) { - return(retrieve_avg_stepsize(sso, ...)) - } - if (grepl_ic("diverg", what)) { - return(retrieve_prop_divergent(sso, ...)) - } - if (grepl_ic("accept", what)) { - return(retrieve_avg_accept(sso, ...)) - } -} \ No newline at end of file +# nocov end diff --git a/R/model_code.R b/R/model_code.R deleted file mode 100644 index d51ac6d9..00000000 --- a/R/model_code.R +++ /dev/null @@ -1,71 +0,0 @@ -# This file is part of shinystan -# Copyright (C) 2015 Jonah Gabry -# -# 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 . - - -#' Add model code to a shinystan object or see the code currently stored in -#' a shinystan -#' -#' @export -#' @param sso A shinystan object. -#' @param code Optionally, the code you want to add. See \strong{Details} below for -#' formatting instructions. -#' @return If \code{code} is missing then any code currently stored in -#' \code{sso} is returned as a character string. If \code{code} is specified -#' then then any previous code is overwritten by the text in \code{code} and -#' an updated shinystan object is returned. -#' -#' @details If \code{code} is specified it should be be a character string that -#' can be used as an argument to \code{cat}. See \strong{Examples}, below. -#' @note For \pkg{rstan} users the model code will be automatically taken -#' from the stanfit object. -#' -#' @seealso \code{cat} -#' -#' @examples -#' \dontrun{ -#' # Some JAGS-style code we might want to add -#' my_code <- " -#' model { -#' for (i in 1:length(Y)) { -#' Y[i] ~ dpois(lambda[i]) -#' log(lambda[i]) <- inprod(X[i,], theta[]) -#' } -#' for (j in 1:J) { -#' theta[j] ~ dt(0.0, 1.0, 1.0) -#' } -#' } -#' " -#' -#' # Add the code to a shinystan object sso -#' sso <- model_code(sso, my_code) -#' -#' # View the code currently stored in sso -#' model_code(sso) -#' -#'} - -model_code <- function(sso, code) { - sso_check(sso) - if (missing(code)) { - return(slot(sso, "model_code")) - } - - if (!is.character(code)) - stop("'code' should be a character string.") - slot(sso, "model_code") <- code - message(paste0("Successfully added code.", "\nYou can view the code in the", - "ShinyStan GUI on the 'Model Code' page.")) - sso -} diff --git a/R/notes.R b/R/notes.R deleted file mode 100644 index 505212be..00000000 --- a/R/notes.R +++ /dev/null @@ -1,57 +0,0 @@ -# This file is part of shinystan -# Copyright (C) 2015 Jonah Gabry -# -# 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 . - -#' Additional or replacement notes -#' -#' Notes are viewable on ShinyStan's Notepad page -#' -#' @export -#' @param sso shinystan object. -#' @param notes Optional. A character vector of additional or replacement notes. -#' @param replace If \code{TRUE} the existing notes are overwritten by -#' \code{notes} if \code{notes} is specified. If \code{FALSE} (the default) -#' if \code{notes} is specified then its content is appended to the existing -#' notes. -#' @return If \code{notes} is missing then any existing notes stored in -#' \code{sso} are returned as a character string. If \code{notes} is specified -#' then an updated shinystan object is returned with either \code{notes} added -#' to the previous notes (if \code{replace=FALSE}) or overwritten by -#' \code{notes} (if \code{replace = TRUE}). -#' -#' -#' @seealso \code{\link{as.shinystan}} -#' @examples -#' \dontrun{ -#' sso <- notes(sso, "new note") -#' sso <- notes(sso, c("a different note", "another note"), replace = TRUE) -#' -#' # See any notes currently in sso -#' notes(sso) -#' } -#' -notes <- function(sso, notes, replace = FALSE) { - if (missing(notes)) { - return(slot(sso, "user_model_info")) - } - if (length(notes) > 1L) { - notes <- c(notes[1L], paste0("\n\n", notes[-1L])) - } - slot(sso, "user_model_info") <- if (replace) - notes else c(slot(sso, "user_model_info"), paste0("\n\n", notes)) - - message(paste0("Successfully added notes.", "\nYou can view the notes in the", - "ShinyStan GUI on the 'Notepad' page.")) - sso -} diff --git a/R/rename_model.R b/R/rename_model.R deleted file mode 100644 index 4ae856ff..00000000 --- a/R/rename_model.R +++ /dev/null @@ -1,33 +0,0 @@ -# This file is part of shinystan -# Copyright (C) 2015 Jonah Gabry -# -# 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 . - -#' Change the model name associated with a shinystan object -#' -#' @param sso shinystan object. -#' @param new_model_name Character string giving the new model name to use. -#' @return sso, updated. -#' @seealso \code{\link{as.shinystan}} -#' @export -#' @examples -#' \dontrun{ -#' sso <- rename_model(sso, "new name for model") -#' } -#' - -rename_model <- function(sso, new_model_name) { - sso_check(sso) - sso@model_name <- new_model_name - sso -} \ No newline at end of file diff --git a/R/retrieve.R b/R/retrieve.R index 678d4f33..98319a70 100644 --- a/R/retrieve.R +++ b/R/retrieve.R @@ -1,6 +1,3 @@ -# This file is part of shinystan -# Copyright (C) 2015 Jonah Gabry -# # 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 @@ -13,54 +10,173 @@ # You should have received a copy of the GNU General Public License along with # this program; if not, see . + #' Get summary statistics from shinystan object #' #' From a shinystan object get rhat, effective sample size, posterior #' quantiles, means, standard deviations, sampler diagnostics, etc. #' -#' @param sso A shinystan object -#' @param what What do you want to get? See \strong{Details}, below. +#' @export +#' @template args-sso +#' @param what What do you want to get? See Details, below. #' @param ... Optional arguments, in particular \code{pars} to specify parameter #' names (by default all parameters will be used). For NUTS sampler parameters #' only (e.g. stepsize, treedepth) \code{inc_warmup} can also be specified to #' include/exclude warmup iterations (the default is \code{FALSE}). See -#' \strong{Details}, below. +#' Details, below. #' -#' @details The argument \code{what} can take on the values below. Args: \code{arg} -#' means that \code{arg} can be specified in \code{...} for this value of \code{what}. +#' @details The argument \code{what} can take on the values below. Args: +#' \code{arg} means that \code{arg} can be specified in \code{...} for this +#' value of \code{what}. #' \describe{ -#' \item{\code{"rhat", "Rhat", "r_hat", or "R_hat"}}{returns: Rhat statistics. Args: \code{pars}} -#' \item{\code{"N_eff","n_eff", "neff", "Neff", "ess", or "ESS"}}{returns: Effective sample sizes. Args: \code{pars}} +#' \item{\code{"rhat"}, \code{"Rhat"}, \code{"r_hat"}, or \code{"R_hat"}}{returns: Rhat statistics. Args: \code{pars}} +#' \item{\code{"N_eff"}, \code{"n_eff"}, \code{"neff"}, \code{"Neff"}, \code{"ess"}, or \code{"ESS"}}{returns: Effective sample sizes. Args: \code{pars}} #' \item{\code{"mean"}}{returns: Posterior means. Args: \code{pars}} #' \item{\code{"sd"}}{returns: Posterior standard deviations. Args: \code{pars}} -#' \item{\code{"se_mean" or "mcse"}}{returns: Monte carlo standard error. Args: \code{pars}} +#' \item{\code{"se_mean"} or \code{"mcse"}}{returns: Monte carlo standard error. Args: \code{pars}} #' \item{\code{"median"}}{returns: Posterior medians. Args: \code{pars}.} -#' \item{\code{"quantiles" or any string with "quant" in it (not case sensitive)}}{returns: 2.5\%, 25\%, 50\%, 75\%, 97.5\% posterior quantiles. Args: \code{pars}.} -#' \item{\code{"avg_accept_stat" or any string with "accept" in it (not case sensitive)}}{returns: Average value of "accept_stat" (which itself is the average acceptance probability over the NUTS subtree). Args: \code{inc_warmup}} -#' \item{\code{"prop_divergent" or any string with "diverg" in it (not case sensitive)}}{returns: Proportion of divergent iterations for each chain. Args: \code{inc_warmup}} -#' \item{\code{"max_treedepth" or any string with "tree" or "depth" in it (not case sensitive)}}{returns: Maximum treedepth for each chain. Args: \code{inc_warmup}} -#' \item{\code{"avg_stepsize" or any string with "step" in it (not case sensitive)}}{returns: Average stepsize for each chain. Args: \code{inc_warmup}} +#' \item{\code{"quantiles"} or any string with \code{"quant"} in it (not case sensitive)}{returns: 2.5\%, 25\%, 50\%, 75\%, 97.5\% posterior quantiles. Args: \code{pars}.} +#' \item{\code{"avg_accept_stat"} or any string with \code{"accept"} in it (not case sensitive)}{returns: Average value of "accept_stat" (which itself is the average acceptance probability over the NUTS subtree). Args: \code{inc_warmup}} +#' \item{\code{"prop_divergent"} or any string with \code{"diverg"} in it (not case sensitive)}{returns: Proportion of divergent iterations for each chain. Args: \code{inc_warmup}} +#' \item{\code{"max_treedepth"} or any string with \code{"tree"} or \code{"depth"} in it (not case sensitive)}{returns: Maximum treedepth for each chain. Args: \code{inc_warmup}} +#' \item{\code{"avg_stepsize"} or any string with \code{"step"} in it (not case sensitive)}{returns: Average stepsize for each chain. Args: \code{inc_warmup}} #' } #' #' @note Sampler diagnostics (e.g. \code{"avg_accept_stat"}) only available for #' models originally fit using Stan. -#' -#' @export +#' #' @examples -#' \dontrun{ -#' # assume 'X' is a shinystan object with parameters -#' # 'beta[1]', 'beta[2]', 'sigma[1]', 'sigma[2]'" +#' # Using example shinystan object 'eight_schools' +#' sso <- eight_schools +#' retrieve(sso, "rhat") +#' retrieve(sso, "mean", pars = c('theta[1]', 'mu')) +#' retrieve(sso, "quantiles") +#' retrieve(sso, "max_treedepth") # equivalent to retrieve(sso, "depth"), retrieve(sso, "tree"), etc. +#' retrieve(sso, "prop_divergent") +#' retrieve(sso, "prop_divergent", inc_warmup = TRUE) #' -#' retrieve(X, "rhat") -#' retrieve(X, "mean", pars = c('beta[1]', 'sigma[1]')) -#' retrieve(X, "quantiles") -#' -#' retrieve(X, "max_treedepth") # equivalent to retrieve(X, "depth"), retrieve(X, "tree"), etc. -#' retrieve(X, "prop_divergent", inc_warmup = FALSE) # don't include warmup iterations -#' } -#' - retrieve <- function(sso, what, ...) { sso_check(sso) .retrieve(sso, what, ...) } + + +# retrieve helpers +.retrieve <- function(sso, what, ...) { + if (what %in% c("rhat", "rhats", "Rhat", "Rhats", "r_hat", "R_hat")) + return(retrieve_rhat(sso, ...)) + if (what %in% c("N_eff", "n_eff", "neff", "Neff", "ess", "ESS")) + return(retrieve_neff(sso, ...)) + if (grepl_ic("mean", what)) + return(retrieve_mean(sso, ...)) + if (grepl_ic("sd", what)) + return(retrieve_sd(sso, ...)) + if (what %in% c("se_mean", "mcse")) + return(retrieve_mcse(sso, ...)) + if (grepl_ic("quant", what)) + return(retrieve_quant(sso, ...)) + if (grepl_ic("median", what)) + return(retrieve_median(sso, ...)) + if (grepl_ic("tree", what) | grepl_ic("depth", what)) + return(retrieve_max_treedepth(sso, ...)) + if (grepl_ic("step", what)) + return(retrieve_avg_stepsize(sso, ...)) + if (grepl_ic("diverg", what)) + return(retrieve_prop_divergent(sso, ...)) + if (grepl_ic("accept", what)) + return(retrieve_avg_accept(sso, ...)) +} + + +retrieve_rhat <- function(sso, pars) { + if (missing(pars)) + return(slot(sso, "summary")[, "Rhat"]) + slot(sso, "summary")[pars, "Rhat"] +} + +retrieve_neff <- function(sso, pars) { + if (missing(pars)) + return(slot(sso, "summary")[, "n_eff"]) + slot(sso, "summary")[pars, "n_eff"] +} + +retrieve_mcse <- function(sso, pars) { + if (missing(pars)) + return(slot(sso, "summary")[, "se_mean"]) + slot(sso, "summary")[pars, "se_mean"] +} + +retrieve_quant <- function(sso, pars) { + cols <- paste0(100 * c(0.025, 0.25, 0.5, 0.75, 0.975), "%") + if (missing(pars)) + return(slot(sso, "summary")[, cols]) + slot(sso, "summary")[pars, cols] +} + +retrieve_median <- function(sso, pars) { + if (missing(pars)) + return(retrieve_quant(sso)[, "50%"]) + retrieve_quant(sso, pars)[, "50%"] +} + +retrieve_mean <- function(sso, pars) { + if (missing(pars)) + return(slot(sso, "summary")[, "mean"]) + slot(sso, "summary")[pars, "mean"] +} + +retrieve_sd <- function(sso, pars) { + if (missing(pars)) + return(slot(sso, "summary")[, "sd"]) + slot(sso, "summary")[pars, "sd"] +} + + +.sp_check <- function(sso) { + if (identical(slot(sso, "sampler_params"), list(NA))) + stop("No sampler parameters found", call. = FALSE) +} + +.which_rows <- function(sso, inc_warmup) { + if (inc_warmup) { + seq_len(slot(sso, "n_iter")) + } else { + seq(from = 1 + slot(sso, "n_warmup"), to = slot(sso, "n_iter")) + } +} + +retrieve_max_treedepth <- function(sso, inc_warmup = FALSE) { + .sp_check(sso) + rows <- .which_rows(sso, inc_warmup) + max_td <- sapply(slot(sso, "sampler_params"), function(x) + max(x[rows, "treedepth__"])) + names(max_td) <- paste0("chain", 1:length(max_td)) + max_td +} + +retrieve_prop_divergent <- function(sso, inc_warmup = FALSE) { + .sp_check(sso) + rows <- .which_rows(sso, inc_warmup) + prop_div <- sapply(slot(sso, "sampler_params"), function(x) + mean(x[rows, "divergent__"])) + names(prop_div) <- paste0("chain", 1:length(prop_div)) + prop_div +} + +retrieve_avg_stepsize <- function(sso, inc_warmup = FALSE) { + .sp_check(sso) + rows <- .which_rows(sso, inc_warmup) + avg_ss <- sapply(slot(sso, "sampler_params"), function(x) + mean(x[rows, "stepsize__"])) + names(avg_ss) <- paste0("chain", 1:length(avg_ss)) + avg_ss +} + +retrieve_avg_accept <- function(sso, inc_warmup = FALSE) { + .sp_check(sso) + rows <- .which_rows(sso, inc_warmup) + avg_accept <- sapply(slot(sso, "sampler_params"), function(x) + mean(x[rows, "accept_stat__"])) + names(avg_accept) <- paste0("chain", 1:length(avg_accept)) + avg_accept +} diff --git a/R/shinystan-class.R b/R/shinystan-class.R deleted file mode 100644 index 5b14fa0e..00000000 --- a/R/shinystan-class.R +++ /dev/null @@ -1,70 +0,0 @@ -# This file is part of shinystan -# Copyright (C) 2015 Jonah Gabry -# -# 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 . - -#' S4 shinystan objects (sso) -#' -#' @description shinystan objects -#' -#' @section Creating shinystan objects: -#' -#' See \code{\link{as.shinystan}}. -#' -#' @section Hosting your own ShinyStan apps online: -#' -#' See \code{\link{deploy_shinystan}}. -#' -#' @section Functions for manipulating shinystan objects: -#' -#' \code{\link{notes}} Add to or replace notes. -#' -#' \code{\link{rename_model}} Change the model name. -#' -#' \code{\link{generate_quantity}} Add new parameters/quantities as a function -#' of one or two existing parameters. -#' -#' \code{\link{model_code}} Add or change model code. -#' -#' \code{\link{update_sso}} Update a shinystan object created by an older version -#' of the package. -#' -shinystan <- setClass("shinystan", - slots = list(model_name = "character", - param_names = "character", - param_dims = "list", - samps_all = "array", - summary = "matrix", - sampler_params = "list", - nChains = "numeric", - nIter = "numeric", - nWarmup = "numeric", - user_model_info = "character", - model_code = "character", - misc = "list" - ), - prototype = list(model_name = "No name", - param_names = "", - param_dims = list(), - samps_all = array(NA, c(1,1)), - summary = matrix(NA, nr=1,nc=1), - sampler_params = list(NA), - nChains = 0, - nIter = 0, - nWarmup = 0, - user_model_info = - "Use this space to store notes about your model", - model_code = - "Use this space to store your model code", - misc = list() - )) diff --git a/R/shinystan-objects.R b/R/shinystan-objects.R new file mode 100644 index 00000000..d37bb52a --- /dev/null +++ b/R/shinystan-objects.R @@ -0,0 +1,730 @@ +# 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 . + + +# shinystan class definition ------------------------------------------ +#' S4 shinystan objects +#' +#' @aliases shinystan-class +#' @description See \code{\link{as.shinystan}} for documentation on creating +#' shinystan objects and \code{\link{eight_schools}} for an example object. +#' +#' @slot model_name (\code{"character"}) Model name. +#' @slot param_names (\code{"character"}) Parameter names. +#' @slot param_dims (\code{"list"}) Parameter dimensions. +#' @slot posterior_sample (\code{"array"}) MCMC sample. +#' @slot summary (\code{"matrix"}) Summary stats for \code{posterior_sample}. +#' @slot sampler_params (\code{"list"}) Sampler parameters (for certain Stan +#' models only). +#' @slot n_chain (\code{"integer"}) Number of chains. +#' @slot n_iter (\code{"integer"}) Number of iterations per chain. +#' @slot n_warmup (\code{"integer"}) Number of warmup iterations per chain. +#' @slot user_model_info (\code{"character"}) Notes to display on ShinyStan's +#' \strong{Notepad} page. +#' @slot model_code (\code{"character"}) Model code to display on ShinyStan's +#' \strong{Model Code} page. +#' @slot misc (\code{"list"}) Miscellaneous, for internal use. +#' +#' @template seealso-as.shinystan +#' @template seealso-drop_parameters +#' @template seealso-generate_quantity +#' @seealso \code{\link{shinystan-metadata}} to view or change metadata +#' associated with a shinystan object. +#' +shinystan <- setClass( + Class = "shinystan", + slots = list( + model_name = "character", + param_names = "character", + param_dims = "list", + posterior_sample = "array", + summary = "matrix", + sampler_params = "list", + n_chain = "numeric", + n_iter = "numeric", + n_warmup = "numeric", + user_model_info = "character", + model_code = "character", + misc = "list" + ), + prototype = list( + model_name = "No name", + param_names = "", + param_dims = list(), + posterior_sample = array(NA, c(1, 1)), + summary = matrix(NA, nr = 1, nc =1), + sampler_params = list(NA), + n_chain = 0, + n_iter = 0, + n_warmup = 0, + user_model_info = "Use this space to store notes about your model", + model_code = "Use this space to store your model code", + misc = list(sso_version = utils::packageVersion("shinystan")) + ) +) + + + +# create shinystan objects ------------------------------------------------ + +# as.shinystan (generic) -------------------------------------------------- +#' Create and test shinystan objects +#' +#' @description The \code{as.shinystan} function creates shinystan objects that +#' can be used with \code{\link{launch_shinystan}} and various other functions +#' in the \pkg{shinystan} package. \code{as.shinystan} is a generic for which +#' the \pkg{shinystan} package provides several methods. Currently methods are +#' provided for creating shinystan objects from arrays, lists of matrices, +#' stanfit objects (\pkg{rstan}), stanreg objects (\pkg{rstanarm}), and +#' mcmc.list objects (\pkg{coda}). +#' +#' \code{is.shinystan} tests if an object is a shinystan object. +#' +#' @name as.shinystan +#' @export +#' @param X For \code{as.shinystan}, an object to be converted to a shinystan +#' object. See the Methods section below. For \code{is.shinystan}, an object +#' to check. +#' @param ... Arguments passed to the individual methods. +#' +#' @return \code{as.shinystan} returns a shinystan object, which is an instance +#' of S4 class \code{"shinystan"}. +#' +#' \code{is.shinystan} returns \code{TRUE} if the tested object is a shinystan +#' object and \code{FALSE} otherwise. +#' +#' @template seealso-launch +#' @template seealso-drop_parameters +#' @template seealso-generate_quantity +#' +setGeneric("as.shinystan", function(X, ...) { + if (inherits(X, "shinystan")) + stop("Already a shinystan object.") + standardGeneric("as.shinystan") +}) + +#' @export +#' @rdname as.shinystan +is.shinystan <- function(X) inherits(X, "shinystan") + +# as.shinystan (array) --------------------------------------------------- +#' @describeIn as.shinystan Create a shinystan object from a 3-D +#' \code{\link{array}} of simulations. The array should have dimensions +#' corresponding to iterations, chains, and parameters, in that order. +#' +#' @param model_name A string giving a name for the model. +#' @param burnin The number of iterations to treat as burnin (warmup). Should be +#' \code{0} if warmup iterations are not included in \code{X}. +#' @param param_dims Rarely used and never necessary. A named list giving the +#' dimensions for all parameters. For scalar parameters use \code{0} as the +#' dimension. See Examples. +#' @param model_code Optionally, a character string with the code used to run +#' the model. This can also be added to your \code{shinystan} object later +#' using the \code{\link[shinystan]{model_code}} function. See +#' \code{\link[shinystan]{model_code}} for additional formatting instructions. +#' After launching the app the code will be viewable in the \strong{Model +#' Code} tab. For \code{stanfit} (\pkg{rstan}) and \code{stanreg} +#' (\pkg{rstanarm}) objects the model code is automatically retrieved from the +#' object. +#' @param note Optionally, text to display on ShinyStan's notes page (stored in +#' \code{user_model_info} slot). +#' +#' @examples +#' \dontrun{ +#' sso <- as.shinystan(X, ...) # replace ... with optional arguments or omit it +#' launch_shinystan(sso) +#' } +#' +setMethod( + "as.shinystan", + signature = "array", + definition = function(X, + model_name = "unnamed model", + burnin = 0, + param_dims = list(), + model_code = NULL, + note = NULL, + ...) { + validate_model_code(model_code) + is3D <- isTRUE(length(dim(X)) == 3) + if (!is3D) + stop ("'X' must have 3 dimensions.") + + if (is.null(dimnames(X)[[3]])) + dimnames(X)[[3]] <- paste0("V", seq_len(dim(X)[3])) + param_names <- dimnames(X)[[3]] + dimnames(X) <- list( + iterations = seq_len(nrow(X)), + chains = paste0("chain:", seq_len(ncol(X))), + parameters = param_names + ) + + sso <- shinystan( + model_name = model_name, + param_names = param_names, + param_dims = .set_param_dims(param_dims, param_names), + posterior_sample = X, + summary = shinystan_monitor(X, warmup = burnin), + n_chain = ncol(X), + n_iter = nrow(X), + n_warmup = burnin + ) + if (!is.null(note)) + sso <- suppressMessages(notes(sso, note = note, replace = TRUE)) + if (!is.null(model_code)) + sso <- suppressMessages(model_code(sso, code = model_code)) + + return(sso) + } +) + +.set_param_dims <- function(param_dims = list(), + param_names = character(length(param_dims))) { + if (!length(param_dims)) { + param_dims <- list() + param_dims[seq_along(param_names)] <- NA + names(param_dims) <- param_names + for (i in seq_along(param_names)) + param_dims[[i]] <- numeric(0) + } else { + zeros <- sapply(seq_along(param_dims), function(i) + 0 %in% param_dims[[i]]) + for (i in which(zeros)) + param_dims[[i]] <- numeric(0) + } + param_dims +} + + +# as.shinystan (list) --------------------------------------------------- +#' @describeIn as.shinystan Create a shinystan object from a \code{\link{list}} +#' of matrices. Each \code{\link{matrix}} (or 2-D array) should contain the +#' simulations for an individual chain and all of the matrices should have the +#' same number of iterations (rows) and parameters (columns). Parameters +#' should have the same names and be in the same order. +#' +#' @examples +#' \dontrun{ +#' ######################## +#' ### list of matrices ### +#' ######################## +#' +#' # Generate some fake data +#' chain1 <- cbind(beta1 = rnorm(100), beta2 = rnorm(100), sigma = rexp(100)) +#' chain2 <- cbind(beta1 = rnorm(100), beta2 = rnorm(100), sigma = rexp(100)) +#' sso <- as.shinystan(list(chain1, chain2)) +#' launch_shinystan(sso) +#' +#' # We can also specify some or all of the optional arguments +#' # note: in order to use param_dims we need to rename 'beta1' and 'beta2' +#' # to 'beta[1]' and 'beta[2]' +#' colnames(chain1) <- colnames(chain2) <- c(paste0("beta[",1:2,"]"), "sigma") +#' sso2 <- as.shinystan(list(chain1, chain2), +#' model_name = "Example", burnin = 0, +#' param_dims = list(beta = 2, sigma = 0)) +#' launch_shinystan(sso2) +#' } +#' +setMethod( + "as.shinystan", + signature = "list", + definition = function(X, + model_name = "unnamed model", + burnin = 0, + param_dims = list(), + model_code = NULL, + note = NULL, + ...) { + validate_model_code(model_code) + if (!length(X)) + stop('List is empty.') + + dims <- sapply(X, function(x) length(dim(x))) + if (!isTRUE(all(dims == 2))) + stop("All elements of X should be matrices / 2-D arrays.") + + nChain <- length(X) + for (i in seq_len(nChain)) { + nms <- colnames(as.matrix(X[[i]])) + if (is.null(nms) || !all(nzchar(nms))) + stop( + "Some parameters are missing names. ", + "Check the column names for the matrices in your list of chains." + ) + } + + if (nChain == 1) { + n_iter <- nrow(X[[1]]) + param_names <- colnames(X[[1]]) + } else { + n_iter <- sapply(X, nrow) + same_iters <- length(unique(n_iter)) == 1 + if (!same_iters) + stop("Each chain should contain the same number of iterations.") + cnames <- sapply(X, colnames) + if (is.array(cnames)) { + same_params <- identical(cnames[, 1], cnames[, 2]) + param_names <- cnames[, 1] + } else { + same_params <- length(unique(cnames)) == 1 + param_names <- cnames + } + if (!same_params) + stop("The parameters for each chain should be in the same order ", + "and have the same names.") + n_iter <- n_iter[1] + } + param_names <- unique(param_names) + nParam <- length(param_names) + out <- array(NA, dim = c(n_iter, nChain, nParam)) + for (i in seq_len(nChain)) + out[, i,] <- X[[i]] + + dimnames(out) <- list( + iterations = NULL, + chains = paste0("chain:", seq_len(nChain)), + parameters = param_names + ) + as.shinystan( + out, + model_name = model_name, + burnin = burnin, + param_dims = param_dims, + model_code = model_code, + note = note, + ... + ) + } +) + + +# as.shinystan (mcmc.list) ----------------------------------------------- +setOldClass("mcmc.list") +#' @describeIn as.shinystan Create a shinystan object from an mcmc.list +#' (\pkg{coda}). +#' +setMethod( + "as.shinystan", + signature = "mcmc.list", + definition = function(X, + model_name = "unnamed model", + burnin = 0, + param_dims = list(), + model_code = NULL, + note = NULL, + ...) { + check_suggests("coda") + validate_model_code(model_code) + + if (length(X) == 1) { + return( + as.shinystan( + X = list(.mcmclist2matrix(X)), + model_name = model_name, + burnin = burnin, + param_dims = param_dims, + model_code = model_code, + note = note, + ... + ) + ) + } + + posterior <- array( + NA, + dim = c(coda::niter(X), coda::nvar(X), coda::nchain(X)), + dimnames = list( + iter = time(X), + var = coda::varnames(X), + chain = coda::chanames(X) + ) + ) + for (c in seq_len(coda::nchain(X))) + posterior[, , c] <- X[[c]] + + posterior <- aperm(drop(posterior), c(1, 3, 2)) + dimnames(posterior) <- list( + iterations = seq_len(nrow(posterior)), + chains = paste0("chain:", seq_len(ncol(posterior))), + parameters = dimnames(posterior)[[3]] + ) + param_names <- dimnames(X[[1]])[[2]] + + sso <- shinystan( + model_name = model_name, + param_names = param_names, + param_dims = .set_param_dims(param_dims, param_names), + posterior_sample = posterior, + summary = shinystan_monitor(posterior, warmup = burnin), + n_chain = ncol(posterior), + n_iter = nrow(posterior), + n_warmup = burnin + ) + if (!is.null(note)) + sso <- suppressMessages(notes(sso, note = note, replace = TRUE)) + if (!is.null(model_code)) + sso <- suppressMessages(model_code(sso, code = model_code)) + + return(sso) + } +) + +.mcmclist2matrix <- function(x) { + # adapted from Coda package + out <- matrix(nrow = coda::niter(x) * coda::nchain(x), ncol = coda::nvar(x)) + cols <- seq_len(coda::nvar(x)) + for (i in seq_len(coda::nchain(x))) { + rows <- (i-1)*coda::niter(x) + seq_len(coda::niter(x)) + out[rows, cols] <- x[[i]] + } + rownames <- character(ncol(out)) + rownames[cols] <- coda::varnames(x, allow.null = FALSE) + dimnames(out) <- list(NULL, rownames) + out +} + + +# as.shinystan (stanfit) ------------------------------------------------- +setClass("stanfit", getClass("stanfit", where = getNamespace("rstan"))) + +#' @describeIn as.shinystan Create a shinystan object from a stanfit object +#' (\pkg{\link[rstan]{rstan}}). Fewer optional arguments are available for +#' this method because all important information can be taken automatically +#' from the stanfit object. +#' +#' @param pars For stanfit objects (\pkg{rstan}), an optional character vector +#' specifying which parameters should be included in the shinystan object. +#' +#' @examples +#' \dontrun{ +#' ###################### +#' ### stanfit object ### +#' ###################### +#' library("rstan") +#' fit <- stan_demo("eight_schools") +#' sso <- as.shinystan(fit, model_name = "example") +#' } +#' +setMethod( + "as.shinystan", + signature = "stanfit", + definition = function(X, + pars, + model_name = X@model_name, + note = NULL, + ...) { + check_suggests("rstan") + if (!missing(pars)) { + any_indiv_els <- any(grepl("[", pars, fixed = TRUE)) + if (any_indiv_els) + stop("Individual elements of non-scalar parameters not allowed in 'pars'.") + if (!"lp__" %in% pars) + pars <- c(pars, "lp__") + } + + posterior <- + rstan::extract(X, + pars = pars, + permuted = FALSE, + inc_warmup = TRUE) + + param_dims <- X@sim$dims_oi + if (!missing(pars)) { + pd <- which(names(param_dims) %in% pars) + if (length(pd)) + param_dims <- param_dims[pd] + } + + sso <- shinystan( + model_name = model_name, + param_names = dimnames(posterior)[[3L]], + param_dims = param_dims, + posterior_sample = posterior, + summary = .rstan_summary(X, pars = pars), + sampler_params = .rstan_sampler_params(X), + n_chain = ncol(X), + n_iter = nrow(posterior), + n_warmup = .rstan_warmup(X), + model_code = rstan::get_stancode(X), + misc = list( + max_td = .rstan_max_treedepth(X), + stan_method = .stan_args(X, "method"), + stan_algorithm = .stan_algorithm(X), + sso_version = utils::packageVersion("shinystan") + ) + ) + sso <- .rename_scalar(sso, oldname = "lp__", newname = "log-posterior") + if (!is.null(note)) + sso <- suppressMessages(notes(sso, note, replace = TRUE)) + + return(sso) + } +) + +# rename a scalar parameter in a shinystan object +.rename_scalar <- function(sso, + oldname = "lp__", + newname = "log-posterior") { + p <- which(sso@param_names == oldname) + if (identical(integer(0), p)) + return(sso) + + sso@param_names[p] <- + dimnames(sso@posterior_sample)$parameters[p] <- + names(sso@param_dims)[which(names(sso@param_dims) == oldname)] <- + rownames(sso@summary)[p] <- newname + return(sso) +} + +# Get stan_args from stanfit object +# @param x stanfit object +# @param which which of the entries in x@stan_args[[1]] is of interest? If NULL +# the full list x@stan_args is returned +.stan_args <- function(x, which = NULL) { + stan_args <- x@stan_args[[1L]] + if (!is.null(which)) + return(stan_args[[which]]) + stan_args +} + +# Check if model was fit using cmdstan rather than rstan +# @param x stanfit object +.from_cmdstan <- function(x) { + isTRUE("engine" %in% names(.stan_args(x))) +} + +# Check if model fit using variational algorithm +# @param x stanfit object +.used_vb <- function(x) { + isTRUE(.stan_args(x, "method") == "variational") +} + +# Check which algorithm was used to fit model +# @param x stanfit object +.stan_algorithm <- function(x) { + algo <- if (.from_cmdstan(x)) + toupper(.stan_args(x, "engine")) else .stan_args(x, "algorithm") + + if (.used_vb(x) || !(algo %in% c("NUTS", "HMC"))) + warning("Many features are only available for models fit using + algorithm NUTS or algorithm HMC.", call. = FALSE) + + algo +} + +# Get summary stats from a stanfit object +# @param x stanfit object +# @param pars optional vector of parameter names +.rstan_summary <- function(x, pars) { + stan_summary <- rstan::summary(x, pars = pars)$summary + if (!.used_vb(x)) + return(stan_summary) + cbind(stan_summary, Rhat = NA, n_eff = NA, se_mean = NA) +} + +# Get sampler params from a stanfit object +# @param x stanfit object +.rstan_sampler_params <- function(x) { + if (.used_vb(x)) + return(list(NA)) + sp <- suppressWarnings(rstan::get_sampler_params(x)) + sp <- .rename_sampler_param(sp, + oldname = "n_divergent__", + newname = "divergent__") + sp +} + +# @param x list of sampler param arrays +.rename_sampler_param <- function(x, oldname, newname) { + if (!identical(x, list(NA))) { + for (j in seq_along(x)) { + sel <- which(colnames(x[[j]]) == oldname) + if (length(sel)) + colnames(x[[j]])[sel] <- newname + } + } + return(x) +} + +# Calculate correct value for number of warmup iterations +# @param x stanfit object +.rstan_warmup <- function(x) { + warmup <- if (.from_cmdstan(x)) + x@sim$warmup2[1L] else x@sim$warmup + + saved <- .stan_args(x, "save_warmup") + if (!is.null(saved) && !saved) + warmup <- 0 + + if (.from_cmdstan(x)) + return(warmup) + + floor(warmup / x@sim$thin) +} + +# Get value of max_treedepth parameter from stanfit object +# @param x stanfit object +.rstan_max_treedepth <- function(x) { + cntrl <- .stan_args(x, "control") + if (is.null(cntrl)) { + max_td <- 11 + } else { + max_td <- cntrl$max_treedepth + if (is.null(max_td)) + max_td <- 11 + } + max_td +} + + + +# as.shinystan (stanreg) ------------------------------------------------- +setOldClass("stanreg") +#' @describeIn as.shinystan Create a shinystan object from a stanreg object +#' (\pkg{\link[rstanarm]{rstanarm}}). +#' +#' @param ppd For stanreg objects (\pkg{rstanarm}), \code{ppd} +#' (logical) indicates whether to draw from the posterior predictive +#' distribution before launching ShinyStan. The default is \code{TRUE}, +#' although for very large objects it can be convenient to set it to +#' \code{FALSE} as drawing from the posterior predictive distribution can be +#' time consuming. If \code{ppd} is \code{TRUE} then graphical posterior +#' predictive checks are available when ShinyStan is launched. +#' @param seed Passed to \code{\link[rstanarm]{pp_check}} (\pkg{rstanarm}) if +#' \code{ppd} is \code{TRUE}. +#' +#' @examples +#' \dontrun{ +#' ###################### +#' ### stanreg object ### +#' ###################### +#' library("rstanarm") +#' example("example_model") +#' sso <- as.shinystan(example_model) +#' launch_shinystan(sso) +#' } +#' +setMethod( + "as.shinystan", + signature = "stanreg", + definition = function(X, + ppd = TRUE, + seed = 1234, + model_name = NULL, + note = NULL, + ...) { + check_suggests("rstanarm") + sso <- as.shinystan(X$stanfit, ...) + + mname <- if (!is.null(model_name)) + model_name else paste0("rstanarm model (", sso@model_name, ")") + sso <- suppressMessages(model_name(sso, mname)) + + if (!is.null(note)) + sso <- suppressMessages(notes(sso, note, replace = TRUE)) + + param_names <- slot(sso, "param_names") + sel <- grep(":_NEW_", dimnames(slot(sso, "posterior_sample"))[[3L]], + fixed = TRUE) + if (length(sel)) { + param_names <- param_names[-sel] + slot(sso, "posterior_sample") <- + slot(sso, "posterior_sample")[, , -sel, drop = FALSE] + slot(sso, "summary") <- + slot(sso, "summary")[-sel, , drop = FALSE] + } + param_dims <- rep(list(numeric(0)), length(param_names)) + names(param_dims) <- param_names + + slot(sso, "param_names") <- param_names + slot(sso, "param_dims") <- param_dims + slot(sso, "misc")[["stanreg"]] <- TRUE + if (isTRUE(ppd)) + slot(sso, "misc")[["pp_check_plots"]] <- .rstanarm_pp_checks(X, seed) + + return(sso) + } +) + +.rstanarm_pp_checks <- function(X, seed, ...) { + message( + "\nHang on... preparing graphical posterior predictive checks for rstanarm model.", + "\nSee help('shinystan', 'rstanarm') for how to disable this feature." + ) + ppc <- rstanarm::pp_check + pp_check_plots <- list() + + pp_check_plots[["pp_check_hist"]] <- + do.call("ppc", + list( + object = X, + check = "dist", + nreps = 8, + overlay = FALSE, + seed = seed + )) + pp_check_plots[["pp_check_dens"]] <- + do.call("ppc", + list( + object = X, + check = "dist", + nreps = 8, + overlay = TRUE, + seed = seed + )) + pp_check_plots[["pp_check_resid"]] <- + do.call("ppc", list( + object = X, + check = "resid", + nreps = 8, + seed = seed + )) + pp_check_plots[["pp_check_scatter"]] <- + do.call("ppc", + list( + object = X, + check = "scatter", + nreps = NULL, + seed = seed + )) + pp_check_plots[["pp_check_stat_mean"]] <- + do.call("ppc", + list( + object = X, + check = "test", + test = "mean", + seed = seed + )) + pp_check_plots[["pp_check_stat_sd"]] <- + do.call("ppc", list( + object = X, + check = "test", + test = "sd", + seed = seed + )) + pp_check_plots[["pp_check_stat_min"]] <- + do.call("ppc", list( + object = X, + check = "test", + test = "min", + seed = seed + )) + pp_check_plots[["pp_check_stat_max"]] <- + do.call("ppc", list( + object = X, + check = "test", + test = "max", + seed = seed + )) + + pp_check_plots +} diff --git a/R/shinystan-package.R b/R/shinystan-package.R index 05d7ca94..a313fcce 100644 --- a/R/shinystan-package.R +++ b/R/shinystan-package.R @@ -1,6 +1,3 @@ -# This file is part of shinystan -# Copyright (C) 2015 Jonah Gabry -# # 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 @@ -13,34 +10,39 @@ # You should have received a copy of the GNU General Public License along with # this program; if not, see . -#' The ShinyStan interface and shinystan R package + +#' ShinyStan interface and shinystan R package #' +#' @docType package +#' @name shinystan-package +#' #' @description Applied Bayesian data analysis is primarily implemented through -#' the MCMC algorithms offered by various software packages. When analyzing a -#' posterior sample obtained by one of these algorithms the first step is to -#' check for signs that the chains have converged to the target distribution -#' and and also for signs that the algorithm might require tuning or might be -#' ill-suited for the given model. There may also be theoretical problems or -#' practical inefficiencies with the specification of the model. ShinyStan -#' provides interactive plots and tables helpful for analyzing a posterior -#' sample, with particular attention to identifying potential problems with -#' the performance of the MCMC algorithm or the specification of the model. -#' ShinyStan is powered by RStudio's Shiny web application framework and works -#' with the output of MCMC programs written in any programming language (and -#' has extended functionality for models fit using the rstan package and the -#' No-U-Turn sampler). +#' the Markov chain Monte Carlo (MCMC) algorithms offered by various software +#' packages. When analyzing a posterior sample obtained by one of these +#' algorithms the first step is to check for signs that the chains have +#' converged to the target distribution and and also for signs that the +#' algorithm might require tuning or might be ill-suited for the given model. +#' There may also be theoretical problems or practical inefficiencies with the +#' specification of the model. ShinyStan provides interactive plots and tables +#' helpful for analyzing a posterior sample, with particular attention to +#' identifying potential problems with the performance of the MCMC algorithm +#' or the specification of the model. ShinyStan is powered by RStudio's Shiny +#' web application framework and works with the output of MCMC programs +#' written in any programming language (and has extended functionality for +#' models fit using the rstan package and the No-U-Turn sampler). #' -#' @section ShinyStan has extended functionality for Stan models: -#' -#' Stan (\url{http://mc-stan.org}) models can be run in R using the -#' \pkg{rstan} package. +#' @section ShinyStan has extended functionality for Stan models: +#' +#' Stan (\url{http://mc-stan.org}) models can be run in R using the +#' \pkg{\link[rstan]{rstan}} and \pkg{\link[rstanarm]{rstanarm}} packages. #' #' @section Saving and sharing: #' -#' The \pkg{shinystan} package allows you to store the basic components of an +#' The \pkg{shinystan} package allows you to store the basic components of an #' entire project (code, posterior samples, graphs, tables, notes) in a single -#' object. Users can save many of the plots as ggplot2 objects for further -#' customization and easy integration in reports or post-processing for +#' object, a \code{\link[=as.shinystan]{shinystan object}} (sso, for short). +#' Users can save many of the plots as ggplot2 objects for further +#' customization and easy integration in reports or post-processing for #' publication. #' #' The \code{\link{deploy_shinystan}} function lets you easily deploy your own @@ -57,6 +59,16 @@ #' #' Check out the demo using \code{\link{launch_shinystan_demo}} or try it with #' one of your own models using \code{\link{launch_shinystan}}. +#' +#' @section Help and bug reports: +#' \itemize{ +#' \item Stan Users Google group (\url{https://groups.google.com/forum/#!forum/stan-users}) +#' \item ShinyStan issue tracker (\url{https://github.com/stan-dev/shinystan/issues}) +#' } +#' +#' @template seealso-as.shinystan +#' @template seealso-demo +#' @template seealso-launch #' #' @import ggplot2 #' @import methods @@ -65,7 +77,7 @@ #' @import threejs #' @import utils #' @import xts -#' @importFrom stats acf quantile time var +#' @importFrom stats acf quantile time var na.omit #' @importFrom shinythemes shinytheme #' @importFrom shinyjs colourInput useShinyjs #' @importFrom DT datatable @@ -75,6 +87,4 @@ #' @importFrom reshape2 melt #' @importFrom xtable xtable print.xtable #' -#' @docType package -#' @name shinystan-package -NULL \ No newline at end of file +NULL diff --git a/R/sso-metadata.R b/R/sso-metadata.R new file mode 100644 index 00000000..051bb009 --- /dev/null +++ b/R/sso-metadata.R @@ -0,0 +1,243 @@ +# 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 . + + +#' View or change metadata associated with a shinystan object +#' +#' @name shinystan-metadata +#' @template args-sso +#' +#' @template seealso-as.shinystan +#' @template seealso-drop_parameters +#' @template seealso-generate_quantity +#' +#' @examples +#' # use eight_schools example object +#' sso <- eight_schools +#' +NULL + +# sso_info ---------------------------------------------------------------- +#' @rdname shinystan-metadata +#' @export +#' +#' @return \code{sso_info} prints basic metadata including number of parameters, +#' chains, iterations, warmup iterations, etc. It does not return anything. +#' +#' @examples +#' ################ +#' ### sso_info ### +#' ################ +#' +#' sso_info(sso) +#' +sso_info <- function(sso) { + sso_check(sso) + sso_name <- deparse(substitute(sso)) + has_notes <- + sso@user_model_info != "Use this space to store notes about your model" + has_code <- + sso@model_code != "Use this space to store your model code" + + cat( + sso_name, + "---------------------", + paste("Model name:", sso@model_name), + paste("Parameters:", length(sso@param_names)), + paste("Parameter groups:", length(names(sso@param_dims))), + paste("Chains:", sso@n_chain), + paste("Iterations:", sso@n_iter), + paste("Warmup:", sso@n_warmup), + paste("Has model code:", has_code), + paste("Has user notes:", has_notes), + sep = "\n" + ) +} + + + +# model_code -------------------------------------------------------------- +#' @rdname shinystan-metadata +#' @export +#' @param code A string, containing model code to be added, that can be +#' used as an argument to \code{\link{cat}}. See \strong{Examples}. +#' +#' @return \code{model_code} returns or replaces model code stored in a +#' shinystan object. If \code{code} is \code{NULL} then any existing model +#' code stored in \code{sso} is returned as a character string. If \code{code} +#' is specified then an updated shinystan object is returned with \code{code} +#' added. For shinystan objects created from stanfit (\pkg{rstan}) and stanreg +#' (\pkg{rstanarm}) objects, model code is automatically taken from that +#' object and does not need to be added manually. From within the ShinyStan +#' interface model code can be viewed on the \strong{Model Code} page. +#' +#' @examples +#' ################## +#' ### model_code ### +#' ################## +#' +#' # view model code in example shinystan object 'eight_schools' +#' cat(model_code(sso)) +#' +#' # change the model code in sso +#' # some jags style code +#' my_code <- " +#' model { +#' for (i in 1:length(Y)) { +#' Y[i] ~ dpois(lambda[i]) +#' log(lambda[i]) <- inprod(X[i,], theta[]) +#' } +#' for (j in 1:J) { +#' theta[j] ~ dt(0.0, 1.0, 1.0) +#' } +#' } +#' " +#' sso <- model_code(sso, my_code) +#' cat(model_code(sso)) +#' +model_code <- function(sso, code = NULL) { + sso_check(sso) + validate_model_code(code) + + if (is.null(code)) + return(slot(sso, "model_code")) + + slot(sso, "model_code") <- code + message( + paste0( + "Successfully added code.", + "\nYou can view the code in the", + "ShinyStan GUI on the 'Model Code' page." + ) + ) + sso +} + +validate_model_code <- function(code) { + if (is.null(code) || is.character(code)) { + invisible(TRUE) + } else { + stop("Model code should be NULL or a string", call. = FALSE) + } +} + + + +# notes ------------------------------------------------------------------- +#' @rdname shinystan-metadata +#' @export +#' @param note A string containing a note to add to any existing notes +#' or replace existing notes, depending on the value of \code{replace}. +#' @param replace If \code{TRUE} the existing notes are overwritten by +#' \code{note} if \code{note} is specified. If \code{FALSE} (the default) +#' if \code{note} is specified then its content is appended to the existing +#' notes. +#' +#' @return \code{notes} returns, amends, or replaces notes stored in a shinystan +#' object. If \code{note} is \code{NULL} then any existing notes stored in +#' \code{sso} are returned as a character string. If \code{note} is specified +#' then an updated shinystan object is returned with either \code{note} added +#' to the previous notes (if \code{replace=FALSE}) or overwritten by +#' \code{note} (if \code{replace = TRUE}). From within the ShinyStan +#' interface, notes are viewable on the \strong{Notepad} page. +#' +#' @examples +#' ############# +#' ### notes ### +#' ############# +#' +#' # view existing notes +#' notes(sso) +#' +#' # add a note to the existing notes +#' sso <- notes(sso, "New note") +#' notes(sso) +#' cat(notes(sso)) +#' +#' # replace existing notes +#' sso <- notes(sso, "replacement note", replace = TRUE) +#' notes(sso) +#' +notes <- function(sso, note = NULL, replace = FALSE) { + sso_check(sso) + if (is.null(note)) + return(slot(sso, "user_model_info")) + + if (!is.character(note) || !isTRUE(length(note) == 1)) + stop("'note' should be a single string") + + slot(sso, "user_model_info") <- if (replace) + note else c(slot(sso, "user_model_info"), paste0("\n\n", note)) + + message( + paste( + "Successfully added note.", + "\nYou can view the notes in the", + "ShinyStan GUI on the 'Notepad' page." + ) + ) + sso +} + + + +# model_name (renaming) -----------------------------------------------------#' +#' @rdname shinystan-metadata +#' @export +#' @param name A string giving the new model name to use. +#' +#' @return \code{model_name} returns or replaces the model name associated with +#' a shinystan object. If \code{name} is \code{NULL} then the current model +#' name is returned. If \code{name} is specified then \code{sso} is returned +#' with an updated model name. +#' +#' @examples +#' ################## +#' ### model_name ### +#' ################## +#' +#' # view model name +#' model_name(sso) +#' +#' # change model name +#' sso <- model_name(sso, "some other name") +#' identical(model_name(sso), "some other name") +#' +model_name <- function(sso, name = NULL) { + sso_check(sso) + if (is.null(name)) + return(slot(sso, "model_name")) + + if (!is.character(name) || !isTRUE(length(name) == 1)) + stop("'name' should be a single string") + + slot(sso, "model_name") <- name + message(paste("Successfully changed model name to", name)) + sso +} + + +# nocov start +#' rename_model (deprecated) +#' +#' This function is deprecated and will be removed in a future release. Please +#' use the \code{\link{model_name}} function instead. +#' +#' @export +#' @keywords internal +#' @param sso,new_model_name Use the \code{\link{model_name}} function instead. +#' +rename_model <- function(sso, new_model_name) { + .Deprecated("model_name()") + model_name(sso, new_model_name) +} +# nocov end diff --git a/R/sso_info.R b/R/sso_info.R deleted file mode 100644 index 68063a46..00000000 --- a/R/sso_info.R +++ /dev/null @@ -1,45 +0,0 @@ -# This file is part of shinystan -# Copyright (C) 2015 Jonah Gabry -# -# 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 . - -#' Print summary of shinystan object -#' -#' Prints basic summary info including number of parameters, chains, iterations, -#' warmup iterations, etc. -#' -#' @export -#' @param sso A \code{shinystan} object. -#' - -sso_info <- function(sso) { - sso_check(sso) - sso_name <- deparse(substitute(sso)) - has_notes <- - sso@user_model_info != "Use this space to store notes about your model" - has_code <- - sso@model_code != "Use this space to store your model code" - - cat( - sso_name, "---------------------", - paste("Model name:", sso@model_name), - paste("Parameters:", length(sso@param_names)), - paste("Parameter groups:", length(names(sso@param_dims))), - paste("Chains:", sso@nChains), - paste("Iterations:", sso@nIter), - paste("Warmup:", sso@nWarmup), - paste("Has model code:", has_code), - paste("Has user notes:", has_notes), - sep = "\n" - ) -} \ No newline at end of file diff --git a/R/stan2shinystan.R b/R/stan2shinystan.R deleted file mode 100644 index 8f3e58d2..00000000 --- a/R/stan2shinystan.R +++ /dev/null @@ -1,90 +0,0 @@ -# This file is part of shinystan -# Copyright (C) 2015 Jonah Gabry -# -# 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 . - - -.rename_scalar <- function(sso, oldname = "lp__", newname = "log-posterior") { - p <- which(sso@param_names == oldname) - if (identical(integer(0), p)) - return(sso) - sso@param_names[p] <- - dimnames(sso@samps_all)$parameters[p] <- - names(sso@param_dims)[which(names(sso@param_dims) == oldname)] <- newname - sso -} - -# convert stanfit object to shinystan object -stan2shinystan <- function(stanfit, model_name, notes) { - # notes: text to add to user_model_info slot - rstan_check() - if (!is.stanfit(stanfit)) { - name <- deparse(substitute(stanfit)) - stop(paste(name, "is not a stanfit object.")) - } - - stan_args <- stanfit@stan_args[[1L]] - stan_method <- stan_args$method - vb <- stan_method == "variational" - from_cmdstan_csv <- ("engine" %in% names(stan_args)) - stan_algorithm <- if (from_cmdstan_csv) - toupper(stan_args$engine) else stan_args$algorithm - warmup <- if (from_cmdstan_csv) stanfit@sim$warmup2[1L] else stanfit@sim$warmup - if (!is.null(stan_args[["save_warmup"]])) { - if (!stan_args[["save_warmup"]]) warmup <- 0 - } - nWarmup <- if (from_cmdstan_csv) warmup else floor(warmup / stanfit@sim$thin) - - cntrl <- stanfit@stan_args[[1L]]$control - if (is.null(cntrl)) - max_td <- 11 - else { - max_td <- cntrl$max_treedepth - if (is.null(max_td)) - max_td <- 11 - } - - samps_all <- rstan::extract(stanfit, permuted = FALSE, inc_warmup = TRUE) - param_names <- dimnames(samps_all)[[3L]] # stanfit@sim$fnames_oi - param_dims <- stanfit@sim$dims_oi - - if (!vb && !(stan_algorithm %in% c("NUTS", "HMC"))) { - warning("Most features are only available for models using - algorithm NUTS or algorithm HMC.") - } - mname <- if (!missing(model_name)) model_name else stanfit@model_name - mcode <- rstan::get_stancode(stanfit) - - sampler_params <- if (vb) list(NA) else suppressWarnings(rstan::get_sampler_params(stanfit)) - stan_summary <- rstan::summary(stanfit)$summary - if (vb) stan_summary <- cbind(stan_summary, Rhat = NA, n_eff = NA, se_mean = NA) - - slots <- list() - slots$Class <- "shinystan" - slots$model_name <- mname - slots$param_names <- param_names - slots$param_dims <- param_dims - slots$samps_all <- samps_all - slots$summary <- stan_summary - slots$sampler_params <- sampler_params - slots$nChains <- ncol(stanfit) - slots$nIter <- nrow(samps_all) - slots$nWarmup <- nWarmup - if (!missing(notes)) slots$user_model_info <- notes - if (length(mcode) > 0) slots$model_code <- mcode - slots$misc <- list(max_td = max_td, stan_method = stan_method, - stan_algorithm = stan_algorithm) - sso <- do.call("new", slots) - .rename_scalar(sso) -} - diff --git a/R/stanreg2shinystan.R b/R/stanreg2shinystan.R deleted file mode 100644 index de1ac5c5..00000000 --- a/R/stanreg2shinystan.R +++ /dev/null @@ -1,46 +0,0 @@ -# This file is part of shinystan -# Copyright (C) 2015 Jonah Gabry -# -# 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 . - -#' @importFrom stats model.frame model.response -#' -stanreg2shinystan <- function(X, ppd = TRUE, ...) { - stopifnot(is.stanreg(X)) - sso <- stan2shinystan(X$stanfit, ...) - param_names <- sso@param_names - param_dims <- list() - param_dims[1:length(param_names)] <- NA - names(param_dims) <- param_names - for(i in 1:length(param_names)) { - param_dims[[i]] <- numeric(0) - } - sso@param_dims <- param_dims - sso@misc$stanreg <- TRUE - if (ppd) { - if (!exists("pp_check", mode = "function")) - stop("Please load or install the 'rstanarm' package.", call. = FALSE) - pp_check_plots <- list() - SEED <- 0110 - pp_check_plots[["pp_check_hist"]] <- do.call("pp_check", list(object = X, check = "dist", nreps = 8, overlay = FALSE, seed = SEED)) - pp_check_plots[["pp_check_dens"]] <- do.call("pp_check", list(object = X, check = "dist", nreps = 8, overlay = TRUE, seed = SEED)) - pp_check_plots[["pp_check_resid"]] <- do.call("pp_check", list(object = X, check = "resid", nreps = 8, seed = SEED)) - pp_check_plots[["pp_check_scatter"]] <- do.call("pp_check", list(object = X, check = "scatter", nreps = NULL, seed = SEED)) - pp_check_plots[["pp_check_stat_mean"]] <- do.call("pp_check", list(object = X, check = "test", test = "mean", seed = SEED)) - pp_check_plots[["pp_check_stat_sd"]] <- do.call("pp_check", list(object = X, check = "test", test = "sd", seed = SEED)) - pp_check_plots[["pp_check_stat_min"]] <- do.call("pp_check", list(object = X, check = "test", test = "min", seed = SEED)) - pp_check_plots[["pp_check_stat_max"]] <- do.call("pp_check", list(object = X, check = "test", test = "max", seed = SEED)) - sso@misc$pp_check_plots <- pp_check_plots - } - sso -} diff --git a/R/update_sso.R b/R/update_sso.R index 984890a1..c9777427 100644 --- a/R/update_sso.R +++ b/R/update_sso.R @@ -1,6 +1,3 @@ -# This file is part of shinystan -# Copyright (C) 2015 Jonah Gabry -# # 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 @@ -13,37 +10,68 @@ # You should have received a copy of the GNU General Public License along with # this program; if not, see . -#' Update an object created by an earlier version of shinystan + +#' Update an object created by the previous version of shinystan #' -#' Before you can use an old shinystan object (sso) with the new version of -#' shinystan you might need to run \code{update_sso}. The updated sso -#' will then have all the slots that will be accessed by the ShinyStan app. +#' If you encounter any errors when using a shinystan object (\code{sso}) +#' created by a previous version of \pkg{shinystan}, you might need to run +#' \code{update_sso}. If \code{update_sso} does not resolve the problem and +#' you still have the object (e.g. stanfit, stanreg, mcmc.list) from which +#' \code{sso} was originally created, you can create a new shinystan object +#' using \code{\link{as.shinystan}}. #' #' @export -#' @param old_sso An old shinystan object to update. -#' @return sso, updated. -#' +#' @template args-sso +#' @return If \code{sso} is already compatible with your version of +#' \pkg{shinystan} then \code{sso} itself is returned and a message is printed +#' indicating that \code{sso} is already up-to-date. Otherwise an updated +#' version of \code{sso} is returned unless an error is encountered. +#' +#' @template seealso-as.shinystan +#' #' @examples #' \dontrun{ -#' sso_new <- update_sso(sso_old) -#' } +#' sso_new <- update_sso(sso) +#' } #' -update_sso <- function(old_sso) { - stopifnot(is.shinystan(old_sso)) - sso_name <- deparse(substitute(old_sso)) - new_sso <- new("shinystan") - snms <- slotNames("shinystan") - m <- which(snms == "misc") - for (nm in snms[-m]) { - slot(new_sso, nm) <- slot(old_sso, nm) - } - if (.hasSlot(old_sso, "stan_algorithm")) { - new_sso@misc$stan_algorithm <- slot(old_sso, "stan_algorithm") +update_sso <- function(sso) { + stopifnot(is.shinystan(sso)) + sso_ver <- sso_version(sso) + shinystan_ver <- utils::packageVersion("shinystan") + if (sso_ver == shinystan_ver) { + message(deparse(substitute(sso)), " already up-to-date.") + return(sso) + } else if (sso_ver > shinystan_ver) { + stop( + deparse(substitute(sso)), + " was created using a more recent version ", + "of shinystan than the one you are currently using. ", + "Please update your version of the shinystan package." + ) } - if (new_sso@misc$stan_algorithm == "NUTS") { - new_sso@misc$max_td <- 11 - message("Note: max_treedepth cannot be recovered from ", sso_name, - " so using default RStan value.") + + slot(sso, "sampler_params") <- + .rename_sampler_param(slot(sso, "sampler_params"), + oldname = "n_divergent__", + newname = "divergent__") + sso_new <- shinystan() + for (sn in slotNames(sso_new)) { + if (.hasSlot(sso, sn)) { + slot(sso_new, sn) <- slot(sso, sn) + } else { + new_slots <- c("posterior_sample", "n_chain", "n_iter", "n_warmup") + old_slots <- c("samps_all", "nChains", "nIter", "nWarmup") + j <- which(new_slots == sn) + if (!length(j)) + stop("Bug found. Slot ", sn, " can't be updated.") + if (.hasSlot(sso, old_slots[j])) { + slot(sso_new, sn) <- slot(sso, old_slots[j]) + } else { + stop("slot ", sn, " not found in ", deparse(substitute(sso))) + } + } } - new_sso + sso_new@misc[["sso_version"]] <- utils::packageVersion("shinystan") + message("shinystan object updated.") + sso_new } diff --git a/R/zzz.R b/R/zzz.R index 4b625fc9..5251cf57 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -1,6 +1,3 @@ -# This file is part of shinystan -# Copyright (C) 2015 Jonah Gabry -# # 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 @@ -19,7 +16,7 @@ ver <- utils::packageVersion("shinystan") msg <- paste0("\nThis is shinystan version ", ver,"\n") packageStartupMessage(msg) -} +} .onLoad <- function(libname, pkgname) { op <- options() diff --git a/README.md b/README.md index 0fe76fa1..7227490c 100644 --- a/README.md +++ b/README.md @@ -5,69 +5,81 @@ # ShinyStan [![Travis-CI Build Status](https://travis-ci.org/stan-dev/shinystan.svg?branch=master)](https://travis-ci.org/stan-dev/shinystan) +[![Codecov](http://codecov.io/gh/stan-dev/shinystan/branch/master/graph/badge.svg)](https://codecov.io/gh/stan-dev/shinystan) [![CRAN_Status_Badge](http://www.r-pkg.org/badges/version/shinystan?color=blue)](http://cran.r-project.org/web/packages/shinystan) +[![RStudio CRAN Mirror Downloads](http://cranlogs.r-pkg.org/badges/grand-total/shinystan?color=blue)](http://cran.rstudio.com/package=shinystan) -ShinyStan provides immediate, informative, customizable visual and -numerical summaries of model parameters and convergence diagnostics for -MCMC simulations. The ShinyStan graphical user interface is available -via the **shinystan** R package. [Try the online demo.](http://gelman-group-win.stat.columbia.edu:3500) +ShinyStan provides immediate, informative, customizable visual and +numerical summaries of model parameters and convergence diagnostics for +MCMC simulations. The ShinyStan interface is coded primarily in R using +the [Shiny](http://shiny.rstudio.com) web application framework and is +available via the **shinystan** R package. + +#### Installing the shinystan R package -### Installing the shinystan R package * Install from CRAN: ```{r} install.packages("shinystan") ``` - + If this fails, try adding the arguments `type='source'` and/or `repos='http://cran.rstudio.com'`. - + * Install from GitHub (requires [devtools](https://github.com/hadley/devtools) package): ```{r} -if (!require("devtools")) install.packages("devtools") +if (!require("devtools")) + install.packages("devtools") devtools::install_github("stan-dev/shinystan", build_vignettes = TRUE) ``` - -To take advantage of all the features in the **shinystan** package, it is also -recommended to install the [rsconnect](https://github.com/rstudio/rsconnect) -package. You can do this by running -```{r} -devtools::install_github("rstudio/rsconnect") + +#### Demo + +After installing run + +```r +library("shinystan") +launch_shinystan_demo() ``` -### About ShinyStan +#### About ShinyStan -Applied Bayesian data analysis is primarily implemented through the MCMC -algorithms offered by various software packages. When analyzing a posterior sample -obtained by one of these algorithms the first step is to check for signs that -the chains have converged to the target distribution and and also for signs that -the algorithm might require tuning or might be ill-suited for the given model. -There may also be theoretical problems or practical inefficiencies with the -specification of the model. +Applied Bayesian data analysis is primarily implemented through the MCMC +algorithms offered by various software packages. When analyzing a posterior sample +obtained by one of these algorithms the first step is to check for signs that +the chains have converged to the target distribution and and also for signs that +the algorithm might require tuning or might be ill-suited for the given model. +There may also be theoretical problems or practical inefficiencies with the +specification of the model. -ShinyStan provides interactive plots and tables helpful for analyzing a +ShinyStan provides interactive plots and tables helpful for analyzing a posterior sample, with particular attention to identifying potential problems -with the performance of the MCMC algorithm or the specification of the model. -ShinyStan is powered by RStudio's Shiny web application framework and works with -the output of MCMC programs written in any programming language (and has extended -functionality for models fit using [RStan](http://mc-stan.org/interfaces/rstan.html) -and the No-U-Turn sampler). +with the performance of the MCMC algorithm or the specification of the model. +ShinyStan is powered by RStudio's Shiny web application framework and works with +the output of MCMC programs written in any programming language (and has extended +functionality for models fit using [RStan](http://mc-stan.org/interfaces/rstan.html) +and the No-U-Turn sampler). -### Saving and deploying (sharing) +#### Saving and deploying (sharing) -The **shinystan** package allows you to store the basic components of an entire -project (code, posterior samples, graphs, tables, notes) in a single object. -Users can save many of the plots as ggplot2 objects for further customization +The **shinystan** package allows you to store the basic components of an entire +project (code, posterior samples, graphs, tables, notes) in a single object. +Users can save many of the plots as ggplot2 objects for further customization and easy integration in reports or post-processing for publication. -**shinystan** also provides the `deploy_shinystan` function, -which lets you easily deploy your own ShinyStan apps online using RStudio's -[ShinyApps](https://www.shinyapps.io) service for any of +**shinystan** also provides the `deploy_shinystan` function, +which lets you easily deploy your own ShinyStan apps online using RStudio's +[ShinyApps](https://www.shinyapps.io) service for any of your models. Each of your apps (each of your models) will have a unique url and is compatible with Safari, Firefox, Chrome, and most other browsers. -### Licensing +#### Get help or submit bug report + +* [Stan Users Google group](https://groups.google.com/forum/#!forum/stan-users) +* [ShinyStan issue tracker](https://github.com/stan-dev/shinystan/issues) + +#### Licensing -The **shinystan** R package and ShinyStan interface are open source licensed under +The **shinystan** R package and ShinyStan interface are open source licensed under the GNU Public License, version 3 (GPLv3). diff --git a/data/eight_schools.rda b/data/eight_schools.rda index 8900343f..3ae0580f 100644 Binary files a/data/eight_schools.rda and b/data/eight_schools.rda differ diff --git a/inst/ShinyStan/css/ShinyStan.css b/inst/ShinyStan/css/ShinyStan.css index 3818710c..3888c3c7 100644 --- a/inst/ShinyStan/css/ShinyStan.css +++ b/inst/ShinyStan/css/ShinyStan.css @@ -742,9 +742,13 @@ http://tympanus.net/codrops/licensing/ color: #222222; font-weight: bolder; } +#params_to_plot_regex_label { + padding-left: 5px; + font-size: 85%; +} #params_to_plot_regex { - font-size: 80%; - height: 30px; + font-size: 85%; + height: 40px; margin: 3px; } #invalid_regex { diff --git a/inst/ShinyStan/ggplot_fns_old.rda b/inst/ShinyStan/ggplot_fns_old.rda deleted file mode 100644 index b1daea91..00000000 Binary files a/inst/ShinyStan/ggplot_fns_old.rda and /dev/null differ diff --git a/inst/ShinyStan/global.R b/inst/ShinyStan/global.R index 497bd2b3..5bee9a28 100644 --- a/inst/ShinyStan/global.R +++ b/inst/ShinyStan/global.R @@ -1,17 +1,2 @@ -# This file is part of shinystan -# Copyright (C) Jonah Gabry -# -# 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 . - -# Load shiny +# Load shiny package library(shiny) diff --git a/inst/ShinyStan/global_utils.R b/inst/ShinyStan/global_utils.R index 45acfd3e..22344315 100644 --- a/inst/ShinyStan/global_utils.R +++ b/inst/ShinyStan/global_utils.R @@ -1,122 +1,35 @@ # give ShinyStan app access to ggplot functions -ggplot_fns_file <- if (packageVersion("ggplot2") < "2.0.0") - "ggplot_fns_old.rda" else "ggplot_fns.rda" - -load(ggplot_fns_file) +load("ggplot_fns.rda") lapply(ggplot_fns, function(f) { - try(assign(f, getFromNamespace(f, "ggplot2"), envir = parent.frame(2)), - silent = TRUE) + try(assign(f, getFromNamespace(f, "ggplot2"), envir = parent.frame(2)), silent = TRUE) }) +# load helper_functions helpers <- file.path("helper_functions", list.files("helper_functions", full.names = FALSE)) -for (h in helpers) source(h, local = TRUE) -source(file.path("server_files","utilities","ppcheck_names_descriptions.R"), local = TRUE) +for (h in helpers) + source(h, local = TRUE) # avoid conflict with inline::code if rstan is loaded code <- shiny::code -save_and_close <- 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 <- 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.") - ) -} -toc_entry <- function(name, icon_name, ...) { - actionLink(inputId = paste0("toc_", tolower(name)), label = name, - if (!missing(icon_name)) icon = icon(name = icon_name, ...)) -} -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"))) -} -strongMed <- function(...) { - strong(style = "font-size: 14px; margin-bottom: 5px;", ...) -} -strongBig <- function(...) { - strong(style = "font-size: 18px; margin-bottom: 5px;", ...) -} - -strong_bl <- function(...) { - strong(style = "color: #006DCC;", ...) -} - -algorithm_nuts <- h5(style = "color: #337ab7;", "algorithm = NUTS") -algorithm_hmc <- h5(style = "color: #337ab7;", "algorithm = HMC") - -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") -} - -condPanel_dens_together <- function(...) { - conditionalPanel(condition = "input.dens_chain_split == 'Together'", ...) -} -condPanel_dens_prior <- function(dist, ...) { - cond <- paste0("input.dens_prior ==","'", dist,"'") - conditionalPanel(cond, ...) -} - -# function to suppress unnecessary warnings and messages generated by ggplot -suppress_and_print <- function(x) { - suppressMessages(suppressWarnings(print(x))) -} # make_param_list ------------------------------------------------------ # generate list of parameter names (formatted for shiny::selectInput) .make_param_list <- function(object) { - param_groups <- names(object@param_dims) + param_names <- slot(object, "param_names") + param_dims <- slot(object, "param_dims") + param_groups <- names(param_dims) choices <- list() - ll <- length(object@param_dims) - choices[1:ll] <- "" + ll <- length(param_dims) + choices[seq_len(ll)] <- "" names(choices) <- param_groups - for(i in 1:ll) { - if (length(object@param_dims[[i]]) == 0) { + for(i in seq_len(ll)) { + if (length(param_dims[[i]]) == 0) { choices[[i]] <- list(param_groups[i]) } else { temp <- paste0(param_groups[i],"\\[") - choices[[i]] <- object@param_names[grep(temp, object@param_names)] + choices[[i]] <- param_names[grep(temp, param_names)] } } choices @@ -126,31 +39,34 @@ suppress_and_print <- function(x) { # generate list of parameter names and include parameter groups (formatted for # shiny::selectInput) .make_param_list_with_groups <- function(object, sort_j = FALSE) { + param_names <- slot(object, "param_names") + param_dims <- slot(object, "param_dims") + param_groups <- names(param_dims) + ll <- length(param_dims) + LL <- sapply(seq_len(ll), function(i) length(param_dims[[i]])) choices <- list() - param_groups <- names(object@param_dims) - ll <- length(object@param_dims) - LL <- sapply(1:ll, function(i) length(object@param_dims[[i]])) - choices[1:ll] <- "" + choices[seq_len(ll)] <- "" names(choices) <- param_groups - for(i in 1:ll) { + 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 <- object@param_names[grep(temp, object@param_names)] - + ch <- param_names[grep(temp, param_names)] + # toggle row/column major 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]" - if (sort_j == TRUE & LL[i] > 1) ch <- gtools::mixedsort(ch) - + if (sort_j == TRUE & LL[i] > 1) + 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 } @@ -158,20 +74,30 @@ suppress_and_print <- function(x) { # update with regex .test_valid_regex <- function(pattern) { trygrep <- try(grep(pattern, ""), silent = TRUE) - if (inherits(trygrep, "try-error")) FALSE else TRUE + if (inherits(trygrep, "try-error")) + FALSE + else + TRUE } .update_params_with_regex <- function(params, all_param_names, regex_pattern) { sel <- which(all_param_names %in% params) - to_search <- if (length(sel)) all_param_names[-sel] else all_param_names - if (!length(regex_pattern)) return(params) + to_search <- if (length(sel)) + all_param_names[-sel] else all_param_names + if (!length(regex_pattern)) + return(params) + to_add <- grep(regex_pattern, to_search, value = TRUE) - if (!length(to_add)) params else c(params, to_add) + if (!length(to_add)) + params + else + c(params, to_add) } # update with groups .update_params_with_groups <- function(params, all_param_names) { as_group <- grep("_as_shinystan_group", params) - if (!length(as_group)) return(params) + if (!length(as_group)) + return(params) make_group <- function(group_name) { all_param_names[grep(paste0("^",group_name,"\\["), all_param_names)] } @@ -193,60 +119,22 @@ color_vector_chain <- function(n) { hcl(h=hues, l=80, c=50)[1:n] } -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_choices <- - c("abs", "atanh", cauchit = "pcauchy", "cloglog", - "exp", "expm1", "identity", "inverse", inv_logit = "plogis", - "log", "log", "log10", "log2", "log1p", logit = "qlogis", - probit = "pnorm", "square", "sqrt") +transformation_choices <- + c( + "abs", "atanh", + cauchit = "pcauchy", "cloglog", + "exp", "expm1", + "identity", "inverse", inv_logit = "plogis", + "log", "log10", "log2", "log1p", logit = "qlogis", + probit = "pnorm", + "square", "sqrt" + ) inverse <- function(x) 1/x cloglog <- function(x) log(-log1p(-x)) square <- function(x) x^2 -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")) - ) -} - - - # extra distributions for density comparisons ----------------------------- # t distribution with location and scale .dt_loc_scale <- function(x, df, location, scale) { @@ -259,41 +147,11 @@ transform_helpText <- function(var = "x") { } -# 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 or the sliders to select areas in the", - "traceplot to zoom into. The other plots on the screen", - "will update accordingly. Double-click to reset.") - -# stan manual -stan_manual <- function() { - helpText(style = "font-size: 12px;", - "Glossary entries are compiled (with minor edits) from various excepts 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)"),")" - ) -} - -# to use in ui.R -.model_name <- slot(object, "model_name") -.param_names <- slot(object, "param_names") -.param_list <- .make_param_list(object) -.param_list_with_groups <- .make_param_list_with_groups(object) -.nChains <- slot(object, "nChains") -.nIter <- slot(object, "nIter") -.nWarmup <- slot(object, "nWarmup") -.model_code <- slot(object, "model_code") -.notes <- slot(object, "user_model_info") -.from_rstanarm <- if (is.null(object@misc$stanreg)) FALSE else object@misc$stanreg +# bold/strong text generators --------------------------------------------- +# used both in ui files and server files that call renderUI +strongMed <- function(...) + strong(style = "font-size: 14px; margin-bottom: 5px;", ...) +strongBig <- function(...) + strong(style = "font-size: 18px; margin-bottom: 5px;", ...) +strong_bl <- function(...) + strong(style = "color: #006DCC;", ...) diff --git a/inst/ShinyStan/helper_functions/gg_theme_elements.R b/inst/ShinyStan/helper_functions/gg_theme_elements.R index 2b28288b..dbf7795d 100644 --- a/inst/ShinyStan/helper_functions/gg_theme_elements.R +++ b/inst/ShinyStan/helper_functions/gg_theme_elements.R @@ -1,32 +1,75 @@ -# ggplot theme elements to be used as needed ----------------------------- -blue_color <- "#006dcc" +# ggplot theme elements to be used as needed + + +# transparent background -------------------------------------------------- +transparent <- theme( + panel.background = element_blank(), + plot.background = element_blank() + ) -transparent <- theme(panel.background = element_blank(), - plot.background = element_blank()) + +# axes and titles --------------------------------------------------------- axis_line_color <- "gray20" -axis_color <- theme(axis.line = element_line(color = axis_line_color)) -axis_labs <- theme(axis.title = element_text(face = "bold", size = 13)) -title_txt <- theme(plot.title = element_text(face = "bold", size = 14)) -fat_axis <- theme(axis.line.x = element_line(size = 3, color = axis_line_color), - axis.line.y = element_line(size = 0.5, color = axis_line_color)) -h_lines <- theme(panel.grid.major = - element_line(size = 0.10, linetype = 3, color = "turquoise4"), - panel.grid.major.x = element_blank()) -v_lines <- theme(panel.grid.major = - element_line(size = 0.25, linetype = 3, color = "turquoise4"), - panel.grid.major.y = element_blank()) -no_lgnd <- theme(legend.position = "none") -lgnd_bot <- theme(legend.position = "bottom", legend.background = element_blank()) -lgnd_top <- theme(legend.position = "top", legend.background = element_blank()) -lgnd_left <- theme(legend.position = "left", legend.background = element_blank()) -lgnd_right <- theme(legend.position = "right", legend.background = element_blank()) -no_yaxs <- theme(axis.line.y = element_blank(), axis.ticks.y = element_blank(), - axis.text.y = element_blank()) -strip_txt <- theme(strip.text = - element_text(size = 12, face = "bold", color = "white"), - strip.background = - element_rect(color = axis_line_color, fill = axis_line_color)) +axis_color <- theme( + axis.line = element_line(color = axis_line_color) + ) +axis_labs <- theme( + axis.title = element_text(face = "bold", size = 13) + ) +title_txt <- theme( + plot.title = element_text(face = "bold", size = 14) + ) +fat_axis <- theme( + axis.line.x = element_line(size = 3, color = axis_line_color), + axis.line.y = element_line(size = 0.5, color = axis_line_color) + ) +no_yaxs <- theme( + axis.line.y = element_blank(), + axis.ticks.y = element_blank(), + axis.text.y = element_blank() + ) + +# facet strips ------------------------------------------------------------ +strip_txt <- theme( + strip.text = element_text(size = 12, face = "bold", color = "white"), + strip.background = element_rect(color = axis_line_color, fill = axis_line_color) + ) + +# horizontal and vertical lines ------------------------------------------- +h_lines <- theme( + panel.grid.major = element_line(size = 0.10, linetype = 3, color = "turquoise4"), + panel.grid.major.x = element_blank() + ) +v_lines <- theme( + panel.grid.major = element_line(size = 0.25, linetype = 3, color = "turquoise4"), + panel.grid.major.y = element_blank() + ) + + +# legends ----------------------------------------------------------------- +no_lgnd <- theme( + legend.position = "none" + ) +lgnd_bot <- theme( + legend.position = "bottom", + legend.background = element_blank() + ) +lgnd_top <- theme( + legend.position = "top", + legend.background = element_blank() + ) +lgnd_left <- theme( + legend.position = "left", + legend.background = element_blank() + ) +lgnd_right <- theme( + legend.position = "right", + legend.background = element_blank() + ) + + +# colors and shapes ------------------------------------------------------- base_fill <- "#66a7e0" overlay_fill <- "#006dcc" vline_base_clr <- "#006dcc" @@ -36,3 +79,5 @@ hit_max_td_fill <- "#eeba30" divergent_clr <- "black" hit_max_td_clr <- "black" div_and_hit_shape <- 21 + +blue_color <- "#006dcc" diff --git a/inst/ShinyStan/helper_functions/hmc_diagnostics_helpers.R b/inst/ShinyStan/helper_functions/hmc_diagnostics_helpers.R index 27949af0..1f43422c 100644 --- a/inst/ShinyStan/helper_functions/hmc_diagnostics_helpers.R +++ b/inst/ShinyStan/helper_functions/hmc_diagnostics_helpers.R @@ -1,18 +1,3 @@ -# This file is part of shinystan -# Copyright (C) 2015 Jonah Gabry -# -# 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 . - thm <- theme_classic() %+replace% (no_lgnd + fat_axis + axis_labs + transparent) thm_no_yaxs <- thm + no_yaxs @@ -22,7 +7,8 @@ thm_no_yaxs <- thm + no_yaxs }) sp_mat <- do.call("cbind", sp_pw) colnames(sp_mat) <- paste0("chain:", 1:ncol(sp_mat)) - sp_mat <- cbind(iterations = (warmup_val+1):(warmup_val + nrow(sp_mat)), sp_mat) + sp_mat <- cbind(iterations = seq(from = warmup_val + 1, to = warmup_val + nrow(sp_mat)), + sp_mat) as.data.frame(sp_mat) } @@ -30,19 +16,28 @@ thm_no_yaxs <- thm + no_yaxs .sampler_param_vs_param <- function(p, sp, divergent = NULL, hit_max_td = NULL, p_lab, sp_lab, chain = 0, violin = FALSE, smoother = FALSE) { - xy_labs <- labs(y = if (missing(p_lab)) NULL else p_lab, - x = if (missing(sp_lab)) NULL else sp_lab) + xy_labs <- labs( + y = if (missing(p_lab)) NULL else p_lab, + x = if (missing(sp_lab)) NULL else sp_lab + ) df <- data.frame(sp = do.call("c", sp), p = c(p)) - if (violin) df$sp <- as.factor(round(df$sp, 4)) - if (!is.null(divergent)) df$divergent <- do.call("c", divergent) - if (!is.null(hit_max_td)) df$hit_max_td <- do.call("c", hit_max_td) + if (violin) + df$sp <- as.factor(round(df$sp, 4)) + if (!is.null(divergent)) + df$divergent <- do.call("c", divergent) + if (!is.null(hit_max_td)) + df$hit_max_td <- do.call("c", hit_max_td) + + base <- ggplot(df, aes(sp,p)) + + xy_labs + + thm - base <- ggplot(df, aes(sp,p)) + xy_labs + thm if (chain == 0) { if (violin) graph <- base + geom_violin(color = vline_base_clr, fill = base_fill) else { graph <- base + geom_point(alpha = 1/3, color = pt_outline_clr, fill = base_fill, shape = 19) - if (smoother) graph <- graph + stat_smooth(color = overlay_fill, se = FALSE) + if (smoother) + graph <- graph + stat_smooth(color = overlay_fill, se = FALSE) if (!is.null(divergent)) graph <- graph + geom_point(data = subset(df, divergent == 1), aes(sp,p), color = divergent_clr, fill = divergent_fill, @@ -55,8 +50,10 @@ thm_no_yaxs <- thm + no_yaxs return(graph) } chain_data <- data.frame(sp = sp[, chain], p = p[, chain]) - if (!is.null(divergent)) chain_data$div <- divergent[, chain] - if (!is.null(hit_max_td)) chain_data$hit <- hit_max_td[, chain] + if (!is.null(divergent)) + chain_data$div <- divergent[, chain] + if (!is.null(hit_max_td)) + chain_data$hit <- hit_max_td[, chain] chain_clr <- color_vector_chain(ncol(sp))[chain] chain_fill <- chain_clr if (violin) { @@ -68,12 +65,11 @@ thm_no_yaxs <- thm + no_yaxs return(graph) } graph <- base + geom_point(alpha = 1/3, color = pt_outline_clr, fill = base_fill, shape = 19) - if (smoother) graph <- graph + - stat_smooth(color = overlay_fill, se = FALSE) - graph <- graph + - geom_point(data = chain_data, aes(sp,p), color = chain_fill, alpha = 0.5) - if (smoother) graph <- graph + - stat_smooth(data = chain_data, aes(sp,p), color = chain_fill, se = FALSE) + if (smoother) + graph <- graph + stat_smooth(color = overlay_fill, se = FALSE) + graph <- graph + geom_point(data = chain_data, aes(sp,p), color = chain_fill, alpha = 0.5) + if (smoother) + graph <- graph + stat_smooth(data = chain_data, aes(sp,p), color = chain_fill, se = FALSE) if (!is.null(divergent)) graph <- graph + geom_point(data = subset(chain_data, div == 1), aes(sp,p), color = divergent_clr, fill = divergent_fill, @@ -87,14 +83,18 @@ thm_no_yaxs <- thm + no_yaxs .sampler_param_vs_sampler_param_violin <- function(df_x, df_y, lab_x, lab_y, chain = 0) { - xy_labs <- labs(y = lab_y, x = lab_x) df <- data.frame(x = do.call("c", df_x), y = do.call("c", df_y)) df$x <- as.factor(df$x) - base <- ggplot(df, aes(x,y)) + xy_labs + thm + base <- ggplot(df, aes(x,y)) + + xy_labs + + thm + graph <- base + geom_violin(color = vline_base_clr, fill = base_fill) - if (chain == 0) return(graph) + if (chain == 0) + return(graph) + chain_clr <- color_vector_chain(ncol(df_x))[chain] chain_fill <- chain_clr chain_data <- data.frame(x = as.factor(df_x[, chain]), y = df_y[, chain]) @@ -109,7 +109,9 @@ thm_no_yaxs <- thm + no_yaxs geom_histogram(aes_string(y="..density.."), binwidth = diff(range(mdf$value))/30, fill = base_fill, color = vline_base_clr, size = 0.2) + - labs(x = if (missing(lab)) NULL else lab, y = "") + thm + labs(x = if (missing(lab)) NULL else lab, y = "") + + thm + if (chain == 0) { graph <- base + geom_vline(xintercept = mean(mdf$value), color = vline_base_clr, size = .8) + @@ -131,21 +133,25 @@ thm_no_yaxs <- thm + no_yaxs .treedepth_ndivergent_hist <- function(df_td, df_nd, chain = 0, divergent = c("All", 0, 1)) { plot_title <- theme(plot.title = element_text(size = 11, hjust = 0)) plot_theme <- thm_no_yaxs + plot_title - x_lab <- if (divergent == "All") "Treedepth (All)" else paste0("Treedepth (N Divergent = ", divergent,")") + x_lab <- if (divergent == "All") "Treedepth (All)" else paste0("Treedepth (Divergent = ", divergent,")") plot_labs <- labs(x = x_lab, y = "") mdf_td <- reshape2::melt(df_td, id.vars = "iterations") mdf_nd <- reshape2::melt(df_nd, id.vars = "iterations") mdf <- cbind(mdf_td, div = mdf_nd$value) - plot_data <- if (divergent == "All") mdf else subset(mdf, div == divergent) - if (nrow(plot_data) == 0) return(NULL) + plot_data <- if (divergent == "All") + mdf else subset(mdf, div == divergent) + if (nrow(plot_data) == 0) + return(NULL) graph <- ggplot(plot_data, aes(x = factor(value)), na.rm = TRUE) + geom_bar(aes(y=..count../sum(..count..)), width=1, fill = base_fill, color = vline_base_clr, size = 0.2) + plot_labs + plot_theme - if (chain == 0) return(graph) + if (chain == 0) + return(graph) + chain_clr <- color_vector_chain(ncol(df_td) - 1)[chain] chain_fill <- chain_clr chain_data <- subset(plot_data, variable == paste0("chain:",chain)) @@ -179,8 +185,8 @@ thm_no_yaxs <- thm + no_yaxs } `%>%` <- dygraphs::`%>%` y_axis_label_remove <- if (stack) "white" else NULL - step_plot <- param_name %in% c("Treedepth", "N Divergent") - fill_graph <- param_name == "N Divergent" + step_plot <- param_name %in% c("Treedepth", "Divergent") + fill_graph <- param_name == "Divergent" stroke_width <- if (step_plot) 0.33 else 0.75 clrs <- color_vector(nChains) if (chain != 0) clrs <- clrs[chain] diff --git a/inst/ShinyStan/helper_functions/shinystan_helpers.R b/inst/ShinyStan/helper_functions/shinystan_helpers.R index 2b4b4e77..3de549e5 100644 --- a/inst/ShinyStan/helper_functions/shinystan_helpers.R +++ b/inst/ShinyStan/helper_functions/shinystan_helpers.R @@ -1,18 +1,3 @@ -# This file is part of shinystan -# Copyright (C) 2015 Jonah Gabry -# -# 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 . - # param_trace_multi ------------------------------------------------------ # trace plots for multiple parameters .param_trace_multi <- function(params = NULL, all_param_names, dat, @@ -218,7 +203,7 @@ priors <- data.frame(family = c("Normal", "t", "Cauchy", "Beta", "Exponential", nl <- if (partial) lags else lags + 1 ch <- factor(rep(1:nc, each = nl), labels = paste0("chain:", 1:nc)) ll <- rep(seq(if (partial) 1 else 0, lags), nc) - data.frame(chains = ch, ac = do.call(c, ac_list), lag = ll) + data.frame(chains = ch, ac = do.call("c", args = ac_list), lag = ll) } .ac_plot_data_multi <- function(dat, lags, partial = FALSE) { nc <- length(unique(dat$chains)) @@ -230,7 +215,7 @@ priors <- data.frame(family = c("Normal", "t", "Cauchy", "Beta", "Exponential", ch <- factor(rep(rep(1:nc, each = nl), np), labels = paste0("chain:", 1:nc)) ll <- rep(seq(if (partial) 1 else 0, lags), nc * np) pp <- factor(rep(1:np, each = nc * nl), labels = levels(dat$parameters)) - data.frame(parameters = pp, chains = ch, ac = do.call(c, ac_list), lag = ll) + data.frame(parameters = pp, chains = ch, ac = do.call("c", args = ac_list), lag = ll) } # markov chain autocorrelation plot for single parameters @@ -485,9 +470,9 @@ priors <- data.frame(family = c("Normal", "t", "Cauchy", "Beta", "Exponential", # n_eff_warnings ----------------------------------------------------------- .n_eff_warnings <- function(summary, threshold = 10, - N_total = length(samps_post_warmup[,, 1L])) { + N_total = NULL) { n_eff <- summary[,"n_eff"] - warn_params <- names(which(n_eff/N_total < threshold/100)) + warn_params <- names(which(n_eff / N_total < threshold / 100)) ll <- length(warn_params) if (ll == 0) "None" else paste0(warn_params, collapse = ", ") @@ -515,7 +500,7 @@ priors <- data.frame(family = c("Normal", "t", "Cauchy", "Beta", "Exponential", # dynamic trace plot ------------------------------------------------------ .param_trace_dynamic <- function(param_samps, param_name=NULL, chain, - # warmup_val, warmup_shade = TRUE, + warmup_val, warmup_shade = TRUE, stack = FALSE, grid = FALSE) { dim_samps <- dim(param_samps) @@ -536,9 +521,11 @@ priors <- data.frame(family = c("Normal", "t", "Cauchy", "Beta", "Exponential", } } - # shade_to <- if (warmup_shade) paste0(warmup_val,"-01-01") else "0001-01-01" `%>%` <- dygraphs::`%>%` - y_axis_label_remove <- if (stack) "white" else NULL + shade_to <- if (warmup_shade) + paste0(warmup_val,"-01-01") else "0001-01-01" + y_axis_label_remove <- if (stack) + "white" else NULL clrs <- color_vector(nChains) if (chain != 0) clrs <- clrs[chain] dygraphs::dygraph(param_chains, xlab = "", ylab = "") %>% @@ -555,6 +542,7 @@ priors <- data.frame(family = c("Normal", "t", "Cauchy", "Beta", "Exponential", hideOnMouseOut = TRUE, highlightSeriesOpts = list(strokeWidth = 1.75)) %>% dygraphs::dyRoller(rollPeriod = 1) %>% + dygraphs::dyShading(from = "0001-01-01", to = shade_to, color = "#EFEFEF", axis = "x") %>% dygraphs::dyCSS(css = "css/ShinyStan_dygraphs.css") } @@ -637,7 +625,7 @@ priors <- data.frame(family = c("Normal", "t", "Cauchy", "Beta", "Exponential", y = if (transform_y == "identity") samps_use[,param2] else t_y(samps_use[,param2])) if (!is.null(sp)) { - dat$divergent <- c(sapply(sp, FUN = function(y) y[, "n_divergent__"])) + dat$divergent <- c(sapply(sp, FUN = function(y) y[, "divergent__"])) dat$hit_max_td <- if (is.null(max_td)) 0 else c(sapply(sp, FUN = function(y) as.numeric(y[, "treedepth__"] == max_td))) } else { diff --git a/inst/ShinyStan/helper_functions/summary_stats_helpers.R b/inst/ShinyStan/helper_functions/summary_stats_helpers.R index 2af492aa..b9bedc4a 100644 --- a/inst/ShinyStan/helper_functions/summary_stats_helpers.R +++ b/inst/ShinyStan/helper_functions/summary_stats_helpers.R @@ -1,22 +1,8 @@ -# This file is part of shinystan -# Copyright (C) 2015 Jonah Gabry -# -# 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 . - # param_summary ----------------------------------------------------------- # summary stats for a single parameter .param_summary <- function(param, summary) { - out <- summary[param, c("Rhat", "n_eff", "mean", "sd", "2.5%", "50%", "97.5%")] + stats <- c("Rhat", "n_eff", "mean", "sd", "2.5%", "50%", "97.5%") + out <- summary[param, stats] out["n_eff"] <- round(out["n_eff"]) outmat <- matrix(out, 1, length(out)) colnames(outmat) <- names(out) @@ -29,10 +15,11 @@ # summary stats for all parameters .all_summary <- function(summary, digits = 2, cols) { if (missing(cols)) - cols <- 1:ncol(summary) + cols <- seq_len(ncol(summary)) df <- as.data.frame(summary[, cols]) df <- round(df, digits) - if ("n_eff" %in% cols) df[, "n_eff"] <- round(df[, "n_eff"]) + if ("n_eff" %in% cols) + df[, "n_eff"] <- round(df[, "n_eff"]) df } @@ -40,22 +27,26 @@ # prep for latex table .tex_summary <- function(summary, params, cols) { df <- as.data.frame(summary[, cols]) - if ("n_eff" %in% cols) df[, "n_eff"] <- round(df[, "n_eff"]) - out <- cbind(Parameter = rownames(df), df) - out + if ("n_eff" %in% cols) + df[, "n_eff"] <- round(df[, "n_eff"]) + cbind(Parameter = rownames(df), df) } # sampler_summary --------------------------------------------------------- .sampler_stuff <- function(X, param, report) { sapply_funs <- function(x, fun_name) { - funs <- list(maxf = function(x) max(x[,param]), minf = function(x) min(x[,param]), - meanf = function(x) mean(x[,param]), sdf = function(x) sd(x[,param])) + funs <- list( + maxf = function(x) max(x[, param]), + minf = function(x) min(x[, param]), + meanf = function(x) mean(x[, param]), + sdf = function(x) sd(x[, param]) + ) sapply(x, FUN = funs[[fun_name]]) } out <- if (report == "maximum") sapply_funs(X, "maxf") - else if (report == "minimum") sapply_funs(X, "minf") - else if (report == "sd") sapply_funs(X, "sdf") - else sapply_funs(X, "meanf") + else if (report == "minimum") sapply_funs(X, "minf") + else if (report == "sd") sapply_funs(X, "sdf") + else sapply_funs(X, "meanf") names(out) <- paste0("chain",1:length(out)) out @@ -66,19 +57,16 @@ report = "average", digits = 4){ params <- colnames(sampler_params[[1]]) - out <- sapply(params, FUN = function(p) .sampler_stuff(X = sampler_params, - param = p, - report = report)) + out <- sapply(params, FUN = function(p) + .sampler_stuff(X = sampler_params, param = p, report = report)) if (length(dim(out)) > 1) { # if multiple chains out <- rbind("All chains" = colMeans(out), out) colnames(out) <- gsub("__","",colnames(out)) - out <- formatC(round(out, digits), format='f', digits=digits) - # out <- cbind(Chain = rownames(out), out) + out <- formatC(round(out, digits), format = 'f', digits = digits) } else { # if only 1 chain names(out) <- gsub("__.chain1", "", names(out)) - out <- t(out) - out <- round(out, digits) + out <- round(t(out), digits) } out } diff --git a/inst/ShinyStan/html/accept_stat.html b/inst/ShinyStan/html/accept_stat.html index 38b4e345..5c876af4 100644 --- a/inst/ShinyStan/html/accept_stat.html +++ b/inst/ShinyStan/html/accept_stat.html @@ -13,17 +13,21 @@

accept_stat



More details

+

If the leapfrog integrator were perfect numerically, there would no need to do any more randomization per transition than generating a random momentum vector. Instead, what is done in practice to account for numerical errors during integration is to apply a Metropolis acceptance step. If the proposal is not accepted, the previous parameter value is returned for the next draw and used to initialize the next iteration. +

+

By setting the target acceptance parameter to a value closer to 1 (its value must be strictly less than 1 and its default value is 0.8), adaptation will be forced to use smaller step sizes. This can improve sampling efficiency (effective samples per iteration) at the cost of increased iteration times. Raising the target will also allow some models that would otherwise get stuck to overcome their blockages. +

\ No newline at end of file diff --git a/inst/ShinyStan/html/citation.html b/inst/ShinyStan/html/citation.html index 7b2f0336..4bec59ee 100644 --- a/inst/ShinyStan/html/citation.html +++ b/inst/ShinyStan/html/citation.html @@ -1,7 +1,7 @@
-    @Misc{shinystan-software:2015,
+    @Misc{shinystan-software:2016,
       title = {{shinystan}: {R} Package for Interactive Exploration of {MCMC} samples, 
-                Version 2.1.0},
+                Version 2.2.0},
       author = {Jonah Gabry and Stan Development Team},
       year = {2016},
       abstract = {The shinystan {R} package provides the {S}hiny{S}tan interface 
diff --git a/inst/ShinyStan/html/home_page_links.html b/inst/ShinyStan/html/home_page_links.html
index 9f9a9930..c3041df0 100644
--- a/inst/ShinyStan/html/home_page_links.html
+++ b/inst/ShinyStan/html/home_page_links.html
@@ -1,9 +1,28 @@
 
-            
\ No newline at end of file
+
\ No newline at end of file
diff --git a/inst/ShinyStan/html/mcse.html b/inst/ShinyStan/html/mcse.html
index f4f55453..6876e0be 100644
--- a/inst/ShinyStan/html/mcse.html
+++ b/inst/ShinyStan/html/mcse.html
@@ -24,6 +24,7 @@ 

mcse (se_mean)



More details

+

When estimating a mean based on a sample of \(M\) independent draws, the estimation error is proportional to \(1/M\). If the draws are positively correlated, as they typically are when drawn using MCMC methods, the error @@ -31,6 +32,7 @@

More details

sample size. Thus it is standard practice to also monitor (an estimate of) the effective sample size until it is large enough for the estimation or inference task at hand. +

\ No newline at end of file diff --git a/inst/ShinyStan/html/ndivergent.html b/inst/ShinyStan/html/ndivergent.html index 9815144b..7747387d 100644 --- a/inst/ShinyStan/html/ndivergent.html +++ b/inst/ShinyStan/html/ndivergent.html @@ -1,5 +1,5 @@
-

n_divergent

+

divergent

Quick definition @@ -7,26 +7,48 @@

n_divergent

The number of leapfrog transitions with diverging error. Because NUTS terminates at the first divergence this will be either 0 or 1 for each iteration. -The average value of n_divergent over all iterations is therefore +The average value of divergent over all iterations is therefore the proportion of iterations with diverging error. +

More details

-Stan uses a symplectic integrator to approximate the exact solution of the -Hamiltonian dynamics and when stepsize is too large relative -to the curvature of the log posterior this approximation can diverge and -threaten the validity of the sampler. n_divergent counts the -number of iterations within a given sample that have diverged and any -non-zero value suggests that the samples may be biased in which case -the step size needs to be decreased. Note that, because sampling is -immediately terminated once a divergence is encountered, n_divergent -should be only 0 or 1. -

+

+When numerical issues arise during the evaluation of the parameter +Jacobians or the model log density, an exception is raised in the +underlying code and the current expansion of the Hamiltonian forward +and backward in time is halted. This is marked as a divergent +transition. +

+ +

+The primary cause of divergent transitions in Euclidean HMC (other +than bugs in the model code) is numerical instability in the leapfrog +integrator used to simulate the Hamiltonian evaluation. The +fundamental problem is that a fixed step size is being multiplied by +the gradient at a particular point, to determine the next simulated +point. If the stepsize is too large, this can overshoot into +ill-defined portions of the posterior. +

+ +

-If there are any post-warmup iterations for which n_divergent = 1 -then the results may be biased and should not be used. You should try rerunning -the model with a higher target acceptance probability (which will decrease the -step size) until n_divergent = 0 for all post-warmup iterations. +If there are (post-warmup) divergences then the results may be biased and +should not be used. -

+

+ +

+In some cases, simply lowering the initial step size and increasing +the target acceptance rate will keep the step size small enough that +sampling can proceed. +

+

+The exact cause of each divergent transition is printed as a warning +message in the output console. This can be useful in cases where managing +the step size is insufficient. In such cases, a reparameterization is +often required so that the posterior curvature is more manageable; +see the section about Neal's Funnel in the Stan manual for an example. +

+ diff --git a/inst/ShinyStan/html/neff.html b/inst/ShinyStan/html/neff.html index fd686fa9..ada808ec 100644 --- a/inst/ShinyStan/html/neff.html +++ b/inst/ShinyStan/html/neff.html @@ -23,6 +23,7 @@

n_eff (ESS)



More details

+

Samples in a Markov chain are only drawn with the marginal distribution \(p(\theta | y,x)\) after the chain has converged to its equilibrium distribution. There are several methods to test whether an MCMC method has failed to converge; @@ -31,17 +32,22 @@

More details

diffuse set of initial parameter values, discard the warmup/adaptation samples, then split the remainder of each chain in half and compute the potential scale reduction statistic \(\hat{R}\). -

-If the result is not enough effective -samples, double the number of iterations and start again, including rerunning -warmup and everything. Often a lack of effective samples is a result of not -enough warmup iterations. At most this rerunning strategy will consume about +

+ +

+If the effective sample size is too low to make inferences with the desired +precision, double the number of iterations and start again, including rerunning +warmup and everything. Often, a small effective sample size is the result of too +few warmup iterations. At most, this rerunning strategy will consume about 50% more cycles than guessing the correct number of iterations at the outset. -

+

+ +

The estimation of effective sample size is described in detail in the 'Markov Chain Monte Carlo Sampling' chapter of the Stan Modeling Language User's Guide and Reference Manual. +

\ No newline at end of file diff --git a/inst/ShinyStan/html/nleapfrog.html b/inst/ShinyStan/html/nleapfrog.html index 73257dae..8cc0d27b 100644 --- a/inst/ShinyStan/html/nleapfrog.html +++ b/inst/ShinyStan/html/nleapfrog.html @@ -11,8 +11,10 @@

n_leapfrog



More details

+

If n_leapfrog is too small, the trajectory traced out in each iteration will be too short and sampling will devolve to a random walk. If n_leapfrog is too large, the algorithm will do too much work on each iteration. +

\ No newline at end of file diff --git a/inst/ShinyStan/html/rhat.html b/inst/ShinyStan/html/rhat.html index 4ef2ccbb..e64abe2e 100644 --- a/inst/ShinyStan/html/rhat.html +++ b/inst/ShinyStan/html/rhat.html @@ -27,16 +27,20 @@

Rhat (\(\hat{R}\))



More details

+

Gelman and Rubin’s recommendation is that the independent Markov chains be initialized with diffuse starting values for the parameters and sampled until all values for \(\hat{R}\) are below 1.1. Stan allows users to specify initial values for parameters and it is also able to draw diffuse random initializations itself. -

+

+ +

Details on the computatation of \(\hat{R}\) and some of its limitations can be found in the 'Markov Chain Monte Carlo Sampling' chapter of the Stan Modeling Language User's Guide and Reference Manual. +

\ No newline at end of file diff --git a/inst/ShinyStan/html/stepsize.html b/inst/ShinyStan/html/stepsize.html index 22933570..c45fe908 100644 --- a/inst/ShinyStan/html/stepsize.html +++ b/inst/ShinyStan/html/stepsize.html @@ -9,12 +9,16 @@

step_size



More details

+ +

All implementations of HMC use numerical integrators requiring a step size (equivalently, discretization time interval). -

+

+

If step_size is too large, the leapfrog integrator will be inaccurate and too many proposals will be rejected. If step_size is too small, too many small steps will be taken by the leapfrog integrator leading to long simulation times per interval. Thus the goal is to balance the acceptance rate between these extremes. +

diff --git a/inst/ShinyStan/html/treedepth.html b/inst/ShinyStan/html/treedepth.html index bb06dc68..b51151ea 100644 --- a/inst/ShinyStan/html/treedepth.html +++ b/inst/ShinyStan/html/treedepth.html @@ -10,21 +10,28 @@

treedepth



More details

+

Configuring NUTS involves putting a cap on the depth of the trees that it evaluates during each iteration. This is controlled through a maximum depth parameter. n_leapfrog is then bounded by 2 to the power of the maximum depth minus 1. -

+

+ +

Tree depth is an important diagnostic tool for NUTS. For example, a treedepth = 0 occurs when the first leapfrog step is immediately rejected and the initial state returned, indicating extreme curvature and poorly-chosen stepsize (at least relative to the current position). -

+

+ +

On the other hand, treedepth = max_treedepth equal to the maximum depth indicates that NUTS is taking many leapfrog steps and being terminated prematurely to avoid excessively long execution time. -

+

+ +

Taking very many steps may be a sign of poor adaptation, may be due to targeting a very high acceptance rate, or may simply indicate a difficult posterior from which to sample. @@ -32,5 +39,5 @@

More details

in the rare cases where the model is correctly specified and a large number of steps is necessary, the maximum depth should be increased to ensure that that the NUTS tree can grow as large as necessary. -

+

diff --git a/inst/ShinyStan/server.R b/inst/ShinyStan/server.R index c4c7afe9..66bf0409 100644 --- a/inst/ShinyStan/server.R +++ b/inst/ShinyStan/server.R @@ -1,6 +1,3 @@ -# This file is part of shinystan -# Copyright (C) 2015 Jonah Gabry -# # 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 @@ -13,36 +10,33 @@ # You should have received a copy of the GNU General Public License along with # this program; if not, see . + # options(shiny.trace=TRUE) -object <- get(".shinystan_temp_object", envir = shinystan:::.sso_env) +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(file.path("server_files","utilities","extract_sso.R"), local = TRUE) +source("server_utils.R", local = TRUE) +source(path_to_extract_sso, local = TRUE) # BEGIN server ------------------------------------------------------ # ___________________________________________________________________ function(input, output, session) { - observe({ - # Stop the app when "Save & Close" button is clicked - if (input$save_and_close_button > 0) - 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 - files <- list.files("server_files", full.names = TRUE, recursive = TRUE) - for (f in files) source(f, local = TRUE) + for (f in SERVER_FILES) + source(f, local = TRUE) - # Home page table of contents entries + # Link to pages from home page table of contents toc_entries <- c("Estimate", "Diagnose", "Explore", "Model Code") - - # Names of inputId triggers - options_inputs <- c("table", "multiparam", "autocorr", "rhat_warnings", # multitrace - "bivariate", "trivariate", "density", "hist") - dens_inputs <- c("point_est", "ci", "x_breaks", "fill_color", "line_color") - diagnostic_inputs <- paste0("diagnostic_", c("param", "param_transform", - "param_transform_go")) observe({ - # Link to pages from home page table of contents local({ lapply(toc_entries, function(x) { id <- paste0("toc_", if (x == "Model Code") "more" else tolower(x)) @@ -50,45 +44,88 @@ function(input, output, session) { }) }) }) + + # Toggle options dropdowns + options_trigger_ids <- c("table", "multiparam", "autocorr", "rhat_warnings", + "bivariate", "trivariate", "density", "hist") observe({ - # Toggle options dropdowns - lapply(seq_along(options_inputs), function(j){ - shinyjs::onclick(paste0(options_inputs[j], "_options_show"), - shinyjs::toggle(id = paste0(options_inputs[j], "_options"), - anim = TRUE, animType = "slide", time = 0.4)) + 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 options - lapply(seq_along(dens_inputs), function(j) { - shinyjs::toggleState(id = paste0("dens_", dens_inputs[j]), - condition = input$dens_chain_split == "Together") + }) + + # 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 - shinyjs::onclick("open_glossary_from_table", - updateTabsetPanel(session, "nav", selected = "Glossary")) - shinyjs::onclick("open_glossary_from_nuts_table", - updateTabsetPanel(session, "nav", selected = "Glossary")) }) + + # 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({ - # Enable/disable diagnostic plots diag_nav <- input$diagnostics_navlist local({ if (diag_nav != 'By model parameter') - lapply(diagnostic_inputs, function(x) shinyjs::disable(id = x)) - else - lapply(diagnostic_inputs, function(x) shinyjs::enable(id = x)) + 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"))) + 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")) + observeEvent( + input$shinystan_citation_show, + shinyjs::toggle( + id = "citation_div", + anim = TRUE, + animType = "fade" + ) + ) + } # END server ------------------------------------------------------ # _________________________________________________________________ diff --git a/inst/ShinyStan/server_files/debounce.R b/inst/ShinyStan/server_files/debounce.R index 0021e117..8f35c269 100644 --- a/inst/ShinyStan/server_files/debounce.R +++ b/inst/ShinyStan/server_files/debounce.R @@ -8,7 +8,10 @@ # 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, +debounce <- function(expr, + millis, + env = parent.frame(), + quoted = FALSE, domain = getDefaultReactiveDomain()) { force(millis) @@ -19,12 +22,12 @@ debounce <- function(expr, millis, env = parent.frame(), quoted = FALSE, 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 + v$when <- Sys.time() + millis / 1000 }, ignoreNULL = FALSE) # This observer is the timer. It rests until v$when elapses, then touches @@ -47,4 +50,4 @@ debounce <- function(expr, millis, env = parent.frame(), quoted = FALSE, eventReactive(v$trigger, { f() }, ignoreNULL = FALSE) -} \ No newline at end of file +} diff --git a/inst/ShinyStan/server_files/pages/diagnose/ppcheck/ppcheck_helpers.R b/inst/ShinyStan/server_files/pages/diagnose/ppcheck/ppcheck_helpers.R index 1f90b18a..ff1b1d34 100644 --- a/inst/ShinyStan/server_files/pages/diagnose/ppcheck/ppcheck_helpers.R +++ b/inst/ShinyStan/server_files/pages/diagnose/ppcheck/ppcheck_helpers.R @@ -1,18 +1,3 @@ -# This file is part of shinystan -# Copyright (C) 2015 Jonah Gabry -# -# 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 . - pp_yrep_clr <- "#487575" pp_yrep_fill <- "#6B8E8E" diff --git a/inst/ShinyStan/server_files/pages/diagnose/ppcheck/server/hists_rep_vs_obs.R b/inst/ShinyStan/server_files/pages/diagnose/ppcheck/server/hists_rep_vs_obs.R index debd8c07..fad4a455 100644 --- a/inst/ShinyStan/server_files/pages/diagnose/ppcheck/server/hists_rep_vs_obs.R +++ b/inst/ShinyStan/server_files/pages/diagnose/ppcheck/server/hists_rep_vs_obs.R @@ -1,18 +1,3 @@ -# This file is part of shinystan -# Copyright (C) Jonah Gabry -# -# 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 . - pp_hists_rep_vs_obs <- reactive({ pp_tests() validate(need(input$pp_hists_rep_vs_obs_type, message = "Loading...")) diff --git a/inst/ShinyStan/server_files/pages/diagnose/ppcheck/server/hists_resids.R b/inst/ShinyStan/server_files/pages/diagnose/ppcheck/server/hists_resids.R index d112fa15..218ae726 100644 --- a/inst/ShinyStan/server_files/pages/diagnose/ppcheck/server/hists_resids.R +++ b/inst/ShinyStan/server_files/pages/diagnose/ppcheck/server/hists_resids.R @@ -1,27 +1,9 @@ -# This file is part of shinystan -# Copyright (C) Jonah Gabry -# -# 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 . - - 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 - )) + 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({ diff --git a/inst/ShinyStan/server_files/pages/diagnose/ppcheck/server/hists_test_statistics.R b/inst/ShinyStan/server_files/pages/diagnose/ppcheck/server/hists_test_statistics.R index 01bf275a..26e7f859 100644 --- a/inst/ShinyStan/server_files/pages/diagnose/ppcheck/server/hists_test_statistics.R +++ b/inst/ShinyStan/server_files/pages/diagnose/ppcheck/server/hists_test_statistics.R @@ -1,19 +1,3 @@ -# This file is part of shinystan -# Copyright (C) Jonah Gabry -# -# 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 . - - pp_hists_test_statistics_mean <- reactive({ pp_tests() y <- get_y() diff --git a/inst/ShinyStan/server_files/pages/diagnose/ppcheck/server/pp_utils.R b/inst/ShinyStan/server_files/pages/diagnose/ppcheck/server/pp_utils.R index 8b565b52..8886782c 100644 --- a/inst/ShinyStan/server_files/pages/diagnose/ppcheck/server/pp_utils.R +++ b/inst/ShinyStan/server_files/pages/diagnose/ppcheck/server/pp_utils.R @@ -1,29 +1,66 @@ # validate input tests ---------------------------------------------------- pp_tests <- reactive({ - validate(need(get_y(), message = "Waiting for y \n"), - need(get_yrep(), message = "Waiting for y_rep \n")) + validate( + need( + get_y(), + message = "Waiting for y \n" + ), + need( + get_yrep(), + message = "Waiting for y_rep \n" + ) + ) }) -# y_rep ------------------------------------------------------------------- -get_yrep <- reactive({ - if (!is.null(pp_yrep)) - return(pp_yrep) - else { - validate(need(input$yrep_name, message = "Waiting for y_rep")) - yreps <- grep(paste0("^",input$yrep_name,"\\["), param_names) - out <- samps_post_warmup[,,yreps] - dd <- dim(out) - out <- array(out, dim = c(prod(dd[1:2]), dd[3])) - return(out) +# 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) } }) -get_y <- reactive({ - if (!is.null(pp_y)) return(pp_y) - else { - validate(need(input$y_name, message = "Waiting for y")) - return(get(input$y_name)) +# 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) + } } }) diff --git a/inst/ShinyStan/server_files/pages/diagnose/ppcheck/server/rep_vs_resid_rep.R b/inst/ShinyStan/server_files/pages/diagnose/ppcheck/server/rep_vs_resid_rep.R index 727a68cb..e22f2614 100644 --- a/inst/ShinyStan/server_files/pages/diagnose/ppcheck/server/rep_vs_resid_rep.R +++ b/inst/ShinyStan/server_files/pages/diagnose/ppcheck/server/rep_vs_resid_rep.R @@ -1,19 +1,3 @@ -# This file is part of shinystan -# Copyright (C) Jonah Gabry -# -# 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 . - - pp_avg_rep_vs_avg_resid_rep <- reactive({ pp_tests() y <- get_y() diff --git a/inst/ShinyStan/server_files/pages/diagnose/ppcheck/server/rstanarm.R b/inst/ShinyStan/server_files/pages/diagnose/ppcheck/server/rstanarm.R index ba7f5dd4..708798d1 100644 --- a/inst/ShinyStan/server_files/pages/diagnose/ppcheck/server/rstanarm.R +++ b/inst/ShinyStan/server_files/pages/diagnose/ppcheck/server/rstanarm.R @@ -1,29 +1,31 @@ output$pp_rep_vs_obs_out_rstanarm <- renderPlot({ overlay <- input$pp_rep_vs_obs_overlay_rstanarm == "density" - if (overlay) print(pp_check_plots[["pp_check_dens"]]) - else suppress_and_print(pp_check_plots[["pp_check_hist"]]) + 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(pp_check_plots[["pp_check_stat_mean"]]) + suppress_and_print(PPC_plots[["pp_check_stat_mean"]]) }, bg = "transparent") output$pp_hists_test_statistics_sd_out_rstanarm <- renderPlot({ - suppress_and_print(pp_check_plots[["pp_check_stat_sd"]]) + suppress_and_print(PPC_plots[["pp_check_stat_sd"]]) }, bg = "transparent") output$pp_hists_test_statistics_min_out_rstanarm <- renderPlot({ - suppress_and_print(pp_check_plots[["pp_check_stat_min"]]) + suppress_and_print(PPC_plots[["pp_check_stat_min"]]) }, bg = "transparent") output$pp_hists_test_statistics_max_out_rstanarm <- renderPlot({ - suppress_and_print(pp_check_plots[["pp_check_stat_max"]]) + suppress_and_print(PPC_plots[["pp_check_stat_max"]]) }, bg = "transparent") output$pp_y_vs_avg_rep_out_rstanarm <- renderPlot({ - print(pp_check_plots[["pp_check_scatter"]]) + print(PPC_plots[["pp_check_scatter"]]) }, bg = "transparent") output$pp_hist_resids_out_rstanarm <- renderPlot({ - suppress_and_print(pp_check_plots[["pp_check_resid"]]) + suppress_and_print(PPC_plots[["pp_check_resid"]]) }, bg = "transparent") diff --git a/inst/ShinyStan/server_files/pages/diagnose/ppcheck/server/y_vs_avg_rep.R b/inst/ShinyStan/server_files/pages/diagnose/ppcheck/server/y_vs_avg_rep.R index c3077ef1..5f3ce4a9 100644 --- a/inst/ShinyStan/server_files/pages/diagnose/ppcheck/server/y_vs_avg_rep.R +++ b/inst/ShinyStan/server_files/pages/diagnose/ppcheck/server/y_vs_avg_rep.R @@ -1,19 +1,3 @@ -# This file is part of shinystan -# Copyright (C) Jonah Gabry -# -# 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 . - - pp_y_vs_avg_rep <- reactive({ pp_tests() y <- get_y() diff --git a/inst/ShinyStan/server_files/pages/diagnose/ppcheck/ui/pp_get_y_and_yrep.R b/inst/ShinyStan/server_files/pages/diagnose/ppcheck/ui/pp_get_y_and_yrep.R index aba77784..cfe1bc73 100644 --- a/inst/ShinyStan/server_files/pages/diagnose/ppcheck/ui/pp_get_y_and_yrep.R +++ b/inst/ShinyStan/server_files/pages/diagnose/ppcheck/ui/pp_get_y_and_yrep.R @@ -1,49 +1,48 @@ -# This file is part of shinystan -# Copyright (C) Jonah Gabry -# -# 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 . output$ui_pp_get_y <- renderUI({ if (is.null(pp_y)) { div( - h4("Select the appropriate object from your global environment"), - selectizeInput("y_name", - label = span(style = "color: #337ab7;", withMathJax("\\(\\mathbf{y}\\), a vector of observations")), - choices = c("", objects(envir = .GlobalEnv)), - options = list(placeholder = "Select an object")) + 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.") + } else { + helpText("All set: y found in shinystan object.") } - }) output$ui_pp_get_yrep <- renderUI({ if (is.null(pp_yrep)) { - choices <- param_names + choices <- PARAM_NAMES choices <- strsplit(choices, split = "[", fixed = TRUE) choices <- lapply(choices, function(i) return(i[1])) choices <- unique(unlist(choices)) - div( - h4("Select the appropriate parameter name from your model"), - selectizeInput("yrep_name", - label = span(style = "color: #337ab7;", - withMathJax("\\(\\mathbf{y^{rep}}\\), posterior predictive replications")), - choices = c("", choices), - options = list(placeholder = "Select a parameter name")) - ) - } - else { - helpText("All set: yrep found in shinystan object. Select a plot to view.") + 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.") } }) diff --git a/inst/ShinyStan/server_files/pages/diagnose/server/autocorr.R b/inst/ShinyStan/server_files/pages/diagnose/server/autocorr.R index 98a7a3b1..73974d60 100644 --- a/inst/ShinyStan/server_files/pages/diagnose/server/autocorr.R +++ b/inst/ShinyStan/server_files/pages/diagnose/server/autocorr.R @@ -1,45 +1,33 @@ -# This file is part of shinystan -# Copyright (C) Jonah Gabry -# -# 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 . - - -# autocorrelation plot ---------------------------------------------------- calc_height_autocorr_plot <- reactive({ params <- input$ac_params - params <- .update_params_with_groups(params, param_names) + params <- .update_params_with_groups(params, PARAM_NAMES) LL <- length(params) LL <- ifelse(LL < 8, 8, LL) - round(60*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) == 0) + 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 - )) + 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({ diff --git a/inst/ShinyStan/server_files/pages/diagnose/server/diagnostics.R b/inst/ShinyStan/server_files/pages/diagnose/server/diagnostics.R index b521278d..f957a0a8 100644 --- a/inst/ShinyStan/server_files/pages/diagnose/server/diagnostics.R +++ b/inst/ShinyStan/server_files/pages/diagnose/server/diagnostics.R @@ -1,28 +1,13 @@ -# This file is part of shinystan -# Copyright (C) Jonah Gabry -# -# 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 . - lp_name <- "log-posterior" lp_lab <- "Log Posterior" metrop_lab <- "Mean Metrop. Acceptance" stepsize_lab <- "Sampled Step Size" treedepth_lab <- "Treedepth" -ndivergent_lab <- "N Divergent" +ndivergent_lab <- "Divergent" sp_nuts_check <- reactive({ validate( - need(stan_algorithm == "NUTS", message = "Only available for algorithm = NUTS"), + need(STAN_ALGORITHM == "NUTS", message = "Only available for algorithm = NUTS"), need(input$diagnostic_chain, message = "Loading...") ) }) @@ -36,24 +21,25 @@ diagnostic_param <- reactive({ }) -diagnostic_param_transform <- eventReactive( - input$diagnostic_param_transform_go > 0, - input$diagnostic_param_transform) +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", - "N divergent information" = "ndivergent") + 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]], "Loading")) 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 <- as.integer(if (is.nan(sel[[1]])) "1" else strsplit(sel[[1]], "[-]")[[1]][1]) low:high }, millis = 125) @@ -61,39 +47,50 @@ selected_range <- debounce({ dynamic_trace_diagnostic_stepsize <- reactive({ sp_nuts_check() chain <- diagnostic_chain() - samps <- .stepsize_pw[, -1] + samps <- .stepsize_pw[,-1] lab <- "Sampled Step Size" - stack <- FALSE + 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 <- 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() 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 <- .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) + 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 + ) }) @@ -101,35 +98,41 @@ stepsize_vs_accept_stat <- reactive({ dynamic_trace_diagnostic_lp <- reactive({ sp_nuts_check() chain <- diagnostic_chain() - samps <- samps_post_warmup[,, lp_name] + 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") + 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") + 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() chain <- diagnostic_chain() sel <- selected_range() - lp <- samps_post_warmup[if (!is.null(sel)) sel,, lp_name] + 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) }) @@ -143,16 +146,21 @@ accept_stat_hist <- reactive({ accept_stat_vs_lp <- reactive({ sp_nuts_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] + 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] + 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) + 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 + ) }) @@ -163,20 +171,33 @@ dynamic_trace_diagnostic_treedepth <- reactive({ 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") + 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) + 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() @@ -206,23 +227,30 @@ treedepth_vs_lp <- reactive({ sp_nuts_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 <- .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) + 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 + ) }) @@ -230,40 +258,55 @@ treedepth_vs_accept_stat <- reactive({ 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") + 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) + graph %>% dygraphs::dyAxis( + "y", + valueRange = c(0, 1.1), + pixelsPerLabel = 1e4, + drawGrid = FALSE + ) }) ndivergent_vs_lp <- reactive({ sp_nuts_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 <- .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) + 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 + ) }) @@ -273,20 +316,22 @@ dynamic_trace_diagnostic_parameter <- reactive({ chain <- diagnostic_chain() param <- diagnostic_param() transform_x <- diagnostic_param_transform() - samps <- samps_post_warmup[,, param] + 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 - ) + 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({ @@ -294,11 +339,11 @@ param_vs_lp <- reactive({ param <- diagnostic_param() chain <- diagnostic_chain() sel <- selected_range() - lp <- samps_post_warmup[if (!is.null(sel)) sel,, lp_name] + 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] + 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") { @@ -307,10 +352,16 @@ param_vs_lp <- reactive({ 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) + .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() @@ -319,7 +370,7 @@ param_vs_accept_stat <- reactive({ 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] + 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)) @@ -329,11 +380,15 @@ param_vs_accept_stat <- reactive({ 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 <- .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({ @@ -343,16 +398,21 @@ param_vs_stepsize <- reactive({ 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] + 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) + .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() @@ -361,15 +421,21 @@ param_vs_treedepth <- reactive({ 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] + 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) + .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() @@ -377,7 +443,7 @@ p_hist <- reactive({ param <- diagnostic_param() sel <- selected_range() transform_x <- diagnostic_param_transform() - samps <- samps_post_warmup[if (!is.null(sel)) sel,, param] + samps <- SAMPS_post_warmup[if (!is.null(sel)) sel,, param] lab <- param if (transform_x != "identity") { t_x <- get(transform_x) @@ -407,8 +473,8 @@ for (j in seq_along(trace_nms)) { } for (i in seq_along(hmc_plots)) { local({ - fn <- hmc_plots[i] - output[[paste0(fn,"_out")]] <- renderPlot({ + fn <- hmc_plots[i] + output[[paste0(fn, "_out")]] <- renderPlot({ x <- suppressMessages(do.call(fn, list())) suppress_and_print(x) }) @@ -416,22 +482,28 @@ for (i in seq_along(hmc_plots)) { } output$diagnostic_chain_text <- renderText({ chain <- diagnostic_chain() - if (chain == 0) return("All chains") + 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) + 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 + 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 }) diff --git a/inst/ShinyStan/server_files/pages/diagnose/server/multitrace.R b/inst/ShinyStan/server_files/pages/diagnose/server/multitrace.R index 097585a6..d5181840 100644 --- a/inst/ShinyStan/server_files/pages/diagnose/server/multitrace.R +++ b/inst/ShinyStan/server_files/pages/diagnose/server/multitrace.R @@ -1,19 +1,3 @@ -# This file is part of shinystan -# Copyright (C) Jonah Gabry -# -# 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 . - - # # # multiparameter traceplots ----------------------------------------------- # calc_height_trace_plot <- reactive({ diff --git a/inst/ShinyStan/server_files/pages/diagnose/server/rhat_neff_mcse.R b/inst/ShinyStan/server_files/pages/diagnose/server/rhat_neff_mcse.R index 4f88f29e..6e8084ef 100644 --- a/inst/ShinyStan/server_files/pages/diagnose/server/rhat_neff_mcse.R +++ b/inst/ShinyStan/server_files/pages/diagnose/server/rhat_neff_mcse.R @@ -1,88 +1,84 @@ -# This file is part of shinystan -# Copyright (C) Jonah Gabry -# -# 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 . - -# rhat, n_eff, mcse ------------------------------------------------------- vb_check <- function() { - validate(need(stan_method != "variational", - message = "Not available for variational inference")) + validate( + need( + STAN_METHOD != "variational", + message = "Not available for variational inference" + ) + ) } n_eff_plot <- reactive({ vb_check() - dat <- fit_summary[,"n_eff"] - N <- prod(dim(samps_post_warmup)[1:2]) + 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" - )) + do.call(".rhat_neff_mcse_hist", + args = list( + dat = dat, + N = nrow(SAMPS_post_warmup), + which = "n_eff" + )) }) rhat_plot <- reactive({ vb_check() - dat <- fit_summary[,"Rhat"] + dat <- SUMMARY[, "Rhat"] dat <- data.frame(parameter = names(dat), x = dat) - do.call(".rhat_neff_mcse_hist", args = list( - dat = dat, - which = "rhat" - )) + do.call(".rhat_neff_mcse_hist", args = list(dat = dat, which = "rhat")) }) mcse_over_sd_plot <- reactive({ vb_check() - dat <- fit_summary[, c("se_mean", "sd")] - dat <- dat[,1] / dat[,2] + 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" - )) + do.call(".rhat_neff_mcse_hist", args = list(dat = dat, which = "mcse")) }) n_eff_warnings <- reactive({ vb_check() - paste(.n_eff_warnings(fit_summary, threshold = input$n_eff_threshold), - collapse = "\n") + 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(fit_summary, threshold = input$rhat_threshold), - collapse = "\n") + paste(.rhat_warnings(SUMMARY, threshold = input$rhat_threshold), collapse = "\n") }) mcse_over_sd_warnings <- reactive({ vb_check() - paste(.mcse_over_sd_warnings(fit_summary, threshold = input$mcse_threshold), - collapse = "\n") + 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: ") + 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,": ") + 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:") + 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({ + fn <- paste0(rhat_neff_mcse[i], "_plot") + output[[paste0(fn, "_out")]] <- renderPlot({ x <- do.call(fn, list()) suppress_and_print(x) }, bg = "transparent") diff --git a/inst/ShinyStan/server_files/pages/diagnose/server/summary_stats_sampler.R b/inst/ShinyStan/server_files/pages/diagnose/server/summary_stats_sampler.R index f052e156..24f3decf 100644 --- a/inst/ShinyStan/server_files/pages/diagnose/server/summary_stats_sampler.R +++ b/inst/ShinyStan/server_files/pages/diagnose/server/summary_stats_sampler.R @@ -1,32 +1,21 @@ -# This file is part of shinystan -# Copyright (C) Jonah Gabry -# -# 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 . - # summary statistics for sampler parameters ------------------------------- summary_stats_sampler <- reactive({ - validate(need(stan_algorithm %in% c("NUTS", "HMC"), - message = "Only available for algorithm = NUTS"), - need(input$sampler_warmup, message = "Loading...")) - sp <- if (input$sampler_warmup == "include") - sampler_params else sampler_params_post_warmup + validate( + need(STAN_ALGORITHM %in% c("NUTS", "HMC"), message = "Only available for algorithm = NUTS"), + 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 = warmup_val, - report = input$sampler_report, - digits = input$sampler_digits - )) + 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({ @@ -42,6 +31,5 @@ output$sampler_summary <- DT::renderDataTable({ paging = FALSE, searching = FALSE, info = FALSE - ) - ) + )) }) diff --git a/inst/ShinyStan/server_files/pages/diagnose/ui/multitrace_customize.R b/inst/ShinyStan/server_files/pages/diagnose/ui/multitrace_customize.R index 13924f0e..92f3be61 100644 --- a/inst/ShinyStan/server_files/pages/diagnose/ui/multitrace_customize.R +++ b/inst/ShinyStan/server_files/pages/diagnose/ui/multitrace_customize.R @@ -1,19 +1,3 @@ -# This file is part of shinystan -# Copyright (C) Jonah Gabry -# -# 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 . - - # # output$ui_multitrace_customize <- renderUI({ # my_palette <- "Default" diff --git a/inst/ShinyStan/server_files/pages/estimate/server/multiparameter_plot.R b/inst/ShinyStan/server_files/pages/estimate/server/multiparameter_plot.R index 5c6e161d..b111477b 100644 --- a/inst/ShinyStan/server_files/pages/estimate/server/multiparameter_plot.R +++ b/inst/ShinyStan/server_files/pages/estimate/server/multiparameter_plot.R @@ -1,32 +1,19 @@ -# This file is part of shinystan -# Copyright (C) Jonah Gabry -# -# 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 . - - -# multiparameter plot ----------------------------------------------------- calc_height_param_plot <- reactive({ - 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 + 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) } - round(50*LL) }) multiparam_plot <- reactive({ @@ -37,21 +24,24 @@ multiparam_plot <- reactive({ } 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 = fit_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") - )) + 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") + ) + ) }) @@ -71,4 +61,5 @@ output$save_pdf_multiparam = downloadHandler( filename = "shinstan-multiparam.pdf", content = function(file) { ggsave(file, plot = multiparam_plot(), device = pdf) -}) + } +) diff --git a/inst/ShinyStan/server_files/pages/estimate/server/summary_stats.R b/inst/ShinyStan/server_files/pages/estimate/server/summary_stats.R index 419325b3..3de93436 100644 --- a/inst/ShinyStan/server_files/pages/estimate/server/summary_stats.R +++ b/inst/ShinyStan/server_files/pages/estimate/server/summary_stats.R @@ -1,23 +1,7 @@ -# This file is part of shinystan -# Copyright (C) Jonah Gabry -# -# 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 . - -# Table of posterior summary statistics ----------------------------------- summary_stats <- reactive({ `%>%` <- DT::`%>%` validate(need(input$table_digits, "loading")) - DT::datatable(data = round(table_stats, digits = input$table_digits), + DT::datatable(data = round(TABLE_STATS, digits = input$table_digits), colnames = c('mcse' = 'se_mean'), options = list( colReorder = list(realtime = TRUE), diff --git a/inst/ShinyStan/server_files/pages/estimate/server/summary_stats_latex.R b/inst/ShinyStan/server_files/pages/estimate/server/summary_stats_latex.R index 9595ef7d..ddf17e2d 100644 --- a/inst/ShinyStan/server_files/pages/estimate/server/summary_stats_latex.R +++ b/inst/ShinyStan/server_files/pages/estimate/server/summary_stats_latex.R @@ -1,49 +1,35 @@ -# This file is part of shinystan -# Copyright (C) Jonah Gabry -# -# 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 . - - -# reactive function to make latex table of summary stats summary_stats_latex <- reactive({ - - params <- unique(.update_params_with_groups(input$tex_params, param_names)) + params <- unique(.update_params_with_groups(input$tex_params, PARAM_NAMES)) nParams <- length(params) - if (nParams == 0) params <- param_names + if (nParams == 0) + params <- PARAM_NAMES if (nParams == 1) { x <- do.call(".param_summary", args = list( - param = params, - summary = fit_summary + param = params, + summary = SUMMARY )) } else { x <- do.call(".tex_summary", args = list( - summary = fit_summary[params, ], - cols = input$tex_columns + summary = SUMMARY[params,], + cols = input$tex_columns )) } - + pkgs <- input$tex_pkgs - tab_env <- if ("Longtable" %in% 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 + 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)) + 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) + xtable::print.xtable( + xt, + booktabs = "Booktabs" %in% pkgs, + tabular.environment = tab_env, + include.rownames = FALSE + ) }) output$summary_stats_latex_out <- renderPrint({ diff --git a/inst/ShinyStan/server_files/pages/estimate/ui/multiparam_selectize.R b/inst/ShinyStan/server_files/pages/estimate/ui/multiparam_selectize.R index 9d75c547..9b09dfbc 100644 --- a/inst/ShinyStan/server_files/pages/estimate/ui/multiparam_selectize.R +++ b/inst/ShinyStan/server_files/pages/estimate/ui/multiparam_selectize.R @@ -1,26 +1,13 @@ -# This file is part of shinystan -# Copyright (C) Jonah Gabry -# -# 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 . - 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) + selectizeInput( + "params_to_plot", + label = h5("Select or enter parameter names"), + width = '100%', + choices = choices, + multiple = TRUE + ) }) @@ -30,18 +17,23 @@ output$ui_multiparam_selectize <- renderUI({ copy_params_to_plot <- reactive({ copy <- input$params_to_plot - if (is.null(copy) || !length(copy)) - NULL else copy + 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) + selected <- .update_params_with_groups(selected, PARAM_NAMES) + updateSelectizeInput( + session, + inputId = "params_to_plot", + choices = choices, + selected = selected + ) }) observeEvent(input$param_plot_regex, { @@ -49,12 +41,15 @@ observeEvent(input$param_plot_regex, { if (pattern != "") { choices <- make_param_list_with_groups_sort() selected <- copy_params_to_plot() - selected <- .update_params_with_groups(selected, .param_names) + 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) + selected <- .update_params_with_regex(selected, PARAM_NAMES, pattern) + updateSelectizeInput( + session, + inputId = "params_to_plot", + choices = choices, + selected = selected + ) } } }) @@ -63,7 +58,7 @@ 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)) + validate(need(.test_valid_regex(pattern), message = msg)) } }) diff --git a/inst/ShinyStan/server_files/pages/explore/server/bivariate.R b/inst/ShinyStan/server_files/pages/explore/server/bivariate.R index 83ff7242..37c07b45 100644 --- a/inst/ShinyStan/server_files/pages/explore/server/bivariate.R +++ b/inst/ShinyStan/server_files/pages/explore/server/bivariate.R @@ -1,75 +1,64 @@ -# This file is part of shinystan -# Copyright (C) Jonah Gabry -# -# 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 . - - # 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_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") + 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") + 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)) - 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() - )) + do.call( + ".bivariate_plot", + args = list( + samps = SAMPS_post_warmup, + sp = if (!identical(SAMPLER_PARAMS_post_warmup, FALSE)) + 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({ @@ -89,4 +78,5 @@ output$save_pdf_bivariate = downloadHandler( filename = "shinstan-bivariate.pdf", content = function(file) { ggsave(file, plot = bivariate_plot(), device = pdf) -}) + } +) diff --git a/inst/ShinyStan/server_files/pages/explore/server/density.R b/inst/ShinyStan/server_files/pages/explore/server/density.R index 3df09336..76c63fad 100644 --- a/inst/ShinyStan/server_files/pages/explore/server/density.R +++ b/inst/ShinyStan/server_files/pages/explore/server/density.R @@ -1,19 +1,4 @@ -# This file is part of shinystan -# Copyright (C) Jonah Gabry -# -# 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 . - - +# kernel density plot dens_transform_x <- eventReactive( input$dens_transform_x_go > 0, input$dens_transform_x @@ -22,64 +7,98 @@ dens_transform_x <- eventReactive( 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_)) + 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 + 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)) + if (xzoom == "") + return(last_plot()) - x_lim <- if (xzoom == "c(min, max)") NULL else { - check <- try(user_xlim(xzoom)) - validate(need(check, message = "Invalid input")) - check - } + 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 + 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 + 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() - )) + 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() + ) + ) }) @@ -99,4 +118,5 @@ output$save_pdf_density = downloadHandler( filename = "shinstan-density.pdf", content = function(file) { ggsave(file, plot = density_plot(), device = pdf) -}) + } +) diff --git a/inst/ShinyStan/server_files/pages/explore/server/histogram.R b/inst/ShinyStan/server_files/pages/explore/server/histogram.R index 25c12592..45511810 100644 --- a/inst/ShinyStan/server_files/pages/explore/server/histogram.R +++ b/inst/ShinyStan/server_files/pages/explore/server/histogram.R @@ -1,42 +1,31 @@ -# This file is part of shinystan -# Copyright (C) Jonah Gabry -# -# 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 . - - -# histogram --------------------------------------------------------------- -hist_transform_x <- eventReactive( - input$hist_transform_x_go > 0, - input$hist_transform_x -) +# 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)) + validate( + need(input$param, message = FALSE), + need(!is.null(input$hist_chain), message = FALSE) + ) chain <- input$hist_chain - if (is.na(chain)) chain <- 0 + 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() - )) + 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({ @@ -56,4 +45,5 @@ output$save_pdf_histogram = downloadHandler( filename = "shinstan-histogram.pdf", content = function(file) { ggsave(file, plot = histogram_plot(), device = pdf) -}) + } +) diff --git a/inst/ShinyStan/server_files/pages/explore/server/multiview.R b/inst/ShinyStan/server_files/pages/explore/server/multiview.R index e672c16b..ea464197 100644 --- a/inst/ShinyStan/server_files/pages/explore/server/multiview.R +++ b/inst/ShinyStan/server_files/pages/explore/server/multiview.R @@ -1,66 +1,66 @@ -# This file is part of shinystan -# Copyright (C) Jonah Gabry -# -# 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 . - multiview_samps <- reactive({ - validate(need(input$param, message = FALSE), - need(!is.null(input$multiview_warmup), message = "Loading...")) - if (!input$multiview_warmup) + validate( + need(input$param, message = FALSE), + need(!is.null(input$multiview_warmup), message = "Loading...") + ) + if (!input$multiview_warmup) par_samps_post_warmup() - else + 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) + 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 + ) ) }) autocorr_plot_multiview <- reactive({ - lags <- min(25, round((nIter-warmup_val)/2)) - do.call(".autocorr_single_plot", args = list( - samps = multiview_samps(), - lags = lags - )) + 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 - )) + 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") +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( diff --git a/inst/ShinyStan/server_files/pages/explore/server/summary_stats_param.R b/inst/ShinyStan/server_files/pages/explore/server/summary_stats_param.R index b1eb4c35..5d5e2e11 100644 --- a/inst/ShinyStan/server_files/pages/explore/server/summary_stats_param.R +++ b/inst/ShinyStan/server_files/pages/explore/server/summary_stats_param.R @@ -1,27 +1,13 @@ -# This file is part of shinystan -# Copyright (C) Jonah Gabry -# -# 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 . - - -# posterior summary statistics for a single parameter --------------------- +# 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 = fit_summary - )) + do.call( + ".param_summary", + args = list( + param = input$param, + summary = SUMMARY + ) + ) }) output$param_name <- renderText({ @@ -33,7 +19,10 @@ output$parameter_summary_out <- DT::renderDataTable({ }, rownames = FALSE, options = list( - paging = FALSE, searching = FALSE, info = FALSE, ordering = FALSE, + 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 diff --git a/inst/ShinyStan/server_files/pages/explore/server/trivariate.R b/inst/ShinyStan/server_files/pages/explore/server/trivariate.R index 3e4d82de..cc0c6183 100644 --- a/inst/ShinyStan/server_files/pages/explore/server/trivariate.R +++ b/inst/ShinyStan/server_files/pages/explore/server/trivariate.R @@ -1,53 +1,39 @@ -# This file is part of shinystan -# Copyright (C) Jonah Gabry -# -# 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 . - - -# 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 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 ...")) + 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() - )) + 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({ diff --git a/inst/ShinyStan/server_files/pages/explore/ui/ui_trivariate_select_x.R b/inst/ShinyStan/server_files/pages/explore/ui/ui_trivariate_select_x.R index 6979ab8b..9a391f80 100644 --- a/inst/ShinyStan/server_files/pages/explore/ui/ui_trivariate_select_x.R +++ b/inst/ShinyStan/server_files/pages/explore/ui/ui_trivariate_select_x.R @@ -1,5 +1,9 @@ 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) + selectizeInput( + "trivariate_param_x", + label = strong_bl("x-axis"), + choices = .make_param_list(object), + selected = input$param, + multiple = FALSE + ) }) \ No newline at end of file diff --git a/inst/ShinyStan/server_files/utilities/extract_sso.R b/inst/ShinyStan/server_files/utilities/extract_sso.R index 266570f5..323bc570 100644 --- a/inst/ShinyStan/server_files/utilities/extract_sso.R +++ b/inst/ShinyStan/server_files/utilities/extract_sso.R @@ -1,69 +1,68 @@ -# 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 . +# 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] -# Extract the contents of the shiny_stan_object slots -model_name <- object@model_name -param_names <- object@param_names -samps_all <- object@samps_all -sampler_params <- object@sampler_params -nIter <- object@nIter -nChains <- object@nChains -warmup_val <- object@nWarmup -samps_post_warmup <- samps_all[(warmup_val + 1):nIter,, ,drop = FALSE] - -MISC <- object@misc +MISC <- slot(object, "misc") MISC_nms <- names(MISC) -stan_method <- if ("stan_method" %in% MISC_nms) +STAN_METHOD <- if ("stan_method" %in% MISC_nms) MISC$stan_method else "Not Stan" -stan_algorithm <- if ("stan_algorithm" %in% MISC_nms) +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 +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]])) +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(1:length(sampler_params), function(i) { - out <- sampler_params[[i]] - out <- if (warmup_val == 0) out else out[-(1:warmup_val), ] - rownames(out) <- (warmup_val + 1):(warmup_val + nrow(out)) + 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 = object@nWarmup) - .ndivergent_pw <- .sampler_param_pw(sampler_params_post_warmup, which = "n_divergent__", - warmup_val = object@nWarmup) - .treedepth_pw <- .sampler_param_pw(sampler_params_post_warmup, which = "treedepth__", - warmup_val = object@nWarmup) - .accept_stat_pw <- .sampler_param_pw(sampler_params_post_warmup, which = "accept_stat__", - warmup_val = object@nWarmup) +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) } -table_stats <- fit_summary <- object@summary -if (!stan_method == "variational") { - sel <- colnames(table_stats) %in% c("Rhat", "n_eff") - table_stats <- cbind(table_stats[, sel], table_stats[, !sel]) +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"]) + TABLE_STATS[, "n_eff"] <- round(TABLE_STATS[, "n_eff"]) } -from_rstanarm <- if (is.null(MISC$stanreg)) FALSE else MISC$stanreg -if (from_rstanarm) pp_check_plots <- MISC$pp_check_plots - +# ppcheck plots from rstanarm +if (isTRUE(MISC$stanreg)) + PPC_plots <- MISC$pp_check_plots diff --git a/inst/ShinyStan/server_files/utilities/make_param_list_with_groups_sort.R b/inst/ShinyStan/server_files/utilities/make_param_list_with_groups_sort.R index c3ecc8fd..7eb2e22f 100644 --- a/inst/ShinyStan/server_files/utilities/make_param_list_with_groups_sort.R +++ b/inst/ShinyStan/server_files/utilities/make_param_list_with_groups_sort.R @@ -2,18 +2,20 @@ 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(object@param_dims) - ll <- length(object@param_dims) - LL <- sapply(1:ll, function(i) length(object@param_dims[[i]])) + param_groups <- names(PARAM_DIMS) + ll <- length(PARAM_DIMS) + LL <- sapply(seq_len(ll), function(i) + length(PARAM_DIMS[[i]])) - choices[1:ll] <- "" + choices[seq_len(ll)] <- "" names(choices) <- param_groups - for(i in 1:ll) { - if (LL[i] == 0) choices[[i]] <- list(param_groups[i]) - else { + 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 <- object@param_names[grep(temp, object@param_names)] + 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 diff --git a/inst/ShinyStan/server_files/utilities/par_samps_reactive.R b/inst/ShinyStan/server_files/utilities/par_samps_reactive.R index faa652bd..43c41a5f 100644 --- a/inst/ShinyStan/server_files/utilities/par_samps_reactive.R +++ b/inst/ShinyStan/server_files/utilities/par_samps_reactive.R @@ -1,26 +1,11 @@ -# 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 . - # reactive function to get samples for a single parameter par_samps_all <- reactive({ param <- input$param - p <- which(param_names == param) - samps_all[,, p] + 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] + p <- which(PARAM_NAMES == param) + SAMPS_post_warmup[, , p] }) diff --git a/inst/ShinyStan/server_files/utilities/ppcheck_names_descriptions.R b/inst/ShinyStan/server_files/utilities/ppcheck_names_descriptions.R deleted file mode 100644 index d6b9043c..00000000 --- a/inst/ShinyStan/server_files/utilities/ppcheck_names_descriptions.R +++ /dev/null @@ -1,32 +0,0 @@ -# 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 . - - - -plot_names <- c("plot_hists_rep_vs_obs", - "plot_dens_rep_vs_obs", - "plot_obs_vs_avg_y_rep", - "plot_hist_resids", - "plot_avg_rep_vs_avg_resid_rep", - "plot_test_statistics" -) - -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})\\)") - diff --git a/inst/ShinyStan/server_utils.R b/inst/ShinyStan/server_utils.R new file mode 100644 index 00000000..a909a53c --- /dev/null +++ b/inst/ShinyStan/server_utils.R @@ -0,0 +1,4 @@ +# function to suppress unnecessary warnings and messages generated by ggplot +suppress_and_print <- function(x) { + suppressMessages(suppressWarnings(print(x))) +} diff --git a/inst/ShinyStan/ui.R b/inst/ShinyStan/ui.R index 55d39bd0..708e1aaf 100644 --- a/inst/ShinyStan/ui.R +++ b/inst/ShinyStan/ui.R @@ -1,6 +1,3 @@ -# This file is part of shinystan -# Copyright (C) 2015 Jonah Gabry -# # 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 @@ -13,235 +10,62 @@ # You should have received a copy of the GNU General Public License along with # this program; if not, see . -object <- get(".shinystan_temp_object", envir = shinystan:::.sso_env) source("global_utils.R", local = TRUE) -rm(object) -gc() - -# corner_link <- HTML(paste0('', 'Stan', '')) +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."), + 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, id = "nav", #title = NULL, - windowTitle = "ShinyStan", collapsible = TRUE, - inverse = FALSE, position = "fixed-top", - theme = shinythemes::shinytheme("flatly"), - - #### HOME PAGE #### - tabPanel(title = strong(style = "color: #B2011D;", "ShinyStan"), - value = "home", - logo_and_name(), - div(class = "home-links", - div(id = "model-name", - br(), - h2(paste("Model:")), - h4(.model_name) - ) - ), - br(),br(),br(),br(), - includeHTML("html/home_page_links.html") - ), - - #### PAGE: DIAGNOSE #### - tabPanel(title = "Diagnose", icon = icon("medkit"), - tabsetPanel( - #### hmc/nuts plots #### - tabPanel("NUTS (plots)", - source(file.path("ui_files", "diagnostics_customize.R"), local = TRUE)$value, - navlistPanel(id = "diagnostics_navlist", - tabPanel("By model parameter", source(file.path("ui_files", "diagnostics_by_parameter.R"), local = TRUE)$value), - tabPanel("Sample information", source(file.path("ui_files", "diagnostics_sample.R"), local = TRUE)$value), - tabPanel("Treedepth information", source(file.path("ui_files", "diagnostics_treedepth.R"), local = TRUE)$value), - tabPanel("N divergent information", source(file.path("ui_files", "diagnostics_ndivergent.R"), local = TRUE)$value), - tabPanel("Step size information", source(file.path("ui_files", "diagnostics_stepsize.R"), local = TRUE)$value), - tabPanel("Help", source(file.path("ui_files", "diagnostics_help.R"), local = TRUE)$value), - well = FALSE, - widths = c(2, 10) - ) - ), - #### hmc/nuts stats #### - tabPanel("HMC/NUTS (stats)", - h2("Summary of sampler parameters"), - a_glossary("open_glossary_from_nuts_table"), - br(), - source(file.path("ui_files", "sampler_stats_customize.R"), local = TRUE)$value, - DT::dataTableOutput("sampler_summary"), - br() - ), - #### rhat, n_eff, mcse #### - tabPanel("\\(\\hat{R}, n_{eff}, \\text{se}_{mean}\\)", - source(file.path("ui_files", "rhat_neff_mcse_layout.R"), local = TRUE)$value - ), - #### autocorrelation #### - tabPanel("Autocorrelation", - source(file.path("ui_files", "autocorr_customize.R"), local = TRUE)$value, - wellPanel( - fluidRow( - column(8, selectizeInput("ac_params", width = "100%", label = h5("Select or enter parameter names"), - choices = .param_list_with_groups, multiple = TRUE)), - column(3, offset = 1, a_options("autocorr")) - ) - ), - plotOutput("autocorr_plot_out") - ), - #### ppcheck #### - tabPanel(title = "PPcheck", - h2("Graphical posterior predictive checks"), - h6("Experimental feature"), - source(file.path("ui_files", if (.from_rstanarm) "pp_navlist_rstanarm.R" else "pp_navlist.R"), local = TRUE)$value, - br() - ) - ) # End tabsetPanel - ), # End DIAGNOSE + + 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") + ), - #### PAGE: ESTIMATE #### - tabPanel(title = "Estimate", icon = icon("stats", lib = "glyphicon"), - withMathJax(), - - tabsetPanel( - #### multiparameter plot #### - tabPanel("Parameters plot", - wellPanel( - fluidRow( - column(6, uiOutput("ui_multiparam_selectize")), - column(3, offset = 1, - sliderInput("param_plot_ci_level", h5("Credible interval"), - width = "75%", ticks = FALSE, min = 50, max = 95, - value = 50, step = 5, post = "%")), - column(2, a_options("multiparam")) - ), - fluidRow( - column(1, actionButton("param_plot_regex", label = "Search", class = "regex-go")), - column(3, textInput("params_to_plot_regex", label = NULL, value = "Add parameters by regex search")), - column(5, textOutput("invalid_regex")) - ) - ), - source(file.path("ui_files", "multiparam_customize.R"), local = TRUE)$value, - plotOutput("multiparam_plot_out", width = "90%") - ), - #### posterior summary statistics #### - tabPanel("Posterior summary statistics", - source(file.path("ui_files", "table_customize.R"), local = TRUE)$value, - div(DT::dataTableOutput("all_summary_out"), - style = "overflow-x: auto") - ), - #### LaTex tables #### - tabPanel("Generate LaTeX table", - br(), - sidebarLayout( - mainPanel = source(file.path("ui_files", "table_latex_main.R"), local = TRUE)$value, - sidebarPanel = source(file.path("ui_files", "table_latex_sidebar.R"), local = TRUE)$value - ) - ) - ) # End tabsetPanel - ), # End ESTIMATE - - #### PAGE: EXPLORE #### - tabPanel(title = "Explore", icon = icon("eye-open", lib = "glyphicon"), - fluidRow( - column(3, selectizeInput(inputId = "param", label = h4("Select parameter"), - choices = .param_list, - selected = .param_list[1], - multiple = FALSE)), - column(7, offset = 1, DT::dataTableOutput("parameter_summary_out")) - ), - navlistPanel(well = FALSE, widths = c(3, 9), - #### multiview #### - tabPanel("Multiview", icon = icon("th-large", lib = "glyphicon"), - checkboxInput("multiview_warmup", label = strong("Include warmup"), value = FALSE), - splitLayout(h5("Kernel Density Estimate"), h5("Autocorrelation")), - splitLayout(plotOutput("multiview_density_out", height = "150"), - plotOutput("multiview_autocorr_out", height = "150"), - cellArgs = list(class = "plot_hover_shadow") - ), - h5("Trace"), - dygraphs::dygraphOutput("multiview_trace_out", height = "200px"), - source(file.path("ui_files", "dynamic_trace_helptext.R"), local = TRUE)$value - ), - #### bivariate ##### - tabPanel("Bivariate", - selectizeInput("bivariate_param_y", label = strong(style = "color: #006DCC;", "y-axis"), - choices = rev(.param_list), - selected = rev(.param_list)[1], multiple = FALSE), - a_options("bivariate"), - source(file.path("ui_files", "bivariate_customize.R"), local = TRUE)$value, - plotOutput("bivariate_plot_out", height = "350px"), - helpText(style = "font-size: 11px", "For Stan models using the NUTS algorithm, red points indicate iterations that encountered a divergent transition.", - "Yellow points indicate a transition that hit the maximum treedepth", - "rather than terminated its evolution normally."), - hr(), - downloadButton("download_bivariate", "ggplot2", class = "plot-download"), - downloadButton('save_pdf_bivariate', "pdf", class = "plot-download pdf-download") - ), - #### trivariate ##### - tabPanel("Trivariate", - source(file.path("ui_files", "trivariate_select.R"), local = TRUE)$value, - a_options("trivariate"), - source(file.path("ui_files", "trivariate_customize.R"), local = TRUE)$value, - br(), - threejs::scatterplotThreeOutput("trivariate_plot_out", height = "400px"), - helpText(style = "font-size: 12px;", "Use your mouse and trackpad to rotate the plot and zoom in or out.") - ), - #### density ##### - tabPanel("Density", - a_options("density"), - source(file.path("ui_files", "density_customize.R"), local = TRUE)$value, - plotOutput("density_plot_out", height = "250px"), - hr(), - downloadButton("download_density", "ggplot2", class = "plot-download"), - downloadButton('save_pdf_density', "pdf", class = "plot-download pdf-download") - ), - #### histogram ##### - tabPanel("Histogram", - a_options("hist"), - source(file.path("ui_files", "hist_customize.R"), local = TRUE)$value, - plotOutput("hist_plot_out", height = "250px"), - hr(), - downloadButton("download_histogram", "ggplot2", class = "plot-download"), - downloadButton('save_pdf_histogram', "pdf", class = "plot-download pdf-download") - ) - ) # End navlist - ), # End EXPLORE - - #### MENU: More #### - navbarMenu(title = "More", - - #### model code #### - tabPanel(title = "Model Code", - source(file.path("ui_files", "model_code.R"), local = TRUE)$value - ), - #### notepad #### - tabPanel(title = "Notepad", - source(file.path("ui_files", "notepad.R"), local = TRUE)$value - ), - #### about #### - tabPanel(title = "About", - logo_and_name(), - div(style = "margin-top: 75px;", - source(file.path("ui_files", "about.R"), local = TRUE)$value - ) - ), - #### glossary #### - tabPanel(title = "Glossary", - div(style = "background-color: white;", - h1(style = "text-align: center;", "Glossary"), - source(file.path("ui_files", "glossary.R"), local = TRUE)$value, - hr(), - stan_manual() - ) - ), - #### help #### - tabPanel(title = "Help", - h1(style = "text-align: center;", "Help"), - source(file.path("ui_files", "help.R"), local = TRUE)$value - ) - ) # End navbarMenu + #### More #### + source_ui("PAGE_more_menu.R") + ) # End navbarPage ) # End tagList + +# End shinyUI ------------------------------------------------------------- +# ------------------------------------------------------------------------- diff --git a/inst/ShinyStan/ui_files/PAGE_diagnose.R b/inst/ShinyStan/ui_files/PAGE_diagnose.R new file mode 100644 index 00000000..98a7299c --- /dev/null +++ b/inst/ShinyStan/ui_files/PAGE_diagnose.R @@ -0,0 +1,89 @@ +tabsetPanel( + id = "diagnose_tabset", + + #### hmc/nuts plots #### + tabPanel( + title = "NUTS (plots)", + source_ui("diagnostics_customize.R"), + navlistPanel( + id = "diagnostics_navlist", + tabPanel( + "By model parameter", + source_ui("diagnostics_by_parameter.R") + ), + tabPanel( + "Sample information", + source_ui("diagnostics_sample.R") + ), + tabPanel( + "Treedepth information", + source_ui("diagnostics_treedepth.R") + ), + tabPanel( + "Divergence information", + source_ui("diagnostics_ndivergent.R") + ), + tabPanel( + "Step size information", + source_ui("diagnostics_stepsize.R") + ), + tabPanel( + "Help", + source_ui("diagnostics_help.R") + ), + well = FALSE, + widths = c(2, 10) + ) + ), + + #### hmc/nuts stats #### + tabPanel( + title = "HMC/NUTS (stats)", + h2("Summary of sampler parameters"), + a_glossary("open_glossary_from_nuts_table"), + br(), + source_ui("sampler_stats_customize.R"), + DT::dataTableOutput("sampler_summary"), + br() + ), + + #### rhat, n_eff, mcse #### + tabPanel( + title = "\\(\\hat{R}, n_{eff}, \\text{se}_{mean}\\)", + source_ui("rhat_neff_mcse_layout.R") + ), + + #### autocorrelation #### + tabPanel( + title = "Autocorrelation", + source_ui("autocorr_customize.R"), + wellPanel(fluidRow( + column( + width = 8, + selectizeInput( + "ac_params", + width = "100%", + label = h5("Select or enter parameter names"), + choices = .param_list_with_groups, + multiple = TRUE + ) + ), + column( + width = 3, + offset = 1, + a_options("autocorr") + ) + )), + plotOutput("autocorr_plot_out") + ), + + #### ppcheck #### + tabPanel( + title = "PPcheck", + h2("Graphical posterior predictive checks"), + h6("Experimental feature"), + source_ui(if (.has_rstanarm_ppcs) + "pp_navlist_rstanarm.R" else "pp_navlist.R"), + br() + ) +) \ No newline at end of file diff --git a/inst/ShinyStan/ui_files/PAGE_estimate.R b/inst/ShinyStan/ui_files/PAGE_estimate.R new file mode 100644 index 00000000..5e8db769 --- /dev/null +++ b/inst/ShinyStan/ui_files/PAGE_estimate.R @@ -0,0 +1,70 @@ +tabsetPanel( + id = "estimate_tabset", + + #### multiparameter plot #### + tabPanel( + title = "Parameters plot", + wellPanel( + fluidRow( + column(width = 6, + uiOutput("ui_multiparam_selectize")), + column( + width = 3, + offset = 1, + sliderInput( + "param_plot_ci_level", + h5("Credible interval"), + width = "75%", + ticks = FALSE, + min = 50, + max = 95, + value = 50, + step = 5, + post = "%" + ) + ), + column(width = 2, + a_options("multiparam")) + ), + fluidRow(column( + width = 3, + offset = 1, + span(id = "params_to_plot_regex_label", + "Add parameters by regex search") + )), + fluidRow( + column( + width = 1, + actionButton("param_plot_regex", label = "Search", class = "regex-go") + ), + column( + width = 3, + textInput("params_to_plot_regex", label = NULL, value = "") + ), + column(width = 5, + textOutput("invalid_regex")) + ) + ), + source_ui("multiparam_customize.R"), + plotOutput("multiparam_plot_out", width = "90%"), + br() + ), + + #### posterior summary statistics #### + tabPanel( + "Posterior summary statistics", + source_ui("table_customize.R"), + div(DT::dataTableOutput("all_summary_out"), + style = "overflow-x: auto") + ), + + #### LaTex tables #### + tabPanel( + "Generate LaTeX table", + br(), + sidebarLayout( + mainPanel = source_ui("table_latex_main.R"), + sidebarPanel = source_ui("table_latex_sidebar.R") + ) + ) +) \ No newline at end of file diff --git a/inst/ShinyStan/ui_files/PAGE_explore.R b/inst/ShinyStan/ui_files/PAGE_explore.R new file mode 100644 index 00000000..f9795285 --- /dev/null +++ b/inst/ShinyStan/ui_files/PAGE_explore.R @@ -0,0 +1,103 @@ +tagList( + fluidRow( + column( + width = 3, + selectizeInput( + inputId = "param", + label = h4("Select parameter"), + choices = .param_list, + selected = .param_list[1], + multiple = FALSE + ) + ), + column( + width = 7, + offset = 1, + DT::dataTableOutput("parameter_summary_out") + ) + ), + navlistPanel( + well = FALSE, + widths = c(3, 9), + + #### multiview #### + tabPanel( + title = "Multiview", + icon = icon("th-large", lib = "glyphicon"), + checkboxInput( + "multiview_warmup", + label = strong("Include warmup"), + value = FALSE + ), + splitLayout(h5("Kernel Density Estimate"), h5("Autocorrelation")), + splitLayout( + plotOutput("multiview_density_out", height = "150"), + plotOutput("multiview_autocorr_out", height = "150"), + cellArgs = list(class = "plot_hover_shadow") + ), + h5("Trace"), + dygraphs::dygraphOutput("multiview_trace_out", height = "200px"), + source_ui("dynamic_trace_helptext.R") + ), + + #### bivariate ##### + tabPanel( + title = "Bivariate", + selectizeInput( + "bivariate_param_y", + label = strong(style = "color: #006DCC;", "y-axis"), + choices = rev(.param_list), + selected = rev(.param_list)[1], + multiple = FALSE + ), + a_options("bivariate"), + source_ui("bivariate_customize.R"), + plotOutput("bivariate_plot_out", height = "350px"), + helpText( + style = "font-size: 11px", + "For Stan models using the NUTS algorithm, red points indicate iterations that encountered a divergent transition.", + "Yellow points indicate a transition that hit the maximum treedepth", + "rather than terminated its evolution normally." + ), + hr(), + downloadButton("download_bivariate", "ggplot2", class = "plot-download"), + downloadButton('save_pdf_bivariate', "pdf", class = "plot-download pdf-download") + ), + + #### trivariate ##### + tabPanel( + title = "Trivariate", + source_ui("trivariate_select.R"), + a_options("trivariate"), + source_ui("trivariate_customize.R"), + br(), + threejs::scatterplotThreeOutput("trivariate_plot_out", height = "400px"), + helpText( + style = "font-size: 12px;", + "Use your mouse and trackpad to rotate the plot and zoom in or out." + ) + ), + + #### density ##### + tabPanel( + title = "Density", + a_options("density"), + source_ui("density_customize.R"), + plotOutput("density_plot_out", height = "250px"), + hr(), + downloadButton("download_density", "ggplot2", class = "plot-download"), + downloadButton('save_pdf_density', "pdf", class = "plot-download pdf-download") + ), + + #### histogram ##### + tabPanel( + title = "Histogram", + a_options("hist"), + source_ui("hist_customize.R"), + plotOutput("hist_plot_out", height = "250px"), + hr(), + downloadButton("download_histogram", "ggplot2", class = "plot-download"), + downloadButton('save_pdf_histogram', "pdf", class = "plot-download pdf-download") + ) + ) +) \ No newline at end of file diff --git a/inst/ShinyStan/ui_files/PAGE_home.R b/inst/ShinyStan/ui_files/PAGE_home.R new file mode 100644 index 00000000..4e8592db --- /dev/null +++ b/inst/ShinyStan/ui_files/PAGE_home.R @@ -0,0 +1,10 @@ +tagList( + logo_and_name(), + div(class = "home-links", + div(id = "model-name", + br(), + h2("Model:"), + h4(.model_name))), + br(), br(), br(), br(), + includeHTML("html/home_page_links.html") +) \ No newline at end of file diff --git a/inst/ShinyStan/ui_files/PAGE_more_menu.R b/inst/ShinyStan/ui_files/PAGE_more_menu.R new file mode 100644 index 00000000..815476df --- /dev/null +++ b/inst/ShinyStan/ui_files/PAGE_more_menu.R @@ -0,0 +1,44 @@ +navbarMenu( + title = "More", + + #### model code #### + tabPanel( + title = "Model Code", + source_ui("model_code.R") + ), + + #### notepad #### + tabPanel( + title = "Notepad", + source_ui("notepad.R") + ), + + #### about #### + tabPanel( + title = "About", + logo_and_name(), + div( + style = "margin-top: 75px;", + source_ui("about.R") + ) + ), + + #### glossary #### + tabPanel( + title = "Glossary", + div( + style = "background-color: white;", + h1(style = "text-align: center;", "Glossary"), + source_ui("glossary.R"), + hr(), + stan_manual() + ) + ), + + #### help #### + tabPanel( + title = "Help", + h1(style = "text-align: center;", "Help"), + source_ui("help.R") + ) +) \ No newline at end of file diff --git a/inst/ShinyStan/ui_files/about.R b/inst/ShinyStan/ui_files/about.R index 09daefad..cede301b 100644 --- a/inst/ShinyStan/ui_files/about.R +++ b/inst/ShinyStan/ui_files/about.R @@ -1,52 +1,65 @@ -# This file is part of shinystan -# Copyright (C) Jonah Gabry -# -# 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 . - -div(style = "text-align: center; margin-top: 100px;", - shinystan_version(), - br(),br(), - a(style = "font-size: 16px;", strong("Stan Development Team"), - href="http://mc-stan.org/team/"), - br(), - a(style = "font-size: 14px;", "mc-stan.org", href="http://mc-stan.org/"), - div( - actionLink(inputId = "shinystan_citation_show", label = "Show Citation", - style = "font-size: 12px;", class = "aoptions"), - div( - shinyjs::hidden(wellPanel(id = "citation_div", style = "text-align: left;", - includeHTML("html/citation.html") - ))) +div( + style = "text-align: center; margin-top: 100px;", + shinystan_version(), + br(),br(), + a( + style = "font-size: 16px;", + strong("Stan Development Team"), + href = "http://mc-stan.org/team/" + ), + br(), + a( + style = "font-size: 14px;", + "mc-stan.org", + href = "http://mc-stan.org/" + ), + div( + actionLink( + inputId = "shinystan_citation_show", + label = "Show Citation", + style = "font-size: 12px;", + class = "aoptions" ), - br(),br(), - h6("Author"), - helpText(style = "font-size: 12px;", "Jonah Gabry"), - br(), - h6(style = "font-size: 12px;", "Contributors"), - helpText(style = "font-size: 12px;", - includeHTML("html/contribs.html") + div(shinyjs::hidden( + wellPanel( + id = "citation_div", + style = "text-align: left;", + includeHTML("html/citation.html") + ) + )) + ), + br(),br(), + h6("Author"), + helpText(style = "font-size: 12px;", "Jonah Gabry"), + br(), + h6(style = "font-size: 12px;", "Contributors"), + helpText(style = "font-size: 12px;", includeHTML("html/contribs.html")), + br(), + h6("Logo"), + helpText( + style = "font-size: 12px;", + a( + href = "http://mc-stan.org/team/", + "Michael Betancourt" + ) + ), + br(), + h6("Shiny"), + helpText( + style = "font-size: 12px;", + "ShinyStan is powered by the", + a( + href = "http://shiny.rstudio.com", + "Shiny web application framework" ), - br(), - h6("Logo"), - helpText(style = "font-size: 12px;", - a(href = "http://mc-stan.org/team/", "Michael Betancourt")), - br(), - h6("Shiny"), - helpText(style = "font-size: 12px;", "ShinyStan is powered by the", - a(href = "http://shiny.rstudio.com", - "Shiny web application framework"), "(RStudio)"), - br(), - h6("Source code"), - a(style="color: #190201;", href="http://github.com/stan-dev/shinystan", - target="_blank", tags$i(class="fa fa-github fa-3x")) + "(RStudio)" + ), + br(), + h6("Source code"), + a( + style = "color: #190201;", + href = "http://github.com/stan-dev/shinystan", + target = "_blank", + tags$i(class = "fa fa-github fa-3x") + ) ) diff --git a/inst/ShinyStan/ui_files/autocorr_customize.R b/inst/ShinyStan/ui_files/autocorr_customize.R index 1fe60f88..708106c8 100644 --- a/inst/ShinyStan/ui_files/autocorr_customize.R +++ b/inst/ShinyStan/ui_files/autocorr_customize.R @@ -1,43 +1,34 @@ -# This file is part of shinystan -# Copyright (C) Jonah Gabry -# -# 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 . - -absolutePanel(id = "controls_autocorr", - class = "draggable_controls", - fixed = TRUE, - top = 185, right = 20, width = 200, - draggable = TRUE, - shinyjs::hidden( - div(id = "autocorr_options", - wellPanel( - class = "optionswell", - strongBig("Autocorrelation"), - hr(class = "hroptions"), - br(), - sliderInput("ac_lags", label = NULL, - post = " lags", min = 0, max = .nIter-.nWarmup-5, - step = 5, value = min(25, round((.nIter-.nWarmup)/2))), - checkboxInput("ac_partial", label = "Partial autocorrelation", - value = FALSE), - checkboxInput("ac_warmup", label = "Include warmup", FALSE), - checkboxInput("ac_combine", label = "Combine chains", FALSE), - checkboxInput("ac_flip", label = "Flip facets", FALSE), - hr(class = "hroptions"), - downloadButton("download_autocorr", "ggplot2", class = "plot-download"), - downloadButton('save_pdf_autocorr', "pdf", class = "plot-download pdf-download") - ) - ) - ) +absolutePanel( + id = "controls_autocorr", + class = "draggable_controls", + fixed = TRUE, + top = 185, + right = 20, + width = 200, + draggable = TRUE, + shinyjs::hidden(div( + id = "autocorr_options", + wellPanel( + class = "optionswell", + strongBig("Autocorrelation"), + hr(class = "hroptions"), + br(), + sliderInput( + "ac_lags", + label = NULL, + post = " lags", + min = 0, + max = .nIter - .nWarmup - 5, + step = 5, + value = min(25, round((.nIter - .nWarmup) / 2)) + ), + checkboxInput("ac_partial", label = "Partial autocorrelation", value = FALSE), + checkboxInput("ac_warmup", label = "Include warmup", FALSE), + checkboxInput("ac_combine", label = "Combine chains", FALSE), + checkboxInput("ac_flip", label = "Flip facets", FALSE), + hr(class = "hroptions"), + downloadButton("download_autocorr", "ggplot2", class = "plot-download"), + downloadButton('save_pdf_autocorr', "pdf", class = "plot-download pdf-download") + ) + )) ) - diff --git a/inst/ShinyStan/ui_files/bivariate_customize.R b/inst/ShinyStan/ui_files/bivariate_customize.R index 5acc5d2d..cc191c09 100644 --- a/inst/ShinyStan/ui_files/bivariate_customize.R +++ b/inst/ShinyStan/ui_files/bivariate_customize.R @@ -1,18 +1,3 @@ -# This file is part of shinystan -# Copyright (C) Jonah Gabry -# -# 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 . - shinyjs::hidden( div(id = "bivariate_options", wellPanel( @@ -21,44 +6,154 @@ shinyjs::hidden( strongBig("Transformation"), transform_helpText("x,y"), fluidRow( - column(3, transformation_selectInput("bivariate_transform_x")), - column(3, transformation_selectInput("bivariate_transform_y")), - column(2, actionButton("bivariate_transform_go", label = "Transform", - class = "transform-go")) + column(width = 3, transformation_selectInput("bivariate_transform_x")), + column(width = 3, transformation_selectInput("bivariate_transform_y")), + column( + width = 2, + actionButton("bivariate_transform_go", label = "Transform", class = "transform-go") + ) ), hr(class = "hroptions"), - selectInput("bivariate_options_display", label = strongBig("Control"), - choices = c("Points", "Ellipse", "Lines"), - selected = "Points", width = "50%"), - conditionalPanel(condition = "input.bivariate_options_display == 'Points'", - fluidRow( - column(3, shinyjs::colourInput("bivariate_pt_color", strongMed("Color"), base_fill)), - column(2, numericInput("bivariate_pt_size", strongMed("Size"), value = 3.5, min = 0, max = 10, step = 0.5)), - column(2, numericInput("bivariate_pt_shape", strongMed("Shape"), value = 10, min = 1, max = 10, step = 1)), - column(2, sliderInput("bivariate_pt_alpha", strongMed("Opacity"), value = alpha_calc_pt(.nIter), min = 0, max = 1, step = 0.01, ticks = FALSE)) - ) - ), - conditionalPanel(condition = "input.bivariate_options_display == 'Ellipse'", - fluidRow( - column(2, selectizeInput(inputId = "bivariate_ellipse_lev", - label = strongMed("Type"), - selected = "None", - choices = list("None" = "None", "50%" = 0.5, "80%" = 0.8, "95%" = 0.95, "99%" = 0.99))), - column(3, shinyjs::colourInput("bivariate_ellipse_color", strongMed("Color"), vline_base_clr)), - column(2, numericInput("bivariate_ellipse_lwd", strongMed("Size"), value = 1, min = 0, max = 5, step = 0.5)), - column(2, numericInput("bivariate_ellipse_lty", strongMed("Shape"), value = 1, min = 1, max = 6, step = 1)), - column(2, sliderInput("bivariate_ellipse_alpha", strongMed("Opacity"), value = 1, min = 0, max = 1, step = 0.01, ticks = FALSE)) - ) - ), - conditionalPanel(condition = "input.bivariate_options_display == 'Lines'", - fluidRow( - column(2, selectizeInput(inputId = "bivariate_lines", - label = strongMed("Position"), - choices = c(Hide = "hide", Back = "back", Front = "front"), selected = "back")), - column(3, shinyjs::colourInput("bivariate_lines_color", strongMed("Color"), "gray")), - column(2, sliderInput("bivariate_lines_alpha", label = strongMed("Opacity"), value = alpha_calc_lines(.nIter), - min = 0, max = 1, step = 0.01, ticks = FALSE)) - ) + selectInput( + "bivariate_options_display", + label = strongBig("Control"), + choices = c("Points", "Ellipse", "Lines"), + selected = "Points", + width = "50%" + ), + conditionalPanel( + condition = "input.bivariate_options_display == 'Points'", + fluidRow( + column( + width = 3, + shinyjs::colourInput("bivariate_pt_color", strongMed("Color"), base_fill) + ), + column( + width = 2, + numericInput( + "bivariate_pt_size", + strongMed("Size"), + value = 3.5, + min = 0, + max = 10, + step = 0.5 + ) + ), + column( + width = 2, + numericInput( + "bivariate_pt_shape", + strongMed("Shape"), + value = 10, + min = 1, + max = 10, + step = 1 + ) + ), + column( + width = 2, + sliderInput( + "bivariate_pt_alpha", + strongMed("Opacity"), + value = alpha_calc_pt(.nIter), + min = 0, + max = 1, + step = 0.01, + ticks = FALSE + ) + ) + )), + conditionalPanel( + condition = "input.bivariate_options_display == 'Ellipse'", + fluidRow( + column( + width = 2, + selectizeInput( + inputId = "bivariate_ellipse_lev", + label = strongMed("Type"), + selected = "None", + choices = list( + "None" = "None", + "50%" = 0.5, + "80%" = 0.8, + "95%" = 0.95, + "99%" = 0.99 + ) + ) + ), + column( + width = 3, + shinyjs::colourInput( + "bivariate_ellipse_color", + strongMed("Color"), + vline_base_clr + ) + ), + column( + width = 2, + numericInput( + "bivariate_ellipse_lwd", + strongMed("Size"), + value = 1, + min = 0, + max = 5, + step = 0.5 + ) + ), + column( + width = 2, + numericInput( + "bivariate_ellipse_lty", + strongMed("Shape"), + value = 1, + min = 1, + max = 6, + step = 1 + ) + ), + column( + width = 2, + sliderInput( + "bivariate_ellipse_alpha", + strongMed("Opacity"), + value = 1, + min = 0, + max = 1, + step = 0.01, + ticks = FALSE + ) + ) + ) + ), + conditionalPanel( + condition = "input.bivariate_options_display == 'Lines'", + fluidRow( + column( + width = 2, + selectizeInput( + inputId = "bivariate_lines", + label = strongMed("Position"), + choices = c(Hide = "hide", Back = "back", Front = "front"), + selected = "back" + ) + ), + column( + width = 3, + shinyjs::colourInput("bivariate_lines_color", strongMed("Color"), "gray") + ), + column( + width = 2, + sliderInput( + "bivariate_lines_alpha", + label = strongMed("Opacity"), + value = alpha_calc_lines(.nIter), + min = 0, + max = 1, + step = 0.01, + ticks = FALSE + ) + ) + ) ) ) ) diff --git a/inst/ShinyStan/ui_files/density_customize.R b/inst/ShinyStan/ui_files/density_customize.R index b23cde00..d9d3a868 100644 --- a/inst/ShinyStan/ui_files/density_customize.R +++ b/inst/ShinyStan/ui_files/density_customize.R @@ -1,103 +1,268 @@ -# This file is part of shinystan -# Copyright (C) Jonah Gabry -# -# 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 . - -shinyjs::hidden( - div(id = "density_options", - wellPanel( - class = "optionswell", - hr(class = "hroptions"), - strongBig("Transformation"), - transform_helpText("x"), - fluidRow( - column(4, transformation_selectInput("dens_transform_x")), - column(2, actionButton("dens_transform_x_go", label = "Transform", - class = "transform-go")) +shinyjs::hidden(div( + id = "density_options", + wellPanel( + class = "optionswell", + hr(class = "hroptions"), + strongBig("Transformation"), + transform_helpText("x"), + fluidRow( + column(width = 4, transformation_selectInput("dens_transform_x")), + column( + width = 2, + actionButton("dens_transform_x_go", label = "Transform", class = "transform-go") + ) + ), + hr(class = "hroptions"), + selectInput( + "dens_options_display", + label = strongBig("Control"), + choices = c("Options", "Aesthetics", "Compare to function" = "Compare"), + selected = "Options", + width = "50%" + ), + conditionalPanel( + condition = "input.dens_options_display == 'Options'", + fluidRow( + column( + width = 3, + numericInput( + "dens_chain", + label = strongMed("Chain"), + min = 0, + max = .nChains, + step = 1, + value = 0 + ) ), - hr(class = "hroptions"), - selectInput("dens_options_display", label = strongBig("Control"), - choices = c("Options", "Aesthetics", "Compare to function" = "Compare"), - selected = "Options", width = "50%"), - conditionalPanel(condition = "input.dens_options_display == 'Options'", - fluidRow( - column(3, numericInput("dens_chain", label = strongMed("Chain"), min = 0, max = .nChains, step = 1, value = 0)), - column(3, conditionalPanel(condition = "input.dens_chain == 0", - radioButtons("dens_chain_split", label = strongMed("All chains"), choices = c("Together", "Separate"), selected = "Together", inline = FALSE))), - column(3, selectInput("dens_point_est", strongMed("Point est"), choices = c("None","Mean","Median","MAP"), selected = "None")), - column(3, selectInput("dens_ci", strongMed("CI %"), choices = c("None" = "None", "50%" = 0.5, "80%" = 0.8, "95%" = 0.95), selected = "None")) - ) + column( + width = 3, + conditionalPanel( + condition = "input.dens_chain == 0", + radioButtons( + "dens_chain_split", + label = strongMed("All chains"), + choices = c("Together", "Separate"), + selected = "Together", + inline = FALSE + ) + ) ), - conditionalPanel(condition = "input.dens_options_display == 'Aesthetics'", - fluidRow( - column(3, selectInput("dens_x_breaks", strongMed("x breaks"), choices = c("None", "Some", "Many"), selected = "Some")), - column(3, shinyjs::colourInput("dens_fill_color", strongMed("Fill"), base_fill)), - column(3, shinyjs::colourInput("dens_line_color", strongMed("Line"), vline_base_clr)) - ) + column( + width = 3, + selectInput( + "dens_point_est", + strongMed("Point est"), + choices = c("None", "Mean", "Median", "MAP"), + selected = "None" + ) ), - conditionalPanel(condition = "input.dens_options_display == 'Compare'", - fluidRow( - column(4, selectInput("dens_prior", strongMed("Family"), choices = list("None", "Normal", "t", "Cauchy", "Exponential", "Gamma", "Inverse Gamma", "Beta"))), - column(2, - condPanel_dens_prior("Normal", numericInput("dens_prior_normal_mu", "Location", value = 0, step = 0.1)), - condPanel_dens_prior("t", numericInput("dens_prior_t_df", "df", value = 1, min = 0, step = 0.1) - ), - condPanel_dens_prior("Cauchy", - numericInput("dens_prior_cauchy_mu", "Location", value = 0, step = 0.1) - ), - condPanel_dens_prior("Beta", - numericInput("dens_prior_beta_shape1", "Shape1", value = 1, min = 0, step = 0.1) - ), - condPanel_dens_prior("Exponential", - numericInput("dens_prior_expo_rate", "Rate", value = 1, min = 0, step = 0.1) - ), - condPanel_dens_prior("Gamma", - numericInput("dens_prior_gamma_shape", "Shape", value = 1, min = 0, step = 0.1) - ), - condPanel_dens_prior("Inverse Gamma", - numericInput("dens_prior_inversegamma_shape", "Shape", value = 1, min = 0, step = 0.1) - ) - ), - column(2, condPanel_dens_prior("Normal", - numericInput("dens_prior_normal_sigma", "Scale", value = 1, min = 0, step = 0.1) - ), - condPanel_dens_prior("t", - numericInput("dens_prior_t_mu", "Location", value = 0, step = 0.1) - ), - condPanel_dens_prior("Cauchy", - numericInput("dens_prior_cauchy_sigma", "Scale", value = 1, min = 0, step = 0.1) - ), - condPanel_dens_prior("Beta", - numericInput("dens_prior_beta_shape2", "Shape2", value = 1, min = 0, step = 0.1) - ), - condPanel_dens_prior("Gamma", - numericInput("dens_prior_gamma_rate", "Rate", value = 1, min = 0, step = 0.1) - ), - condPanel_dens_prior("Inverse Gamma", - numericInput("dens_prior_inversegamma_scale", "Scale", value = 1, min = 0, step = 0.1) - ) - ), - column(2, - condPanel_dens_prior("t", - numericInput("dens_prior_t_sigma", "Scale", value = 1, min = 0, step = 0.1) - ) - ) - ), - condPanel_dens_together( - textInput("dens_xzoom", label = strongMed("x-axis limits"), value = "c(min, max)") - ), - br() + column( + width = 3, + selectInput( + "dens_ci", + strongMed("CI %"), + choices = c( + "None" = "None", + "50%" = 0.5, + "80%" = 0.8, + "95%" = 0.95 + ), + selected = "None" + ) ) - ) + )), + conditionalPanel( + condition = "input.dens_options_display == 'Aesthetics'", + fluidRow( + column( + width = 3, + selectInput( + "dens_x_breaks", + strongMed("x breaks"), + choices = c("None", "Some", "Many"), + selected = "Some" + ) + ), + column( + width = 3, + shinyjs::colourInput("dens_fill_color", strongMed("Fill"), base_fill) + ), + column( + width = 3, + shinyjs::colourInput("dens_line_color", strongMed("Line"), vline_base_clr) + ) + )), + conditionalPanel( + condition = "input.dens_options_display == 'Compare'", + fluidRow( + column( + width = 4, + selectInput( + "dens_prior", + strongMed("Family"), + choices = list( + "None", + "Normal", + "t", + "Cauchy", + "Exponential", + "Gamma", + "Inverse Gamma", + "Beta" + ) + )), + column( + width = 2, + condPanel_dens_prior( + "Normal", + numericInput( + "dens_prior_normal_mu", + "Location", + value = 0, + step = 0.1 + ) + ), + condPanel_dens_prior( + "t", + numericInput( + "dens_prior_t_df", + "df", + value = 1, + min = 0, + step = 0.1 + ) + ), + condPanel_dens_prior( + "Cauchy", + numericInput( + "dens_prior_cauchy_mu", + "Location", + value = 0, + step = 0.1 + ) + ), + condPanel_dens_prior( + "Beta", + numericInput( + "dens_prior_beta_shape1", + "Shape1", + value = 1, + min = 0, + step = 0.1 + ) + ), + condPanel_dens_prior( + "Exponential", + numericInput( + "dens_prior_expo_rate", + "Rate", + value = 1, + min = 0, + step = 0.1 + ) + ), + condPanel_dens_prior( + "Gamma", + numericInput( + "dens_prior_gamma_shape", + "Shape", + value = 1, + min = 0, + step = 0.1 + ) + ), + condPanel_dens_prior( + "Inverse Gamma", + numericInput( + "dens_prior_inversegamma_shape", + "Shape", + value = 1, + min = 0, + step = 0.1 + ) + ) + ), + column( + width = 2, + condPanel_dens_prior( + "Normal", + numericInput( + "dens_prior_normal_sigma", + "Scale", + value = 1, + min = 0, + step = 0.1 + ) + ), + condPanel_dens_prior( + "t", + numericInput( + "dens_prior_t_mu", + "Location", + value = 0, + step = 0.1 + ) + ), + condPanel_dens_prior( + "Cauchy", + numericInput( + "dens_prior_cauchy_sigma", + "Scale", + value = 1, + min = 0, + step = 0.1 + ) + ), + condPanel_dens_prior( + "Beta", + numericInput( + "dens_prior_beta_shape2", + "Shape2", + value = 1, + min = 0, + step = 0.1 + ) + ), + condPanel_dens_prior( + "Gamma", + numericInput( + "dens_prior_gamma_rate", + "Rate", + value = 1, + min = 0, + step = 0.1 + ) + ), + condPanel_dens_prior( + "Inverse Gamma", + numericInput( + "dens_prior_inversegamma_scale", + "Scale", + value = 1, + min = 0, + step = 0.1 + ) + ) + ), + column(width = 2, condPanel_dens_prior( + "t", + numericInput( + "dens_prior_t_sigma", + "Scale", + value = 1, + min = 0, + step = 0.1 + ) + )) + ), + condPanel_dens_together( + textInput( + "dens_xzoom", + label = strongMed("x-axis limits"), + value = "c(min, max)" + ) + ), + br() + ) ) -) +)) diff --git a/inst/ShinyStan/ui_files/diagnostics_by_parameter.R b/inst/ShinyStan/ui_files/diagnostics_by_parameter.R index bd6ea783..83f9278f 100644 --- a/inst/ShinyStan/ui_files/diagnostics_by_parameter.R +++ b/inst/ShinyStan/ui_files/diagnostics_by_parameter.R @@ -1,15 +1,25 @@ -# model parameter --------------------------------------------------------- +# model parameter div(class = "diagnostics-navlist-tabpanel", fluidRow( - column(7, help_dynamic, - dygraphOutput_175px("dynamic_trace_diagnostic_parameter_out")), - column(5, help_lines, plotOutput_200px("p_hist_out")) + column( + width = 7, + help_dynamic, + dygraphOutput_175px("dynamic_trace_diagnostic_parameter_out") + ), + column(width = 5, help_lines, plotOutput_200px("p_hist_out")) ), help_points, fluidRow( - column(6, plotOutput_200px("param_vs_lp_out"), - plotOutput_200px("param_vs_stepsize_out")), - column(6, plotOutput_200px("param_vs_accept_stat_out"), - plotOutput_200px("param_vs_treedepth_out")) - ) + column( + width = 6, + plotOutput_200px("param_vs_lp_out"), + plotOutput_200px("param_vs_stepsize_out") + ), + column( + width = 6, + plotOutput_200px("param_vs_accept_stat_out"), + plotOutput_200px("param_vs_treedepth_out") + ) + ), + br() ) \ No newline at end of file diff --git a/inst/ShinyStan/ui_files/diagnostics_customize.R b/inst/ShinyStan/ui_files/diagnostics_customize.R index de3aeab6..ad6967e6 100644 --- a/inst/ShinyStan/ui_files/diagnostics_customize.R +++ b/inst/ShinyStan/ui_files/diagnostics_customize.R @@ -1,24 +1,43 @@ div(id = "diagnostics_customize", wellPanel( fluidRow( - column(3, h4(textOutput("diagnostic_chain_text"))), - column(4, h5("Parameter")), - column(4, h5("Transformation")) + column(width = 3, h4(textOutput("diagnostic_chain_text"))), + column(width = 4, h5("Parameter")), + column(width = 4, h5("Transformation")) ), fluidRow( - column(3, div(style = "width: 100px;", - numericInput("diagnostic_chain", label = NULL, value = 0, - min = 0, - # don't allow changing chains if only 1 chain - max = ifelse(.nChains == 1, 0, .nChains)))), - column(4, selectizeInput( - inputId = "diagnostic_param", label = NULL, multiple = FALSE, - choices = .param_list, - selected = .param_list[1])), - column(3, transformation_selectInput("diagnostic_param_transform")), - column(2, actionButton("diagnostic_param_transform_go", "Transform", class = "transform-go")) + column( + width = 3, div(style = "width: 100px;", + numericInput( + "diagnostic_chain", + label = NULL, + value = 0, + min = 0, + # don't allow changing chains if only 1 chain + max = ifelse(.nChains == 1, 0, .nChains) + ) + )), + column( + width = 4, + selectizeInput( + inputId = "diagnostic_param", + label = NULL, + multiple = FALSE, + choices = .param_list, + selected = .param_list[1] + ) + ), + column( + width = 3, + transformation_selectInput("diagnostic_param_transform") + ), + column( + width = 2, + actionButton("diagnostic_param_transform_go", "Transform", class = "transform-go") + ) ), - helpText(strong(style = "color: red; font-size: 13px;", - textOutput("diagnostics_warnings_text"))) - ) -) + helpText(strong( + style = "color: red; font-size: 13px;", + textOutput("diagnostics_warnings_text") + )) + )) diff --git a/inst/ShinyStan/ui_files/diagnostics_help.R b/inst/ShinyStan/ui_files/diagnostics_help.R index abece292..5d305547 100644 --- a/inst/ShinyStan/ui_files/diagnostics_help.R +++ b/inst/ShinyStan/ui_files/diagnostics_help.R @@ -1,48 +1,47 @@ -# This file is part of shinystan -# Copyright (C) Jonah Gabry -# -# 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 . - -navlistPanel(well = FALSE, widths = c(2, 10), - id = "diagnostics_help_navlist", - tabPanel("accept_stat", - withMathJax(), - includeHTML("html/accept_stat.html"), - hr(), stan_manual() - ), - tabPanel("n_divergent", - withMathJax(), - includeHTML("html/ndivergent.html"), - hr(), stan_manual() - ), - tabPanel("stepsize", - withMathJax(), - includeHTML("html/stepsize.html"), - hr(), stan_manual() - ), - tabPanel("n_leapfrog", - withMathJax(), - includeHTML("html/nleapfrog.html"), - hr(), stan_manual() - ), - tabPanel("treedepth", - withMathJax(), - includeHTML("html/treedepth.html"), - hr(), stan_manual() - ), - tabPanel("NUTS", - withMathJax(), - includeHTML("html/nuts.html"), - hr(), stan_manual() - ) +navlistPanel( + well = FALSE, + widths = c(2, 10), + id = "diagnostics_help_navlist", + tabPanel( + "accept_stat", + withMathJax(), + includeHTML("html/accept_stat.html"), + hr(), + stan_manual() + ), + tabPanel( + "divergent", + withMathJax(), + includeHTML("html/ndivergent.html"), + hr(), + stan_manual() + ), + tabPanel( + "stepsize", + withMathJax(), + includeHTML("html/stepsize.html"), + hr(), + stan_manual() + ), + tabPanel( + "n_leapfrog", + withMathJax(), + includeHTML("html/nleapfrog.html"), + hr(), + stan_manual() + ), + tabPanel( + "treedepth", + withMathJax(), + includeHTML("html/treedepth.html"), + hr(), + stan_manual() + ), + tabPanel( + "NUTS", + withMathJax(), + includeHTML("html/nuts.html"), + hr(), + stan_manual() + ) ) diff --git a/inst/ShinyStan/ui_files/diagnostics_ndivergent.R b/inst/ShinyStan/ui_files/diagnostics_ndivergent.R index befabac7..8ec38dc1 100644 --- a/inst/ShinyStan/ui_files/diagnostics_ndivergent.R +++ b/inst/ShinyStan/ui_files/diagnostics_ndivergent.R @@ -1,9 +1,11 @@ -# N divergent ------------------------------------------------------------- +# Divergences fluidRow( - column(7, - help_dynamic, - dygraphOutput_175px("dynamic_trace_diagnostic_ndivergent_out"), - br(),br(), - plotOutput("ndivergent_vs_lp_out", height = "150px")), - column(5, plotOutput_400px("ndivergent_vs_accept_stat_out")) + column( + width = 7, + help_dynamic, + dygraphOutput_175px("dynamic_trace_diagnostic_ndivergent_out"), + br(), br(), + plotOutput("ndivergent_vs_lp_out", height = "150px") + ), + column(width = 5, plotOutput_400px("ndivergent_vs_accept_stat_out")) ) diff --git a/inst/ShinyStan/ui_files/diagnostics_sample.R b/inst/ShinyStan/ui_files/diagnostics_sample.R index 34a25acb..06c91b55 100644 --- a/inst/ShinyStan/ui_files/diagnostics_sample.R +++ b/inst/ShinyStan/ui_files/diagnostics_sample.R @@ -1,17 +1,27 @@ -# sample (accept_stat, lp) ------------------------------------------------ +# sample (accept_stat, lp) div(class = "diagnostics-navlist-tabpanel", fluidRow( - column(7, - fluidRow( - column(6, help_dynamic, - dygraphOutput_175px("dynamic_trace_diagnostic_lp_out"), - br(), - dygraphOutput_175px("dynamic_trace_diagnostic_accept_stat_out")), - column(6, help_lines, plotOutput_200px("lp_hist_out"), br(), - plotOutput_200px("accept_stat_hist_out")) - ) - ), - column(5, help_points, - plotOutput_400px("accept_stat_vs_lp_out")) - ) -) \ No newline at end of file + column( + width = 7, + fluidRow( + column( + width = 6, + help_dynamic, + dygraphOutput_175px("dynamic_trace_diagnostic_lp_out"), + br(), + dygraphOutput_175px("dynamic_trace_diagnostic_accept_stat_out") + ), + column( + width = 6, + help_lines, + plotOutput_200px("lp_hist_out"), + br(), + plotOutput_200px("accept_stat_hist_out") + ) + )), + column( + width = 5, + help_points, + plotOutput_400px("accept_stat_vs_lp_out") + ) + )) \ No newline at end of file diff --git a/inst/ShinyStan/ui_files/diagnostics_stepsize.R b/inst/ShinyStan/ui_files/diagnostics_stepsize.R index 54aa52c0..ee8e0185 100644 --- a/inst/ShinyStan/ui_files/diagnostics_stepsize.R +++ b/inst/ShinyStan/ui_files/diagnostics_stepsize.R @@ -1,8 +1,11 @@ -# stepsize ---------------------------------------------------------------- +# stepsize fluidRow( - column(7, help_dynamic, - dygraphOutput_175px("dynamic_trace_diagnostic_stepsize_out"), - br(),br(), - plotOutput("stepsize_vs_lp_out", height = "150px")), - column(5, plotOutput_400px("stepsize_vs_accept_stat_out")) + column( + width = 7, + help_dynamic, + dygraphOutput_175px("dynamic_trace_diagnostic_stepsize_out"), + br(),br(), + plotOutput("stepsize_vs_lp_out", height = "150px") + ), + column(width = 5, plotOutput_400px("stepsize_vs_accept_stat_out")) ) \ No newline at end of file diff --git a/inst/ShinyStan/ui_files/diagnostics_treedepth.R b/inst/ShinyStan/ui_files/diagnostics_treedepth.R index 64245276..985cfcdd 100644 --- a/inst/ShinyStan/ui_files/diagnostics_treedepth.R +++ b/inst/ShinyStan/ui_files/diagnostics_treedepth.R @@ -1,18 +1,20 @@ -# treedepth --------------------------------------------------------------- -div(class = "diagnostics-navlist-tabpanel", - fluidRow( - column(7, help_dynamic, - dygraphOutput_175px("dynamic_trace_diagnostic_treedepth_out"), - br(),br(), - plotOutput("treedepth_vs_lp_out", height = "150px") - ), - column(5, plotOutput_400px("treedepth_vs_accept_stat_out")) +# treedepth +div( + class = "diagnostics-navlist-tabpanel", + fluidRow( + column( + width = 7, + help_dynamic, + dygraphOutput_175px("dynamic_trace_diagnostic_treedepth_out"), + br(), br(), + plotOutput("treedepth_vs_lp_out", height = "150px") ), - splitLayout( - plotOutput("treedepth_ndivergent_hist_out", height = "125px"), - plotOutput("treedepth_ndivergent0_hist_out", height = "125px"), - plotOutput("treedepth_ndivergent1_hist_out", height = "125px") - ), - br() + column(width = 5, plotOutput_400px("treedepth_vs_accept_stat_out")) + ), + splitLayout( + plotOutput("treedepth_ndivergent_hist_out", height = "125px"), + plotOutput("treedepth_ndivergent0_hist_out", height = "125px"), + plotOutput("treedepth_ndivergent1_hist_out", height = "125px") + ), + br() ) - diff --git a/inst/ShinyStan/ui_files/dynamic_trace_helptext.R b/inst/ShinyStan/ui_files/dynamic_trace_helptext.R index 7eeec61f..857f7c19 100644 --- a/inst/ShinyStan/ui_files/dynamic_trace_helptext.R +++ b/inst/ShinyStan/ui_files/dynamic_trace_helptext.R @@ -1,24 +1,12 @@ -# This file is part of shinystan -# Copyright (C) Jonah Gabry -# -# 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 . - div( br(), - helpText(style = "font-size: 11px;", - "Use your mouse to highlight areas in the traceplot to zoom into. Double-click to reset.", - "You can also use the range selector below the graph for panning and zooming.", - "The number in the small black box in the bottom left corner controls the", em("roll period."), - "If you specify a roll period of N the resulting graph will be a moving average,", - "with each plotted point representing the average of N points in the data.") + helpText( + style = "font-size: 11px;", + "Use your mouse to highlight areas in the traceplot to zoom into. Double-click to reset.", + "You can also use the range selector below the graph for panning and zooming.", + "The number in the small black box in the bottom left corner controls the", + em("roll period."), + "If you specify a roll period of N the resulting graph will be a moving average,", + "with each plotted point representing the average of N points in the data." + ) ) diff --git a/inst/ShinyStan/ui_files/glossary.R b/inst/ShinyStan/ui_files/glossary.R index 280cd8fa..9693eda5 100644 --- a/inst/ShinyStan/ui_files/glossary.R +++ b/inst/ShinyStan/ui_files/glossary.R @@ -1,47 +1,51 @@ -div(class = "help-glossary-div", +div( + class = "help-glossary-div", + withMathJax(), + br(),br(), + div( withMathJax(), - br(),br(), - div(class = "help-glossary-nav-container", - navlistPanel(well = TRUE, id = "glossary_navlist", - tabPanel("Effective sample size", - withMathJax(), - includeHTML("html/neff.html") - ), - tabPanel("Monte Carlo uncertainty", - withMathJax(), - includeHTML("html/mcse.html") - ), - tabPanel("Rhat", - div(id = "rhat_glossary", - withMathJax(), - includeHTML("html/rhat.html") - ) - ), - tabPanel("No-U-Turn Sampler (NUTS)", - withMathJax(), - includeHTML("html/nuts.html") - ), - tabPanel("accept_stat", - withMathJax(), - includeHTML("html/accept_stat.html") - ), - tabPanel("n_divergent", - withMathJax(), - includeHTML("html/ndivergent.html") - ), - tabPanel("stepsize", - withMathJax(), - includeHTML("html/stepsize.html") - ), - tabPanel("n_leapfrog", - withMathJax(), - includeHTML("html/nleapfrog.html") - ), - tabPanel("treedepth", - withMathJax(), - includeHTML("html/treedepth.html") - ) + class = "help-glossary-nav-container", + navlistPanel( + well = TRUE, + id = "glossary_navlist", + tabPanel( + "Effective sample size", + includeHTML("html/neff.html") + ), + tabPanel( + "Monte Carlo uncertainty", + includeHTML("html/mcse.html") + ), + tabPanel( + "Rhat", + includeHTML("html/rhat.html") + ), + tabPanel( + "No-U-Turn Sampler (NUTS)", + includeHTML("html/nuts.html") + ), + tabPanel( + "accept_stat", + includeHTML("html/accept_stat.html") + ), + tabPanel( + "divergent", + withMathJax(), + includeHTML("html/ndivergent.html") + ), + tabPanel( + "stepsize", + includeHTML("html/stepsize.html") + ), + tabPanel( + "n_leapfrog", + includeHTML("html/nleapfrog.html") + ), + tabPanel( + "treedepth", + includeHTML("html/treedepth.html") + ) ) - ), - br(),br() + ), + br(),br() ) diff --git a/inst/ShinyStan/ui_files/help.R b/inst/ShinyStan/ui_files/help.R index f15d7e5e..8ac2e5bc 100644 --- a/inst/ShinyStan/ui_files/help.R +++ b/inst/ShinyStan/ui_files/help.R @@ -1,73 +1,92 @@ -# This file is part of shinystan -# Copyright (C) Jonah Gabry -# -# 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 . - -div(class = "help-glossary-div", - br(),br(), - div(class = "help-glossary-nav-container", - navlistPanel(well = TRUE, id = "help_navlist", - "Topics", - tabPanel("Questions, bugs, and new features", - div(class = "glossary-entry", - h4("Stan users group"), - p("To ask a question or suggest a new feature visit the", - a("Stan users message board.", - href = "https://groups.google.com/forum/?fromgroups#!forum/stan-users")), - br(), - h4("GitHub issue tracker"), - p("To report a bug or suggest a new feature visit the", - a("GitHub issue tracker.", - href = "https://github.com/stan-dev/shinystan/issues")) - ) - ), - tabPanel("Saving plots", - div(class = "glossary-entry", - h4("Saving plots as ggplot2 objects"), - p("Clicking on a 'Save ggplot2 object' button will be save an .RData - file that you can load into your Global Environment using the", - code("load"), "function in R. - You can then make changes to the plot using the functions in the - ggplot2 package." - ), - p("Any plot that can be saved as a ggplot2 object can also be saved - as a PDF.") - ) - ), - tabPanel("Large models and launch speed", - div(class = "glossary-entry", - h4("Launching ShinyStan faster"), - p("For large models, the", code("launch_shinystan"), - "function will launch the app quick when used with a", - "shinystan object (rather than a stanfit object)", - "because no conversion is required."), - p("If ShinyStan takes a long time to launch for your", - "model then it can help to first create a", - "shinystan object using the ", code("as.shinystan"), - "function. Alternatively, the first time you launch", - "ShinyStan using a stanfit object, a shinystan", - "object will be returned if you assign the value of", - code("launch_shinystan"), "to a name, e.g."), - p(code("sso <- launch_shinystan(my_stanfit)")), - p("rather than just"), - p(code("launch_shinystan(my_stanfit)")), - p("The next time you launch ShinyStan for the same", - "model you can launch it using", code("sso"), - "rather than", code("my_stanfit"), "and it should", - "be quicker to launch.") - ) - ) +div( + class = "help-glossary-div", + br(), br(), + div( + class = "help-glossary-nav-container", + navlistPanel( + well = TRUE, + id = "help_navlist", + "Topics", + tabPanel( + "Questions, bugs, and new features", + div( + class = "glossary-entry", + h4("Stan users group"), + p( + "To ask a question or suggest a new feature visit the", + a( + "Stan users message board.", + href = "https://groups.google.com/forum/?fromgroups#!forum/stan-users" + ) + ), + br(), + h4("GitHub issue tracker"), + p( + "To report a bug or suggest a new feature visit the", + a( + "GitHub issue tracker.", + href = "https://github.com/stan-dev/shinystan/issues" + ) + ) + ) + ), + tabPanel( + "Saving plots", + div( + class = "glossary-entry", + h4("Saving plots as ggplot2 objects"), + p( + "Clicking on a 'Save ggplot2 object' button will be save an .RData + file that you can load into your Global Environment using the", + code("load"), + "function in R. + You can then make changes to the plot using the functions in the + ggplot2 package." + ), + p( + "Any plot that can be saved as a ggplot2 object can also be saved + as a PDF." + ) + )), + tabPanel( + "Large models and launch speed", + div( + class = "glossary-entry", + h4("Launching ShinyStan faster"), + p( + "The", code("drop_parameters"), "function in the", + strong("shinystan"), "R package will allow you to reduce the size", + "of a shinystan object by removing parameters.", + "See", code("help('drop_parameters', 'shinystan')"), + "for the documentation." + ), + p( + "Additionally, for large models, the", code("launch_shinystan"), + "function will launch the app faster when used with a", + "shinystan object rather than a stanfit object", + "(because no conversion is required).", + "If ShinyStan takes a long time to launch for your", + "model then it can help to first create a", + "shinystan object using the", code("as.shinystan"), "function.", + "Alternatively, the first time you launch", + "ShinyStan using a stanfit object, a shinystan", + "object will be returned if you assign the value of", + code("launch_shinystan"), + "to a name, e.g." + ), + p(code("sso <- launch_shinystan(stanfit)")), + p("rather than just"), + p(code("launch_shinystan(stanfit)")), + p( + "The next time you launch ShinyStan for the same", + "model you can launch it using", code("sso"), "rather than", + code("stanfit"), "and it should be quicker to launch.", + "If it is still too slow then dropping some large parameters", + "from the shinystan object is the best solution." + ) + ) + ) ) - ), - br(),br() + ), + br(), br() ) diff --git a/inst/ShinyStan/ui_files/hist_customize.R b/inst/ShinyStan/ui_files/hist_customize.R index adf3cec3..f1a796cf 100644 --- a/inst/ShinyStan/ui_files/hist_customize.R +++ b/inst/ShinyStan/ui_files/hist_customize.R @@ -1,37 +1,50 @@ -# This file is part of shinystan -# Copyright (C) Jonah Gabry -# -# 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 . - -shinyjs::hidden( - div(id = "hist_options", - wellPanel( - class = "optionswell", - hr(class = "hroptions"), - strongBig("Transformation"), - transform_helpText("x"), - fluidRow( - column(4, transformation_selectInput("hist_transform_x")), - column(2, actionButton("hist_transform_x_go", label = "Transform", - class = "transform-go")) - ), - hr(class = "hroptions"), - fluidRow( - column(2, numericInput("hist_chain", label = strongMed("Chain"), min = 0, max = .nChains, step = 1, value = 0)), - column(4, sliderInput("hist_binwd", label = strongMed("Binwidth (0 = default)"), min = 0, value = 0, max = 50, step = 0.05, ticks = FALSE)), - column(3, shinyjs::colourInput("hist_fill_color", strongMed("Fill"), base_fill)), - column(3, shinyjs::colourInput("hist_line_color", strongMed("Line"), vline_base_clr)) +shinyjs::hidden(div( + id = "hist_options", + wellPanel( + class = "optionswell", + hr(class = "hroptions"), + strongBig("Transformation"), + transform_helpText("x"), + fluidRow( + column(width = 4, transformation_selectInput("hist_transform_x")), + column( + width = 2, + actionButton("hist_transform_x_go", label = "Transform", class = "transform-go") + ) + ), + hr(class = "hroptions"), + fluidRow( + column( + width = 2, + numericInput( + "hist_chain", + label = strongMed("Chain"), + min = 0, + max = .nChains, + step = 1, + value = 0 + ) + ), + column( + width = 4, + sliderInput( + "hist_binwd", + label = strongMed("Binwidth (0 = default)"), + min = 0, + value = 0, + max = 50, + step = 0.05, + ticks = FALSE ) + ), + column( + width = 3, + shinyjs::colourInput("hist_fill_color", strongMed("Fill"), base_fill) + ), + column( + width = 3, + shinyjs::colourInput("hist_line_color", strongMed("Line"), vline_base_clr) ) + ) ) -) +)) diff --git a/inst/ShinyStan/ui_files/model_code.R b/inst/ShinyStan/ui_files/model_code.R index 8ba7f2c6..39355b88 100644 --- a/inst/ShinyStan/ui_files/model_code.R +++ b/inst/ShinyStan/ui_files/model_code.R @@ -1,22 +1,38 @@ sidebarLayout( - sidebarPanel(width = 3, style = "height: 550px;", - br(), - h4("Model Code"), - helpText(style = "font-size: 12px;", - p("Model code will be displayed here each", - "time you launch ShinyStan with this shinystan object.") - ), - br(), - actionButton("save_user_model_code", label = "Save code", - icon = icon("save")), - div(style = "font-size: 11px;", textOutput("user_code_saved")), - conditionalPanel(condition = "input.save_user_model_code > 0", - br(), save_and_close_reminder("save_user_model_code_safe_quit")) + sidebarPanel( + width = 3, + style = "height: 550px;", + br(), + h4("Model Code"), + helpText( + style = "font-size: 12px;", + p( + "Model code will be displayed here each", + "time you launch ShinyStan with this shinystan object." + ) + ), + br(), + actionButton( + "save_user_model_code", + label = "Save code", + icon = icon("save") + ), + div(style = "font-size: 11px;", textOutput("user_code_saved")), + conditionalPanel( + condition = "input.save_user_model_code > 0", + br(), + save_and_close_reminder("save_user_model_code_safe_quit") + ) ), - mainPanel(width = 9, - br(),br(), - tags$textarea(id="user_model_code", wrap = "off", cols = 80, - rows = 20, .model_code) + mainPanel( + width = 9, + br(), br(), + tags$textarea( + id = "user_model_code", + wrap = "off", + cols = 80, + rows = 20, + .model_code + ) ) ) - diff --git a/inst/ShinyStan/ui_files/multiparam_customize.R b/inst/ShinyStan/ui_files/multiparam_customize.R index a54ccd21..e4ee5e98 100644 --- a/inst/ShinyStan/ui_files/multiparam_customize.R +++ b/inst/ShinyStan/ui_files/multiparam_customize.R @@ -1,56 +1,98 @@ -# This file is part of shinystan -# Copyright (C) Jonah Gabry -# -# 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 . - -absolutePanel(id = "controls_multiparam", - class = "draggable_controls", - fixed = TRUE, - top = 190, right = 20, width = 200, - draggable = TRUE, - shinyjs::hidden( - div(id = "multiparam_options", - wellPanel( - class = "optionswell", - strongBig("Parameter estimates"), - hr(class = "hroptions"), - selectInput("multiparam_options_display", label = strongBig("Control"), - choices = c("Options", "Aesthetics", "Sorting"), - selected = "Options", width = "100%"), - conditionalPanel(condition = "input.multiparam_options_display == 'Options'", - checkboxInput("param_plot_show_density", label = "Kernal density estimates", value = FALSE), - checkboxInput("param_plot_show_ci_line", label = "95% interval line", value = TRUE), - radioButtons("param_plot_point_est", label = "Point estimate", choices = c("Median", "Mean"), selected = "Median", inline = TRUE), - hr(class = "hroptions"), - downloadButton("download_multiparam_plot", "ggplot2", class = "plot-download"), - downloadButton('save_pdf_multiparam', "pdf", class = "plot-download pdf-download") - ), - conditionalPanel(condition = "input.multiparam_options_display == 'Aesthetics'", - withMathJax(), - checkboxInput("param_plot_color_by_rhat", label = "Color point est. by \\(\\hat{R}\\)", value = FALSE), - shinyjs::colourInput("param_plot_fill_color", span(style = "font-size: 12px", "Density/CI color"), "#590815"), - shinyjs::colourInput("param_plot_outline_color", span(style = "font-size: 12px", "Outline color"), "#487575"), - conditionalPanel(condition = "input.param_plot_color_by_rhat == false", - shinyjs::colourInput("param_plot_est_color", span(style = "font-size: 12px", "Point estimate color"), base_fill)), - conditionalPanel(condition = "input.param_plot_color_by_rhat == true", - selectInput("param_plot_rhat_palette", span(style = "font-size: 12px", "Rhat palette"), choices = c("Blues", "Grays", "Greens", "Oranges", "Purples", "Reds"), selected = "Blues", selectize=TRUE)) - ), - conditionalPanel(condition = "input.multiparam_options_display == 'Sorting'", - radioButtons("param_plot_sort_j", label = "Sort parameters in select list by", - choices = c(Row = TRUE, Column = FALSE), selected = TRUE, inline = TRUE), - helpText(style = "font-size: 12px;","If applicable, sort with x[1,2] before x[2,1] or vice-versa") - ) - ) - ) - ) +absolutePanel( + id = "controls_multiparam", + class = "draggable_controls", + fixed = TRUE, + top = 190, + right = 20, + width = 200, + draggable = TRUE, + shinyjs::hidden(div( + id = "multiparam_options", + wellPanel( + class = "optionswell", + strongBig("Parameter estimates"), + hr(class = "hroptions"), + selectInput( + "multiparam_options_display", + label = strongBig("Control"), + choices = c("Options", "Aesthetics", "Sorting"), + selected = "Options", + width = "100%" + ), + conditionalPanel( + condition = "input.multiparam_options_display == 'Options'", + checkboxInput( + "param_plot_show_density", + label = "Kernal density estimates", + value = FALSE + ), + checkboxInput( + "param_plot_show_ci_line", + label = "95% interval line", + value = TRUE + ), + radioButtons( + "param_plot_point_est", + label = "Point estimate", + choices = c("Median", "Mean"), + selected = "Median", + inline = TRUE + ), + hr(class = "hroptions"), + downloadButton("download_multiparam_plot", "ggplot2", class = "plot-download"), + downloadButton('save_pdf_multiparam', "pdf", class = "plot-download pdf-download") + ), + conditionalPanel( + condition = "input.multiparam_options_display == 'Aesthetics'", + withMathJax(), + checkboxInput( + "param_plot_color_by_rhat", + label = "Color point est. by \\(\\hat{R}\\)", + value = FALSE + ), + shinyjs::colourInput( + "param_plot_fill_color", + span(style = "font-size: 12px", "Density/CI color"), + "#590815" + ), + shinyjs::colourInput( + "param_plot_outline_color", + span(style = "font-size: 12px", "Outline color"), + "#487575" + ), + conditionalPanel( + condition = "input.param_plot_color_by_rhat == false", + shinyjs::colourInput( + "param_plot_est_color", + span(style = "font-size: 12px", "Point estimate color"), + base_fill + ) + ), + conditionalPanel( + condition = "input.param_plot_color_by_rhat == true", + selectInput( + "param_plot_rhat_palette", + span(style = "font-size: 12px", "Rhat palette"), + choices = c("Blues", "Grays", "Greens", "Oranges", "Purples", "Reds"), + selected = "Blues", + selectize = TRUE + ) + ) + ), + conditionalPanel( + condition = "input.multiparam_options_display == 'Sorting'", + radioButtons( + "param_plot_sort_j", + label = "Sort parameters in select list by", + choices = c(Row = TRUE, Column = FALSE), + selected = TRUE, + inline = TRUE + ), + helpText( + style = "font-size: 12px;", + "If applicable, sort with x[1,2] before x[2,1] or vice-versa" + ) + ) + ) + )) ) diff --git a/inst/ShinyStan/ui_files/notepad.R b/inst/ShinyStan/ui_files/notepad.R index 112af701..5fc4ac3e 100644 --- a/inst/ShinyStan/ui_files/notepad.R +++ b/inst/ShinyStan/ui_files/notepad.R @@ -1,23 +1,35 @@ div(id = "notepad_div", sidebarLayout( - sidebarPanel(width = 3, style = "height: 550px;", - br(), - h4("Notes"), - helpText(style = "font-size: 12px;", - p("Notes are displayed here each time you launch ShinyStan - with this shinystan object.") - ), - br(), - actionButton("save_user_model_info", label = "Save notes", - icon = icon("save")), - div(style = "font-size: 11px;", textOutput("user_text_saved")), - conditionalPanel(condition = "input.save_user_model_info > 0", - br(), save_and_close_reminder("save_user_model_info_safe_quit")) + sidebarPanel( + width = 3, + style = "height: 550px;", + br(), + h4("Notes"), + helpText( + style = "font-size: 12px;", + p("Notes are displayed here each time you launch ShinyStan with this shinystan object.") + ), + br(), + actionButton( + "save_user_model_info", + label = "Save notes", + icon = icon("save") + ), + div(style = "font-size: 11px;", textOutput("user_text_saved")), + conditionalPanel( + condition = "input.save_user_model_info > 0", + br(), + save_and_close_reminder("save_user_model_info_safe_quit") + ) ), - mainPanel(width = 9, - br(),br(), - tags$textarea(id="user_model_info", rows=20, cols=80, - .notes) + mainPanel( + width = 9, + br(), br(), + tags$textarea( + id = "user_model_info", + rows = 20, + cols = 80, + .notes + ) ) - ) -) + )) diff --git a/inst/ShinyStan/ui_files/pp_about.R b/inst/ShinyStan/ui_files/pp_about.R index fb0131f2..70352e38 100644 --- a/inst/ShinyStan/ui_files/pp_about.R +++ b/inst/ShinyStan/ui_files/pp_about.R @@ -1,38 +1,44 @@ -# This file is part of shinystan -# Copyright (C) Jonah Gabry -# -# 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 . - - - div( withMathJax(), - h3(style = "color: #337ab7;","What is posterior predictive checking?"), - p(strong("The idea behind posterior predictive checking is simple:")), - p(style = "text-indent: 10px", - em("If our model is a good fit then we should be able to use it to generate")), - p(style = "text-indent: 10px", em("data that looks a lot like the data we observed.")), + h3(style = "color: #337ab7;", "What is posterior predictive checking?"), + p( + strong("The idea behind posterior predictive checking is simple:") + ), + p( + style = "text-indent: 10px", + em("If our model is a good fit then we should be able to use it to generate") + ), + p( + style = "text-indent: 10px", + em("data that looks a lot like the data we observed.") + ), br(), - p("To generate this 'replicated' data we use the", - em("posterior predictive distribution")), - span(style = "color: #337ab7; font-face: bold;", withMathJax("$$ p(y^{rep} | y ) = \\int p(y^{rep} | \\theta) p(\\theta | y ) d \\theta,$$")), - p("where \\(y\\) is the observed data and \\(\\theta\\) the parameters in our model."), + p( + "To generate this 'replicated' data we use the", + em("posterior predictive distribution") + ), + span( + style = "color: #337ab7; font-face: bold;", + withMathJax( + "$$ p(y^{rep} | y ) = \\int p(y^{rep} | \\theta) p(\\theta | y ) d \\theta,$$" + ) + ), + p( + "where \\(y\\) is the observed data and \\(\\theta\\) the parameters in our model." + ), br(), - p("For each draw of \\(\\theta\\) from the posterior \\(p(\\theta | y) \\) - we simulate data \\(y^{rep}\\) from the posterior predictive distribution \\(p(y^{rep} | y) \\)."), + p( + "For each draw of \\(\\theta\\) from the posterior \\(p(\\theta | y) \\) + we simulate data \\(y^{rep}\\) from the posterior predictive distribution \\(p(y^{rep} | y) \\)." + ), br(), - p("Using the simulations of \\(y^{rep}\\) we can make various - graphical displays comparing our observed data to the replications."), + p( + "Using the simulations of \\(y^{rep}\\) we can make various + graphical displays comparing our observed data to the replications." + ), hr(), - helpText("For a more thorough discussion of posterior predictive checking see Chapter 6 of", a("BDA3.", href = "http://www.stat.columbia.edu/~gelman/book/")) + helpText( + "For a more thorough discussion of posterior predictive checking see Chapter 6 of", + a("BDA3.", href = "http://www.stat.columbia.edu/~gelman/book/") + ) ) diff --git a/inst/ShinyStan/ui_files/pp_navlist.R b/inst/ShinyStan/ui_files/pp_navlist.R index 1b8d5746..c3d4931f 100644 --- a/inst/ShinyStan/ui_files/pp_navlist.R +++ b/inst/ShinyStan/ui_files/pp_navlist.R @@ -1,90 +1,128 @@ -# This file is part of shinystan -# Copyright (C) Jonah Gabry -# -# 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 . - -navlistPanel(id = "pp_navlist", widths = c(3,9), well = TRUE, - tabPanel("Select data", - div( - br(), - uiOutput("ui_pp_get_y"), - br(), - uiOutput("ui_pp_get_yrep") - ) - ), - "Plots", - tabPanel("Distribution of observed data vs replications", - div( - br(), - h4(withMathJax(plot_descriptions["plot_hists_rep_vs_obs"])), - br(), - actionButton("resample_hist_go", label = "Show different replications", icon = icon("refresh")), - fluidRow( - column(5, radioButtons("pp_hists_rep_vs_obs_type", label = "", choices = list(Histograms = "histogram", Densities = "density"), inline = TRUE)), - column(4, - conditionalPanel(condition = "input.pp_hists_rep_vs_obs_type == 'density'", - radioButtons("pp_hists_rep_vs_obs_overlay", label = "", choices = list(Separate = FALSE, Overlay = TRUE), selected = FALSE, inline = TRUE) - )) - ), - plotOutput("pp_hists_rep_vs_obs_out", width = "90%"), - br() - ) - ), - tabPanel("Distributions of test statistics", - div( - br(), - h4(withMathJax(plot_descriptions["plot_test_statistics"])), - helpText("The blue lines show \\(T(y)\\), the value of the statistic computed from the observed data."), - radioButtons("pp_hists_test_statistics_type", label = "", choices = list(Histograms = "histogram", Densities = "density"), inline = TRUE), - fluidRow( - column(6, plotOutput("pp_hists_test_statistics_mean_out", height = "200px")), - column(6, plotOutput("pp_hists_test_statistics_sd_out", height = "200px")) - ), - br(), - fluidRow( - column(6, plotOutput("pp_hists_test_statistics_min_out", height = "200px")), - column(6, plotOutput("pp_hists_test_statistics_max_out", height = "200px")) - ), - br() - ) - ), - tabPanel("Scatterplots", - div( - br(), - h4(withMathJax(plot_descriptions["plot_obs_vs_avg_y_rep"])), - checkboxInput("pp_zoom_to_zero", "Zoom to include (0,0)", value = FALSE), - plotOutput("pp_y_vs_avg_rep_out", height = "250px", width = "80%"), - # h5(withMathJax(plot_descriptions["plot_avg_rep_vs_avg_resid_rep"])), - # plotOutput("pp_avg_rep_vs_avg_resid_rep_out", height = "250px", width = "80%"), - br() - ) - ), - tabPanel("Histograms of residuals", - div( - br(), - h4(withMathJax(plot_descriptions["plot_hist_resids"])), - br(), - actionButton("resample_resids_go", label = "Show a different replication", icon = icon("refresh")), - br(),br(), - plotOutput("pp_hist_resids_out", height = "250px", width = "75%") - ) - ), - "About", - tabPanel("About graphical posterior predictive checking", - source(file.path("ui_files", "pp_about.R"), local = TRUE)$value - ), - tabPanel("Tutorial", - includeMarkdown("markdown/pp_check_tutorial.md") - ) - +navlistPanel( + id = "pp_navlist", + widths = c(3, 9), + well = TRUE, + tabPanel( + "Select data", + div( + br(), + uiOutput("ui_pp_get_y"), + br(), + uiOutput("ui_pp_get_yrep") + ) + ), + "Plots", + tabPanel( + "Distribution of observed data vs replications", + div( + br(), + h4(withMathJax(plot_descriptions["plot_hists_rep_vs_obs"])), + br(), + actionButton( + "resample_hist_go", + label = "Show different replications", + icon = icon("refresh") + ), + fluidRow( + column( + width = 5, + radioButtons( + "pp_hists_rep_vs_obs_type", + label = "", + choices = list(Histograms = "histogram", Densities = "density"), + inline = TRUE + ) + ), + column( + width = 4, + conditionalPanel( + condition = "input.pp_hists_rep_vs_obs_type == 'density'", + radioButtons( + "pp_hists_rep_vs_obs_overlay", + label = "", + choices = list(Separate = FALSE, Overlay = TRUE), + selected = FALSE, + inline = TRUE + ) + ) + ) + ), + plotOutput("pp_hists_rep_vs_obs_out", width = "90%"), + br() + ) + ), + tabPanel( + "Distributions of test statistics", + div( + br(), + h4(withMathJax(plot_descriptions["plot_test_statistics"])), + helpText( + "The blue lines show \\(T(y)\\), the value of the statistic computed from the observed data." + ), + radioButtons( + "pp_hists_test_statistics_type", + label = "", + choices = list(Histograms = "histogram", Densities = "density"), + inline = TRUE + ), + fluidRow( + column( + width = 6, + plotOutput("pp_hists_test_statistics_mean_out", height = "200px") + ), + column( + width = 6, + plotOutput("pp_hists_test_statistics_sd_out", height = "200px") + ) + ), + br(), + fluidRow( + column( + width = 6, + plotOutput("pp_hists_test_statistics_min_out", height = "200px") + ), + column( + width = 6, + plotOutput("pp_hists_test_statistics_max_out", height = "200px") + ) + ), + br() + ) + ), + tabPanel( + "Scatterplots", + div( + br(), + h4(withMathJax(plot_descriptions["plot_obs_vs_avg_y_rep"])), + checkboxInput("pp_zoom_to_zero", "Zoom to include (0,0)", value = FALSE), + plotOutput("pp_y_vs_avg_rep_out", height = "250px", width = "80%"), + # h5(withMathJax(plot_descriptions["plot_avg_rep_vs_avg_resid_rep"])), + # plotOutput("pp_avg_rep_vs_avg_resid_rep_out", height = "250px", width = "80%"), + br() + ) + ), + tabPanel( + "Histograms of residuals", + div( + br(), + h4(withMathJax(plot_descriptions["plot_hist_resids"])), + br(), + actionButton( + "resample_resids_go", + label = "Show a different replication", + icon = icon("refresh") + ), + br(),br(), + plotOutput("pp_hist_resids_out", height = "250px", width = "75%") + ) + ), + "About", + tabPanel( + "About graphical posterior predictive checking", + source(file.path("ui_files", "pp_about.R"), local = TRUE)$value + ), + tabPanel( + "Tutorial", + includeMarkdown("markdown/pp_check_tutorial.md") + ) ) diff --git a/inst/ShinyStan/ui_files/pp_navlist_rstanarm.R b/inst/ShinyStan/ui_files/pp_navlist_rstanarm.R index 779489dd..2c0b0852 100644 --- a/inst/ShinyStan/ui_files/pp_navlist_rstanarm.R +++ b/inst/ShinyStan/ui_files/pp_navlist_rstanarm.R @@ -1,69 +1,84 @@ -# This file is part of shinystan -# Copyright (C) Jonah Gabry -# -# 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 . - -navlistPanel(id = "pp_navlist", widths = c(3,9), well = TRUE, - tabPanel("Distribution of observed data vs replications", - div( - br(), - h4(withMathJax(plot_descriptions["plot_hists_rep_vs_obs"])), - br(), - # actionButton("resample_go", label = "Show different replications", icon = icon("refresh")), - fluidRow( - column(5, radioButtons("pp_rep_vs_obs_overlay_rstanarm", label = "", choices = list(Histograms = "histograms", "Overlaid Densities" = "density"), inline = TRUE)) - ), - plotOutput("pp_rep_vs_obs_out_rstanarm"), - br() - ) - ), - tabPanel("Distributions of test statistics", - div( - br(), - h4(withMathJax(plot_descriptions["plot_test_statistics"])), - helpText("The blue lines show \\(T(y)\\), the value of the statistic computed from the observed data."), - fluidRow( - column(6, plotOutput("pp_hists_test_statistics_mean_out_rstanarm", height = "200px")), - column(6, plotOutput("pp_hists_test_statistics_sd_out_rstanarm", height = "200px")) - ), - br(), - fluidRow( - column(6, plotOutput("pp_hists_test_statistics_min_out_rstanarm", height = "200px")), - column(6, plotOutput("pp_hists_test_statistics_max_out_rstanarm", height = "200px")) - ), - br() - ) - ), - tabPanel("Scatterplots", - div( - br(), - h4(withMathJax(plot_descriptions["plot_obs_vs_avg_y_rep"])), - plotOutput("pp_y_vs_avg_rep_out_rstanarm"), - br() - ) - ), - tabPanel("Histograms of residuals", - div( - br(), - h4(withMathJax(plot_descriptions["plot_hist_resids"])), - # br(), - # actionButton("resample_resids_go", label = "Show a different replication", icon = icon("refresh")), - # br(),br(), - plotOutput("pp_hist_resids_out_rstanarm") - ) - ), - "About", - tabPanel("About graphical posterior predictive checking", - source(file.path("ui_files", "pp_about.R"), local = TRUE)$value - ) +navlistPanel( + id = "pp_navlist", + widths = c(3, 9), + well = TRUE, + tabPanel( + "Distribution of observed data vs replications", + div( + br(), + h4(withMathJax(plot_descriptions["plot_hists_rep_vs_obs"])), + br(), + # actionButton("resample_go", label = "Show different replications", icon = icon("refresh")), + fluidRow( + column( + width = 5, + radioButtons( + "pp_rep_vs_obs_overlay_rstanarm", + label = "", + choices = list(Histograms = "histograms", "Overlaid Densities" = "density"), + inline = TRUE + ) + ) + ), + plotOutput("pp_rep_vs_obs_out_rstanarm"), + br() + ) + ), + tabPanel( + "Distributions of test statistics", + div( + br(), + h4(withMathJax(plot_descriptions["plot_test_statistics"])), + helpText( + "The blue lines show \\(T(y)\\), the value of the statistic computed from the observed data." + ), + fluidRow( + column( + width = 6, + plotOutput("pp_hists_test_statistics_mean_out_rstanarm", height = "200px") + ), + column( + width = 6, + plotOutput("pp_hists_test_statistics_sd_out_rstanarm", height = "200px") + ) + ), + br(), + fluidRow( + column( + width = 6, + plotOutput("pp_hists_test_statistics_min_out_rstanarm", height = "200px") + ), + column( + width = 6, + plotOutput("pp_hists_test_statistics_max_out_rstanarm", height = "200px") + ) + ), + br() + ) + ), + tabPanel( + "Scatterplots", + div( + br(), + h4(withMathJax(plot_descriptions["plot_obs_vs_avg_y_rep"])), + plotOutput("pp_y_vs_avg_rep_out_rstanarm"), + br() + ) + ), + tabPanel( + "Histograms of residuals", + div( + br(), + h4(withMathJax(plot_descriptions["plot_hist_resids"])), + # br(), + # actionButton("resample_resids_go", label = "Show a different replication", icon = icon("refresh")), + # br(),br(), + plotOutput("pp_hist_resids_out_rstanarm") + ) + ), + "About", + tabPanel( + "About graphical posterior predictive checking", + source(file.path("ui_files", "pp_about.R"), local = TRUE)$value + ) ) diff --git a/inst/ShinyStan/ui_files/rhat_neff_mcse_layout.R b/inst/ShinyStan/ui_files/rhat_neff_mcse_layout.R index f31435bb..6ec2d58b 100644 --- a/inst/ShinyStan/ui_files/rhat_neff_mcse_layout.R +++ b/inst/ShinyStan/ui_files/rhat_neff_mcse_layout.R @@ -1,49 +1,90 @@ -sidebarLayout(position = "right", - sidebarPanel(width = 3, class = "optionswell", - strongBig("Definitions"), - hr(class = "hroptions"), - div(actionLink("open_quick_mcse", "mcse (se_mean)")), - div(actionLink("open_quick_neff", "n_eff (ESS)")), - div(actionLink("open_quick_rhat", "Rhat")), - br(), - strongBig("Warnings"), - hr(class = "hroptions"), - withMathJax(), - sliderInput("n_eff_threshold", "\\(n_{eff} / N\\) warning threshold", - ticks = FALSE, value = 10, min = 0, max = 100, step = 5, post = "%"), - sliderInput("mcse_threshold", "\\(\\text{se}_{mean} / sd\\) warning threshold", - ticks = FALSE, value = 10, min = 0, max = 100, step = 5, post = "%"), - sliderInput("rhat_threshold", "\\(\\hat{R}\\) warning threshold", - ticks = FALSE, value = 1.1, min = 1, max = 1.2, step = 0.01) - +sidebarLayout( + position = "right", + sidebarPanel( + width = 3, + class = "optionswell", + strongBig("Definitions"), + hr(class = "hroptions"), + div(actionLink("open_quick_mcse", "mcse (se_mean)")), + div(actionLink("open_quick_neff", "n_eff (ESS)")), + div(actionLink("open_quick_rhat", "Rhat")), + br(), + strongBig("Warnings"), + hr(class = "hroptions"), + withMathJax(), + sliderInput( + "n_eff_threshold", + "\\(n_{eff} / N\\) warning threshold", + ticks = FALSE, + value = 10, + min = 0, + max = 100, + step = 5, + post = "%" + ), + sliderInput( + "mcse_threshold", + "\\(\\text{se}_{mean} / sd\\) warning threshold", + ticks = FALSE, + value = 10, + min = 0, + max = 100, + step = 5, + post = "%" + ), + sliderInput( + "rhat_threshold", + "\\(\\hat{R}\\) warning threshold", + ticks = FALSE, + value = 1.1, + min = 1, + max = 1.2, + step = 0.01 + ) ), - mainPanel(width = 9, - withMathJax(), - br(), - splitLayout(h4("\\(n_{eff} / N\\)", align = "center"), - h4("\\(mcse / sd\\)", align = "center"), - h4("\\(\\hat{R}\\)", align = "center") - ), - splitLayout( - plotOutput("n_eff_plot_out", height = "200px"), - plotOutput("mcse_over_sd_plot_out", height = "200px"), - plotOutput("rhat_plot_out", height = "200px") - ), - hr(), - div( - fluidRow( - column(4, strong(textOutput("n_eff_warnings_title"))), - column(4, strong(textOutput("mcse_over_sd_warnings_title"))), - column(4, strong(textOutput("rhat_warnings_title"))) - ), - tags$style(type="text/css", "#n_eff_warnings_title, #rhat_warnings_title, #mcse_over_sd_warnings_title {font-size: 13px;}"), - br(), - fluidRow( - column(4, div(style = "color: #006dcc;", textOutput("n_eff_warnings"))), - column(4, div(style = "color: #006dcc;", textOutput("mcse_over_sd_warnings"))), - column(4, div(style = "color: #006dcc;", textOutput("rhat_warnings"))) - ), - tags$style(type="text/css", "#n_eff_warnings, #rhat_warnings, #mcse_over_sd_warnings {font-size: 12px;}") - ) + mainPanel( + width = 9, + withMathJax(), + br(), + splitLayout( + h4("\\(n_{eff} / N\\)", align = "center"), + h4("\\(mcse / sd\\)", align = "center"), + h4("\\(\\hat{R}\\)", align = "center") + ), + splitLayout( + plotOutput("n_eff_plot_out", height = "200px"), + plotOutput("mcse_over_sd_plot_out", height = "200px"), + plotOutput("rhat_plot_out", height = "200px") + ), + hr(), + div( + fluidRow( + column(width = 4, strong(textOutput( + "n_eff_warnings_title" + ))), + column(width = 4, strong( + textOutput("mcse_over_sd_warnings_title") + )), + column(width = 4, strong(textOutput( + "rhat_warnings_title" + ))) + ), + tags$style( + type = "text/css", + "#n_eff_warnings_title, #rhat_warnings_title, #mcse_over_sd_warnings_title {font-size: 13px;}" + ), + br(), + fluidRow( + column(width = 4, div(style = "color: #006dcc;", textOutput("n_eff_warnings"))), + column(width = 4, div( + style = "color: #006dcc;", textOutput("mcse_over_sd_warnings") + )), + column(width = 4, div(style = "color: #006dcc;", textOutput("rhat_warnings"))) + ), + tags$style( + type = "text/css", + "#n_eff_warnings, #rhat_warnings, #mcse_over_sd_warnings {font-size: 12px;}" + ) + ) ) ) \ No newline at end of file diff --git a/inst/ShinyStan/ui_files/sampler_stats_customize.R b/inst/ShinyStan/ui_files/sampler_stats_customize.R index f0e730f0..959b6d84 100644 --- a/inst/ShinyStan/ui_files/sampler_stats_customize.R +++ b/inst/ShinyStan/ui_files/sampler_stats_customize.R @@ -1,29 +1,36 @@ -# This file is part of shinystan -# Copyright (C) Jonah Gabry -# -# 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 . - - fluidRow( - column(3, radioButtons("sampler_warmup", label = h5("Warmup"), - choices = list(Omit = "omit", Include = "include"), - inline = TRUE) + column( + width = 3, + radioButtons( + "sampler_warmup", + label = h5("Warmup"), + choices = list(Omit = "omit", Include = "include"), + inline = TRUE + ) ), - column(4, radioButtons("sampler_report", label = h5("Statistic"), - choices = list(Mean = "average", SD = "sd", - Max = "maximum", Min = "minimum"), - inline = TRUE) + column( + width = 4, + radioButtons( + "sampler_report", + label = h5("Statistic"), + choices = list( + Mean = "average", + SD = "sd", + Max = "maximum", + Min = "minimum" + ), + inline = TRUE + ) ), - column(2, numericInput("sampler_digits", label = h5("Decimals"), value = 4, - min = 0, max = 10, step = 1)) + column( + width = 2, + numericInput( + "sampler_digits", + label = h5("Decimals"), + value = 4, + min = 0, + max = 10, + step = 1 + ) + ) ) diff --git a/inst/ShinyStan/ui_files/table_customize.R b/inst/ShinyStan/ui_files/table_customize.R index e82f9c5d..fad8ac4f 100644 --- a/inst/ShinyStan/ui_files/table_customize.R +++ b/inst/ShinyStan/ui_files/table_customize.R @@ -1,30 +1,23 @@ -# This file is part of shinystan -# Copyright (C) Jonah Gabry -# -# 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 . - fluidRow( - column(4, - helpText(style = "margin-bottom: 2px;", "Table tips:"), - helpText(style = "margin-top: 2px; font-size: 11px;", - "Drag column names to rearrange the table columns." - )), - column(2, offset = 4, - div( - strong(id = "table_digits_txt", "Digits"), - numericInput("table_digits", label = NULL, - value = 1, min = 0, max = 7, step = 1) - ) + column( + width = 4, + helpText(style = "margin-bottom: 2px;", "Table tips:"), + helpText(style = "margin-top: 2px; font-size: 11px;", "Drag column names to rearrange the table columns.") ), - column(2, a_glossary("open_glossary_from_table")) + column( + width = 2, + offset = 4, + div( + strong(id = "table_digits_txt", "Digits"), + numericInput( + "table_digits", + label = NULL, + value = 1, + min = 0, + max = 7, + step = 1 + ) + ) + ), + column(width = 2, a_glossary("open_glossary_from_table")) ) \ No newline at end of file diff --git a/inst/ShinyStan/ui_files/table_latex_main.R b/inst/ShinyStan/ui_files/table_latex_main.R index f7d87a41..91dc7dc8 100644 --- a/inst/ShinyStan/ui_files/table_latex_main.R +++ b/inst/ShinyStan/ui_files/table_latex_main.R @@ -1,6 +1,10 @@ -mainPanel(width = 8, - actionButton("tex_go", withMathJax("Update \\(\\LaTeX\\)"), - icon = icon("print", lib = "glyphicon")), - br(),br(), - verbatimTextOutput("summary_stats_latex_out") +mainPanel( + width = 8, + actionButton( + "tex_go", + withMathJax("Update \\(\\LaTeX\\)"), + icon = icon("print", lib = "glyphicon") + ), + br(), br(), + verbatimTextOutput("summary_stats_latex_out") ) \ No newline at end of file diff --git a/inst/ShinyStan/ui_files/table_latex_sidebar.R b/inst/ShinyStan/ui_files/table_latex_sidebar.R index abc6b30e..0f9132b0 100644 --- a/inst/ShinyStan/ui_files/table_latex_sidebar.R +++ b/inst/ShinyStan/ui_files/table_latex_sidebar.R @@ -1,22 +1,49 @@ -sidebarPanel(width = 4, - h4(strong(withMathJax("\\(\\LaTeX\\) table generator"))), - selectInput("tex_params", width = "100%", - label = "Parameters (blank = all)", multiple = TRUE, - choices = .param_list_with_groups, - selected = if (length(.param_names) == 1) .param_names else .param_names[1:2]), - numericInput("tex_digits", label = "Digits", value = 1, min = 0), - div(style = "padding: 1px;", - checkboxGroupInput("tex_columns", label = "Columns", - choices = c("Rhat", "Effective sample size" = "n_eff", "Posterior mean" = "mean", - "Posterior standard deviation" = "sd", "Monte Carlo error" = "se_mean", - "Quantile: 2.5%" = "2.5%", "Quantile: 25%" = "25%", "Quantile: 50%" = "50%", - "Quantile: 75%" = "75%", "Quantile: 97.5%" = "97.5%"), - selected = c("Rhat", "n_eff", "mean", "sd", "2.5%", "50%", "97.5%")) - ), - textInput("tex_caption", label = "Caption"), - checkboxGroupInput("tex_pkgs", "Packages", - choices = c("Booktabs", "Longtable"), - selected = "Booktabs", inline = TRUE - ), - br() -) \ No newline at end of file +sidebarPanel( + width = 4, + h4(strong( + withMathJax("\\(\\LaTeX\\) table generator") + )), + selectInput( + "tex_params", + width = "100%", + label = "Parameters (blank = all)", + multiple = TRUE, + choices = .param_list_with_groups, + selected = if (length(.param_names) == 1) .param_names else .param_names[1:2] + ), + numericInput( + "tex_digits", + label = "Digits", + value = 1, + min = 0 + ), + div( + style = "padding: 1px;", + checkboxGroupInput( + "tex_columns", + label = "Columns", + choices = c( + "Rhat", + "Effective sample size" = "n_eff", + "Posterior mean" = "mean", + "Posterior standard deviation" = "sd", + "Monte Carlo error" = "se_mean", + "Quantile: 2.5%" = "2.5%", + "Quantile: 25%" = "25%", + "Quantile: 50%" = "50%", + "Quantile: 75%" = "75%", + "Quantile: 97.5%" = "97.5%" + ), + selected = c("Rhat", "n_eff", "mean", "sd", "2.5%", "50%", "97.5%") + ) + ), + textInput("tex_caption", label = "Caption"), + checkboxGroupInput( + "tex_pkgs", + "Packages", + choices = c("Booktabs", "Longtable"), + selected = "Booktabs", + inline = TRUE + ), + br() +) diff --git a/inst/ShinyStan/ui_files/trivariate_customize.R b/inst/ShinyStan/ui_files/trivariate_customize.R index 160bd729..ffa64da6 100644 --- a/inst/ShinyStan/ui_files/trivariate_customize.R +++ b/inst/ShinyStan/ui_files/trivariate_customize.R @@ -1,46 +1,70 @@ -# This file is part of shinystan -# Copyright (C) Jonah Gabry -# -# 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 . - -shinyjs::hidden( - div(id = "trivariate_options", - wellPanel( - class = "optionswell", - hr(class = "hroptions"), - strongBig("Transformation"), - transform_helpText("x,y,z"), - fluidRow( - column(3, transformation_selectInput("trivariate_transform_x")), - column(3, transformation_selectInput("trivariate_transform_y")), - column(3, transformation_selectInput("trivariate_transform_z")), - column(2, actionButton("trivariate_transform_go", label = "Transform", - class = "transform-go")) - ), - hr(class = "hroptions"), - fluidRow( - column(3, shinyjs::colourInput("trivariate_pt_color", strongMed("Color"), - value = base_fill)), - column(3, sliderInput("trivariate_pt_size", strongMed("Size"), - value = 0.5, min = 0, max = 2, step = 0.1, ticks = FALSE)), - column(2, radioButtons("trivariate_grid", strongMed("Grid"), - choices = list(Show = "show", Hide = "hide"), - selected = "show", inline = FALSE)), - column(2, radioButtons("trivariate_flip", strongMed("y-axis"), - choices = list(Normal = "normal", Flipped = "flip"), - selected = "normal", inline = FALSE)) +shinyjs::hidden(div( + id = "trivariate_options", + wellPanel( + class = "optionswell", + hr(class = "hroptions"), + strongBig("Transformation"), + transform_helpText("x,y,z"), + fluidRow( + column( + width = 3, + transformation_selectInput("trivariate_transform_x") + ), + column( + width = 3, + transformation_selectInput("trivariate_transform_y") + ), + column( + width = 3, + transformation_selectInput("trivariate_transform_z") + ), + column( + width = 2, + actionButton( + "trivariate_transform_go", + label = "Transform", + class = "transform-go" ) ) + ), + hr(class = "hroptions"), + fluidRow( + column( + width = 3, + shinyjs::colourInput("trivariate_pt_color", strongMed("Color"), value = base_fill) + ), + column( + width = 3, + sliderInput( + "trivariate_pt_size", + strongMed("Size"), + value = 0.5, + min = 0, + max = 2, + step = 0.1, + ticks = FALSE + ) + ), + column( + width = 2, + radioButtons( + "trivariate_grid", + strongMed("Grid"), + choices = list(Show = "show", Hide = "hide"), + selected = "show", + inline = FALSE + ) + ), + column( + width = 2, + radioButtons( + "trivariate_flip", + strongMed("y-axis"), + choices = list(Normal = "normal", Flipped = "flip"), + selected = "normal", + inline = FALSE + ) + ) + ) ) -) - +)) diff --git a/inst/ShinyStan/ui_files/trivariate_select.R b/inst/ShinyStan/ui_files/trivariate_select.R index 5fc07d9e..1f506540 100644 --- a/inst/ShinyStan/ui_files/trivariate_select.R +++ b/inst/ShinyStan/ui_files/trivariate_select.R @@ -1,9 +1,26 @@ fluidRow( - column(3, uiOutput("ui_trivariate_select_x")), - column(3, selectizeInput("trivariate_param_y", label = strong_bl("y-axis"), - choices = .param_list, selected = .param_list[1L], - multiple = FALSE)), - column(3, selectizeInput("trivariate_param_z", label = strong_bl("z-axis"), - choices = rev(.param_list), - multiple = FALSE)) + column( + width = 3, + uiOutput("ui_trivariate_select_x") + ), + column( + width = 3, + selectizeInput( + "trivariate_param_y", + label = strong_bl("y-axis"), + choices = .param_list, + selected = if (length(unlist(.param_list)) > 1) + unlist(.param_list)[2] else unlist(.param_list)[1], + multiple = FALSE + ) + ), + column( + width = 3, + selectizeInput( + "trivariate_param_z", + label = strong_bl("z-axis"), + choices = rev(.param_list), + multiple = FALSE + ) + ) ) \ No newline at end of file diff --git a/inst/ShinyStan/ui_utils.R b/inst/ShinyStan/ui_utils.R new file mode 100644 index 00000000..f09add6a --- /dev/null +++ b/inst/ShinyStan/ui_utils.R @@ -0,0 +1,220 @@ +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 or the sliders to select areas 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 ------------------------------------- +.model_name <- + slot(shinystan:::.sso_env[[".SHINYSTAN_OBJECT"]], "model_name") +.param_names <- + slot(shinystan:::.sso_env[[".SHINYSTAN_OBJECT"]], "param_names") +.param_list <- + .make_param_list(shinystan:::.sso_env[[".SHINYSTAN_OBJECT"]]) +.param_list_with_groups <- + .make_param_list_with_groups(shinystan:::.sso_env[[".SHINYSTAN_OBJECT"]]) +.nChains <- + slot(shinystan:::.sso_env[[".SHINYSTAN_OBJECT"]], "n_chain") +.nIter <- + slot(shinystan:::.sso_env[[".SHINYSTAN_OBJECT"]], "n_iter") +.nWarmup <- + slot(shinystan:::.sso_env[[".SHINYSTAN_OBJECT"]], "n_warmup") +.model_code <- + slot(shinystan:::.sso_env[[".SHINYSTAN_OBJECT"]], "model_code") +.notes <- + slot(shinystan:::.sso_env[[".SHINYSTAN_OBJECT"]], "user_model_info") +.has_rstanarm_ppcs <- + isTRUE(shinystan:::.sso_env[[".SHINYSTAN_OBJECT"]]@misc$stanreg) && + !is.null(shinystan:::.sso_env[[".SHINYSTAN_OBJECT"]]@misc$pp_check_plots) + +if (exists("object")) + rm(object) +gc() diff --git a/man-roxygen/args-sso.R b/man-roxygen/args-sso.R new file mode 100644 index 00000000..356ff527 --- /dev/null +++ b/man-roxygen/args-sso.R @@ -0,0 +1 @@ +#' @param sso A \code{\link[=as.shinystan]{shinystan object}}. diff --git a/man-roxygen/seealso-as.shinystan.R b/man-roxygen/seealso-as.shinystan.R new file mode 100644 index 00000000..a8ed30bd --- /dev/null +++ b/man-roxygen/seealso-as.shinystan.R @@ -0,0 +1 @@ +#' @seealso \code{\link{as.shinystan}} for creating shinystan objects. diff --git a/man-roxygen/seealso-demo.R b/man-roxygen/seealso-demo.R new file mode 100644 index 00000000..71fe3ed7 --- /dev/null +++ b/man-roxygen/seealso-demo.R @@ -0,0 +1 @@ +#' @seealso \code{\link{launch_shinystan_demo}} to try a demo. diff --git a/man-roxygen/seealso-drop_parameters.R b/man-roxygen/seealso-drop_parameters.R new file mode 100644 index 00000000..fffa9631 --- /dev/null +++ b/man-roxygen/seealso-drop_parameters.R @@ -0,0 +1,2 @@ +#' @seealso \code{\link{drop_parameters}} to remove parameters from a shinystan +#' object. diff --git a/man-roxygen/seealso-generate_quantity.R b/man-roxygen/seealso-generate_quantity.R new file mode 100644 index 00000000..84d0b939 --- /dev/null +++ b/man-roxygen/seealso-generate_quantity.R @@ -0,0 +1,2 @@ +#' @seealso \code{\link{generate_quantity}} to add a new quantity to a shinystan +#' object. diff --git a/man-roxygen/seealso-launch.R b/man-roxygen/seealso-launch.R new file mode 100644 index 00000000..b612ae62 --- /dev/null +++ b/man-roxygen/seealso-launch.R @@ -0,0 +1,2 @@ +#' @seealso \code{\link{launch_shinystan}} to launch the ShinyStan interface +#' using a particular shinystan object. diff --git a/man-roxygen/seealso-update_sso.R b/man-roxygen/seealso-update_sso.R new file mode 100644 index 00000000..c553be6c --- /dev/null +++ b/man-roxygen/seealso-update_sso.R @@ -0,0 +1,2 @@ +#' @seealso \code{\link{update_sso}} to update a shinystan object created by a +#' previous version of the package. diff --git a/man/as.shinystan.Rd b/man/as.shinystan.Rd index 6c8a5808..4ca789e8 100644 --- a/man/as.shinystan.Rd +++ b/man/as.shinystan.Rd @@ -1,99 +1,174 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/as.shinystan.R +% Please edit documentation in R/shinystan-objects.R +\docType{methods} \name{as.shinystan} \alias{as.shinystan} +\alias{as.shinystan,array-method} +\alias{as.shinystan,list-method} +\alias{as.shinystan,mcmc.list-method} +\alias{as.shinystan,stanfit-method} +\alias{as.shinystan,stanreg-method} \alias{is.shinystan} \title{Create and test shinystan objects} \usage{ as.shinystan(X, ...) -is.shinystan(object) +is.shinystan(X) + +\S4method{as.shinystan}{array}(X, model_name = "unnamed model", burnin = 0, + param_dims = list(), model_code = NULL, note = NULL, ...) + +\S4method{as.shinystan}{list}(X, model_name = "unnamed model", burnin = 0, + param_dims = list(), model_code = NULL, note = NULL, ...) + +\S4method{as.shinystan}{mcmc.list}(X, model_name = "unnamed model", + burnin = 0, param_dims = list(), model_code = NULL, note = NULL, ...) + +\S4method{as.shinystan}{stanfit}(X, pars, model_name = X@model_name, + note = NULL, ...) + +\S4method{as.shinystan}{stanreg}(X, ppd = TRUE, seed = 1234, + model_name = NULL, note = NULL, ...) } \arguments{ -\item{X}{An object to be converted to a shinystan object. Can be -one of the following: -\describe{ - \item{stanfit}{An object of class stanfit (\pkg{rstan})} - \item{stanreg}{An object of class stanreg (\pkg{rstanarm})} - \item{mcmc.list}{An object of class \code{mcmc.list} (\pkg{coda})} - \item{3D array}{A 3D array of posterior simulations with dimensions corresponding - to iterations, chains, and parameters, in that order.} - \item{chain list}{A list of matrices/2D arrays each corresponding to a single chain, - and with dimensions corresponding to iterations (rows) and parameters (columns). - } -}} +\item{X}{For \code{as.shinystan}, an object to be converted to a shinystan +object. See the Methods section below. For \code{is.shinystan}, an object +to check.} + +\item{...}{Arguments passed to the individual methods.} + +\item{model_name}{A string giving a name for the model.} + +\item{burnin}{The number of iterations to treat as burnin (warmup). Should be +\code{0} if warmup iterations are not included in \code{X}.} -\item{...}{Additional arguments. See Details, below.} +\item{param_dims}{Rarely used and never necessary. A named list giving the +dimensions for all parameters. For scalar parameters use \code{0} as the +dimension. See Examples.} -\item{object}{An object to test.} +\item{model_code}{Optionally, a character string with the code used to run +the model. This can also be added to your \code{shinystan} object later +using the \code{\link[shinystan]{model_code}} function. See +\code{\link[shinystan]{model_code}} for additional formatting instructions. +After launching the app the code will be viewable in the \strong{Model +Code} tab. For \code{stanfit} (\pkg{rstan}) and \code{stanreg} +(\pkg{rstanarm}) objects the model code is automatically retrieved from the +object.} + +\item{note}{Optionally, text to display on ShinyStan's notes page (stored in +\code{user_model_info} slot).} + +\item{pars}{For stanfit objects (\pkg{rstan}), an optional character vector +specifying which parameters should be included in the shinystan object.} + +\item{ppd}{For stanreg objects (\pkg{rstanarm}), \code{ppd} +(logical) indicates whether to draw from the posterior predictive +distribution before launching ShinyStan. The default is \code{TRUE}, +although for very large objects it can be convenient to set it to +\code{FALSE} as drawing from the posterior predictive distribution can be +time consuming. If \code{ppd} is \code{TRUE} then graphical posterior +predictive checks are available when ShinyStan is launched.} + +\item{seed}{Passed to \code{\link[rstanarm]{pp_check}} (\pkg{rstanarm}) if +\code{ppd} is \code{TRUE}.} } \value{ -For \code{as.shinystan} an object of class shinystan that can be used - with \code{\link{launch_shinystan}}. For \code{is.shinystan} a logical value - indicating whether the tested object is a shinystan object. +\code{as.shinystan} returns a shinystan object, which is an instance + of S4 class \code{"shinystan"}. + + \code{is.shinystan} returns \code{TRUE} if the tested object is a shinystan + object and \code{FALSE} otherwise. } \description{ -Create and test shinystan objects -} -\details{ -If \code{X} is a stanfit object then no additional arguments should - be specified in \code{...} (they are taken automatically from the stanfit - object). - - If \code{X} is a stanreg object the argument \code{ppd} (logical) - can be specified indicating whether to draw from the posterior predictive - distribution before launching ShinyStan. The default is \code{TRUE}, - although for large objects it can be wise to set it to \code{FALSE} as - drawing from the posterior predictive distribution can be time consuming. - - If \code{X} is not a stanfit or stanreg object then the following arguments - can be specified but are not required: +The \code{as.shinystan} function creates shinystan objects that + can be used with \code{\link{launch_shinystan}} and various other functions + in the \pkg{shinystan} package. \code{as.shinystan} is a generic for which + the \pkg{shinystan} package provides several methods. Currently methods are + provided for creating shinystan objects from arrays, lists of matrices, + stanfit objects (\pkg{rstan}), stanreg objects (\pkg{rstanarm}), and + mcmc.list objects (\pkg{coda}). -\describe{ - \item{\code{model_name}}{A character string giving a name for the model.} - \item{\code{burnin}}{The number of burnin (warmup) iterations. \code{burnin} - should only be specified if the burnin samples are included in \code{X}.} - \item{\code{param_dims}}{Rarely used and never necessary. A named list - giving the dimensions for all parameters. (For scalar parameters use - \code{0} as the dimension.) This allows shinystan to group parameters in - vectors/arrays/etc together for certain features. See \strong{Examples}.} - \item{\code{model_code}}{A character string with the code for your model.} + \code{is.shinystan} tests if an object is a shinystan object. } -} -\examples{ -\dontrun{ -################# -### Example 1 ### -################# +\section{Methods (by class)}{ +\itemize{ +\item \code{array}: Create a shinystan object from a 3-D +\code{\link{array}} of simulations. The array should have dimensions +corresponding to iterations, chains, and parameters, in that order. -# If X is a mcmc.list, 3D array or list of 2D chains then just do: -X_sso <- as.shinystan(X, ...) # replace ... with optional arguments or omit it +\item \code{list}: Create a shinystan object from a \code{\link{list}} +of matrices. Each \code{\link{matrix}} (or 2-D array) should contain the +simulations for an individual chain and all of the matrices should have the +same number of iterations (rows) and parameters (columns). Parameters +should have the same names and be in the same order. -# You can also do the above if X is a stanfit object although it is not -# necessary since launch_shinystan accepts stanfit objects. +\item \code{mcmc.list}: Create a shinystan object from an mcmc.list +(\pkg{coda}). +\item \code{stanfit}: Create a shinystan object from a stanfit object +(\pkg{\link[rstan]{rstan}}). Fewer optional arguments are available for +this method because all important information can be taken automatically +from the stanfit object. -############################################## -### Example 2: if X is a list of 2D chains ### -############################################## +\item \code{stanreg}: Create a shinystan object from a stanreg object +(\pkg{\link[rstanarm]{rstanarm}}). +}} +\examples{ + +\dontrun{ +sso <- as.shinystan(X, ...) # replace ... with optional arguments or omit it +launch_shinystan(sso) +} + +\dontrun{ +######################## +### list of matrices ### +######################## # Generate some fake data chain1 <- cbind(beta1 = rnorm(100), beta2 = rnorm(100), sigma = rexp(100)) chain2 <- cbind(beta1 = rnorm(100), beta2 = rnorm(100), sigma = rexp(100)) -X <- list(chain1, chain2) -X_sso <- as.shinystan(X) +sso <- as.shinystan(list(chain1, chain2)) +launch_shinystan(sso) # We can also specify some or all of the optional arguments # note: in order to use param_dims we need to rename 'beta1' and 'beta2' # to 'beta[1]' and 'beta[2]' colnames(chain1) <- colnames(chain2) <- c(paste0("beta[",1:2,"]"), "sigma") -X_sso <- as.shinystan(X, param_dims = list(beta = 2, sigma = 0), - model_name = "Example", - burnin = 0) -launch_shinystan(my_shinystan) +sso2 <- as.shinystan(list(chain1, chain2), + model_name = "Example", burnin = 0, + param_dims = list(beta = 2, sigma = 0)) +launch_shinystan(sso2) } + +\dontrun{ +###################### +### stanfit object ### +###################### +library("rstan") +fit <- stan_demo("eight_schools") +sso <- as.shinystan(fit, model_name = "example") +} + +\dontrun{ +###################### +### stanreg object ### +###################### +library("rstanarm") +example("example_model") +sso <- as.shinystan(example_model) +launch_shinystan(sso) +} + } \seealso{ -\code{\link{launch_shinystan}}, \code{\link{launch_shinystan_demo}} +\code{\link{launch_shinystan}} to launch the ShinyStan interface + using a particular shinystan object. + +\code{\link{drop_parameters}} to remove parameters from a shinystan + object. + +\code{\link{generate_quantity}} to add a new quantity to a shinystan + object. } diff --git a/man/deploy_shinystan.Rd b/man/deploy_shinystan.Rd index 573f4061..110ca9ee 100644 --- a/man/deploy_shinystan.Rd +++ b/man/deploy_shinystan.Rd @@ -4,10 +4,10 @@ \alias{deploy_shinystan} \title{Deploy a ShinyStan app on the web using shinyapps.io by RStudio} \usage{ -deploy_shinystan(sso, appName, account = NULL, ...) +deploy_shinystan(sso, appName, account = NULL, ..., deploy = TRUE) } \arguments{ -\item{sso}{A shinystan object.} +\item{sso}{A \code{\link[=as.shinystan]{shinystan object}}.} \item{appName}{The name to use for the application. Application names must be at least four characters long and may only contain letters, numbers, dashes @@ -17,11 +17,20 @@ and underscores.} account is configured on the system.} \item{...}{Optional arguments. See Details.} + +\item{deploy}{Should the app be deployed? The only reason for this to be +\code{FALSE} is if you just want to check that the preprocessing before +deployment is successful.} +} +\value{ +\link[=invisible]{Invisibly}, \code{TRUE} if deployment succeeded + (did not encounter an error) or, if \code{deploy} argument is set to + \code{FALSE}, the path to the temporary directory containing the app ready + for deployment (also invisibly). } \description{ -Requires a (free or paid) shinyapps.io account. Visit -\url{http://www.shinyapps.io/} to sign up and for details on how to configure -your account on your local system using RStudio's \pkg{rsconnect} package. +Requires a (free or paid) ShinyApps account. Visit +\url{http://www.shinyapps.io/} to sign up. } \details{ In \code{...}, the arguments \code{ppcheck_data} and @@ -34,10 +43,6 @@ In \code{...}, the arguments \code{ppcheck_data} and \code{ppcheck_yrep} (but not \code{ppcheck_data}) can also be set interactively on shinyapps.io when using the app. } -\note{ -See the 'Deploying to shinyapps.io' vignette for a more detailed - example. -} \examples{ \dontrun{ # For this example assume sso is the name of the shinystan object for @@ -53,4 +58,12 @@ deploy_shinystan(sso, appName = "my-model") } } +\seealso{ +The example in the \emph{Deploying to shinyapps.io} vignette that + comes with this package. + + \url{http://www.shinyapps.io/} to sign up for a free or paid ShinyApps + account and for details on how to configure your account on your local + system using RStudio's \pkg{\link[rsconnect]{rsconnect}} package. +} diff --git a/man/drop_parameters.Rd b/man/drop_parameters.Rd new file mode 100644 index 00000000..116d5d4b --- /dev/null +++ b/man/drop_parameters.Rd @@ -0,0 +1,44 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/drop_parameters.R +\name{drop_parameters} +\alias{drop_parameters} +\title{Drop parameters from a shinystan object} +\usage{ +drop_parameters(sso, pars) +} +\arguments{ +\item{sso}{A \code{\link[=as.shinystan]{shinystan object}}.} + +\item{pars}{A character vector of parameter names. If the name of a +non-scalar (e.g. vector, matrix) parameter is included in \code{pars} all +of its elements will be removed. Currently it is not possible to remove +only a subset of the elements of a non-scalar parameter.} +} +\value{ +\code{sso}, with \code{pars} dropped. +} +\description{ +Remove selected parameters from a shinystan object. This is useful if you +have a very large shinystan object when you only want to look at a subset of +parameters. With a smaller shinystan object, \code{\link{launch_shinystan}} +will be faster and you should experience better performance (responsiveness) +after launching when using the ShinyStan app. +} +\examples{ +# Using example shinystan object 'eight_schools' +print(eight_schools@param_names) + +# Remove the scalar parameters mu and tau +sso <- drop_parameters(eight_schools, pars = c("mu", "tau")) +print(sso@param_names) + +# Remove all elements of the parameter vector theta +sso <- drop_parameters(sso, pars = "theta") +print(sso@param_names) + +} +\seealso{ +\code{\link{generate_quantity}} to add a new quantity to a shinystan + object. +} + diff --git a/man/eight_schools.Rd b/man/eight_schools.Rd deleted file mode 100644 index 1c2c989d..00000000 --- a/man/eight_schools.Rd +++ /dev/null @@ -1,18 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/eight_schools.R -\docType{data} -\name{eight_schools} -\alias{eight_schools} -\title{ShinyStan demo: Eight Schools} -\format{An S4 object of class \code{shinystan}} -\usage{ -eight_schools -} -\description{ -A shinystan object for the Stan "Eight Schools" demo model -} -\seealso{ -\code{\link{launch_shinystan_demo}} -} -\keyword{datasets} - diff --git a/man/generate_quantity.Rd b/man/generate_quantity.Rd index 92c7c6d4..975e1da0 100644 --- a/man/generate_quantity.Rd +++ b/man/generate_quantity.Rd @@ -2,20 +2,19 @@ % Please edit documentation in R/generate_quantity.R \name{generate_quantity} \alias{generate_quantity} -\title{Add to shinystan object a new parameter as a function of one or two -existing parameters} +\title{Add new quantity to shinystan object} \usage{ generate_quantity(sso, param1, param2, fun, new_name) } \arguments{ -\item{sso}{shinystan object.} +\item{sso}{A \code{\link[=as.shinystan]{shinystan object}}.} \item{param1}{Name of first parameter as character string.} \item{param2}{Optional. Name of second paramter as character string.} -\item{fun}{Function to call, i.e. \code{function(param1)} or -\code{function(param1,param2)}. See \strong{Examples}, below.} +\item{fun}{Function to call, i.e. \code{function(param1)} or +\code{function(param1,param2)}. See Examples, below.} \item{new_name}{Name for the new parameter as character string.} } @@ -23,37 +22,21 @@ generate_quantity(sso, param1, param2, fun, new_name) sso, updated. See Examples. } \description{ -Add to shinystan object a new parameter as a function of one or two -existing parameters +Add to shinystan object a new parameter as a function of one or two existing +parameters. } \examples{ -\dontrun{ -################# -### Example 1 ### -################# - -# Below, assume X is a shinystan object and two of the -# parameters are alpha and beta. - -# Add parameter gamma = inverse-logit(beta) to X -inv_logit <- function(x) 1/(exp(-x) + 1) -X <- generate_quantity(sso = X, - fun = inv_logit, - param1 = "beta", - new_name = "gamma") - - -# Add parameter delta = (alpha-beta)^2 to X -X <- generate_quantity(sso = X, - fun = function(x,y) (x-y)^2, - param1 = "alpha", - param2 = "beta", - new_name = "delta") - -launch_shinystan(X) -} +# Using example shinystan object 'eight_schools' +sso <- eight_schools +sso <- generate_quantity(sso, fun = function(x) x^2, + param1 = "tau", new_name = "tau_sq") +sso <- generate_quantity(sso, fun = "-", + param1 = "theta[1]", param2 = "theta[2]", + new_name = "theta1minus2") + } \seealso{ -\code{\link{as.shinystan}} +\code{\link{drop_parameters}} to remove parameters from a shinystan + object. } diff --git a/man/launch_shinystan.Rd b/man/launch_shinystan.Rd index a44c2404..9cf89d4c 100644 --- a/man/launch_shinystan.Rd +++ b/man/launch_shinystan.Rd @@ -2,28 +2,30 @@ % Please edit documentation in R/launch_shinystan.R \name{launch_shinystan} \alias{launch_shinystan} -\title{ShinyStan app} +\title{Launch the ShinyStan app} \usage{ launch_shinystan(object, rstudio = getOption("shinystan.rstudio"), ...) } \arguments{ -\item{object}{An object of class shinystan, stanfit, or stanreg. See -\code{\link{as.shinystan}} for converting other objects to a shinystan -object (sso).} +\item{object}{An object of class shinystan, stanfit, or stanreg. To use other +types of objects first create a shinystan object using +\code{\link{as.shinystan}}.} -\item{rstudio}{Only relevant for RStudio users. The default -(\code{rstudio=FALSE}) is to launch the app in the default web browser -rather than RStudio's pop-up Viewer. Users can change the default to -\code{TRUE} by setting the global option \code{options(shinystan.rstudio = -TRUE)}.} +\item{rstudio}{Only relevant for RStudio users. The default (\code{FALSE}) is +to launch the app in the user's default web browser rather than RStudio's +pop-up Viewer. Users can change the default to \code{TRUE} by setting the +global option \code{options(shinystan.rstudio = TRUE)}.} -\item{...}{Optional arguments to pass to \code{\link[shiny]{runApp}}.} +\item{...}{Optional arguments passed to \code{\link[shiny]{runApp}}.} } \value{ -An S4 shinystan object. +The \code{launch_shinystan} function is used for the side effect of + starting the ShinyStan app, but it also returns a shinystan object, an + instance of S4 class \code{"shinystan"}. } \description{ -ShinyStan app +Launch the ShinyStan app in the default web browser. RStudio users also have +the option of launching the app in RStudio's pop-up Viewer. } \examples{ \dontrun{ @@ -67,6 +69,11 @@ fit_sso <- as.shinystan(fit, model_name = "Example") } \seealso{ -\code{\link{as.shinystan}}, \code{\link{launch_shinystan_demo}} +\code{\link{as.shinystan}} for creating shinystan objects. + +\code{\link{update_sso}} to update a shinystan object created by a + previous version of the package. + +\code{\link{launch_shinystan_demo}} to try a demo. } diff --git a/man/launch_shinystan_demo.Rd b/man/launch_shinystan_demo.Rd index 28be348e..90e56a5f 100644 --- a/man/launch_shinystan_demo.Rd +++ b/man/launch_shinystan_demo.Rd @@ -1,19 +1,28 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/launch_shinystan_demo.R +% Please edit documentation in R/launch_shinystan.R \name{launch_shinystan_demo} +\alias{eight_schools} \alias{launch_shinystan_demo} \title{ShinyStan demo} \usage{ -launch_shinystan_demo(rstudio = getOption("shinystan.rstudio"), ...) +launch_shinystan_demo(demo_name = "eight_schools", + rstudio = getOption("shinystan.rstudio"), ...) } \arguments{ -\item{rstudio}{Only relevant for RStudio users. The default -(\code{rstudio=FALSE}) is to launch the app in the default web browser -rather than RStudio's pop-up Viewer. Users can change the default to -\code{TRUE} by setting the global option \code{options(shinystan.rstudio = -TRUE)}.} +\item{demo_name}{The name of the demo. Currently \code{"eight_schools"} is +the only option, but additional demos may be available in future releases. +\describe{ +\item{\code{eight_schools}}{Hierarchical meta-analysis model. See + \emph{Meta Analysis} chapter of the Stan manual (chapter 11.2 in version + 2.9), \url{http://mc-stan.org/documentation/}.} +}} -\item{...}{Optional arguments to pass to \code{\link[shiny]{runApp}}.} +\item{rstudio}{Only relevant for RStudio users. The default (\code{FALSE}) is +to launch the app in the user's default web browser rather than RStudio's +pop-up Viewer. Users can change the default to \code{TRUE} by setting the +global option \code{options(shinystan.rstudio = TRUE)}.} + +\item{...}{Optional arguments passed to \code{\link[shiny]{runApp}}.} } \value{ An S4 shinystan object. @@ -27,11 +36,14 @@ ShinyStan demo launch_shinystan_demo() # launch demo and save the shinystan object for the demo -ssdemo <- launch_shinystan_demo() +sso_demo <- launch_shinystan_demo() } } \seealso{ -\code{\link{launch_shinystan}}, \code{\link{as.shinystan}} +\code{\link{launch_shinystan}} to launch the ShinyStan interface + using a particular shinystan object. + +\code{\link{as.shinystan}} for creating shinystan objects. } diff --git a/man/model_code.Rd b/man/model_code.Rd deleted file mode 100644 index 8f0f3eb3..00000000 --- a/man/model_code.Rd +++ /dev/null @@ -1,60 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/model_code.R -\name{model_code} -\alias{model_code} -\title{Add model code to a shinystan object or see the code currently stored in -a shinystan} -\usage{ -model_code(sso, code) -} -\arguments{ -\item{sso}{A shinystan object.} - -\item{code}{Optionally, the code you want to add. See \strong{Details} below for -formatting instructions.} -} -\value{ -If \code{code} is missing then any code currently stored in - \code{sso} is returned as a character string. If \code{code} is specified - then then any previous code is overwritten by the text in \code{code} and - an updated shinystan object is returned. -} -\description{ -Add model code to a shinystan object or see the code currently stored in -a shinystan -} -\details{ -If \code{code} is specified it should be be a character string that - can be used as an argument to \code{cat}. See \strong{Examples}, below. -} -\note{ -For \pkg{rstan} users the model code will be automatically taken -from the stanfit object. -} -\examples{ -\dontrun{ -# Some JAGS-style code we might want to add -my_code <- " - model { - for (i in 1:length(Y)) { - Y[i] ~ dpois(lambda[i]) - log(lambda[i]) <- inprod(X[i,], theta[]) - } - for (j in 1:J) { - theta[j] ~ dt(0.0, 1.0, 1.0) - } - } -" - -# Add the code to a shinystan object sso -sso <- model_code(sso, my_code) - -# View the code currently stored in sso -model_code(sso) - -} -} -\seealso{ -\code{cat} -} - diff --git a/man/notes.Rd b/man/notes.Rd deleted file mode 100644 index 78a4f7ae..00000000 --- a/man/notes.Rd +++ /dev/null @@ -1,42 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/notes.R -\name{notes} -\alias{notes} -\title{Additional or replacement notes} -\usage{ -notes(sso, notes, replace = FALSE) -} -\arguments{ -\item{sso}{shinystan object.} - -\item{notes}{Optional. A character vector of additional or replacement notes.} - -\item{replace}{If \code{TRUE} the existing notes are overwritten by -\code{notes} if \code{notes} is specified. If \code{FALSE} (the default) -if \code{notes} is specified then its content is appended to the existing -notes.} -} -\value{ -If \code{notes} is missing then any existing notes stored in - \code{sso} are returned as a character string. If \code{notes} is specified - then an updated shinystan object is returned with either \code{notes} added - to the previous notes (if \code{replace=FALSE}) or overwritten by - \code{notes} (if \code{replace = TRUE}). -} -\description{ -Notes are viewable on ShinyStan's Notepad page -} -\examples{ -\dontrun{ -sso <- notes(sso, "new note") -sso <- notes(sso, c("a different note", "another note"), replace = TRUE) - -# See any notes currently in sso -notes(sso) -} - -} -\seealso{ -\code{\link{as.shinystan}} -} - diff --git a/man/rename_model.Rd b/man/rename_model.Rd index ae096b30..6ec1eb84 100644 --- a/man/rename_model.Rd +++ b/man/rename_model.Rd @@ -1,29 +1,17 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/rename_model.R +% Please edit documentation in R/sso-metadata.R \name{rename_model} \alias{rename_model} -\title{Change the model name associated with a shinystan object} +\title{rename_model (deprecated)} \usage{ rename_model(sso, new_model_name) } \arguments{ -\item{sso}{shinystan object.} - -\item{new_model_name}{Character string giving the new model name to use.} -} -\value{ -sso, updated. +\item{sso, new_model_name}{Use the \code{\link{model_name}} function instead.} } \description{ -Change the model name associated with a shinystan object -} -\examples{ -\dontrun{ -sso <- rename_model(sso, "new name for model") -} - -} -\seealso{ -\code{\link{as.shinystan}} +This function is deprecated and will be removed in a future release. Please +use the \code{\link{model_name}} function instead. } +\keyword{internal} diff --git a/man/retrieve.Rd b/man/retrieve.Rd index 0bc944ab..d5de2467 100644 --- a/man/retrieve.Rd +++ b/man/retrieve.Rd @@ -7,35 +7,36 @@ retrieve(sso, what, ...) } \arguments{ -\item{sso}{A shinystan object} +\item{sso}{A \code{\link[=as.shinystan]{shinystan object}}.} -\item{what}{What do you want to get? See \strong{Details}, below.} +\item{what}{What do you want to get? See Details, below.} \item{...}{Optional arguments, in particular \code{pars} to specify parameter names (by default all parameters will be used). For NUTS sampler parameters only (e.g. stepsize, treedepth) \code{inc_warmup} can also be specified to include/exclude warmup iterations (the default is \code{FALSE}). See -\strong{Details}, below.} +Details, below.} } \description{ From a shinystan object get rhat, effective sample size, posterior quantiles, means, standard deviations, sampler diagnostics, etc. } \details{ -The argument \code{what} can take on the values below. Args: \code{arg} -means that \code{arg} can be specified in \code{...} for this value of \code{what}. +The argument \code{what} can take on the values below. Args: + \code{arg} means that \code{arg} can be specified in \code{...} for this + value of \code{what}. \describe{ - \item{\code{"rhat", "Rhat", "r_hat", or "R_hat"}}{returns: Rhat statistics. Args: \code{pars}} - \item{\code{"N_eff","n_eff", "neff", "Neff", "ess", or "ESS"}}{returns: Effective sample sizes. Args: \code{pars}} + \item{\code{"rhat"}, \code{"Rhat"}, \code{"r_hat"}, or \code{"R_hat"}}{returns: Rhat statistics. Args: \code{pars}} + \item{\code{"N_eff"}, \code{"n_eff"}, \code{"neff"}, \code{"Neff"}, \code{"ess"}, or \code{"ESS"}}{returns: Effective sample sizes. Args: \code{pars}} \item{\code{"mean"}}{returns: Posterior means. Args: \code{pars}} \item{\code{"sd"}}{returns: Posterior standard deviations. Args: \code{pars}} - \item{\code{"se_mean" or "mcse"}}{returns: Monte carlo standard error. Args: \code{pars}} + \item{\code{"se_mean"} or \code{"mcse"}}{returns: Monte carlo standard error. Args: \code{pars}} \item{\code{"median"}}{returns: Posterior medians. Args: \code{pars}.} - \item{\code{"quantiles" or any string with "quant" in it (not case sensitive)}}{returns: 2.5\%, 25\%, 50\%, 75\%, 97.5\% posterior quantiles. Args: \code{pars}.} - \item{\code{"avg_accept_stat" or any string with "accept" in it (not case sensitive)}}{returns: Average value of "accept_stat" (which itself is the average acceptance probability over the NUTS subtree). Args: \code{inc_warmup}} - \item{\code{"prop_divergent" or any string with "diverg" in it (not case sensitive)}}{returns: Proportion of divergent iterations for each chain. Args: \code{inc_warmup}} - \item{\code{"max_treedepth" or any string with "tree" or "depth" in it (not case sensitive)}}{returns: Maximum treedepth for each chain. Args: \code{inc_warmup}} - \item{\code{"avg_stepsize" or any string with "step" in it (not case sensitive)}}{returns: Average stepsize for each chain. Args: \code{inc_warmup}} + \item{\code{"quantiles"} or any string with \code{"quant"} in it (not case sensitive)}{returns: 2.5\%, 25\%, 50\%, 75\%, 97.5\% posterior quantiles. Args: \code{pars}.} + \item{\code{"avg_accept_stat"} or any string with \code{"accept"} in it (not case sensitive)}{returns: Average value of "accept_stat" (which itself is the average acceptance probability over the NUTS subtree). Args: \code{inc_warmup}} + \item{\code{"prop_divergent"} or any string with \code{"diverg"} in it (not case sensitive)}{returns: Proportion of divergent iterations for each chain. Args: \code{inc_warmup}} + \item{\code{"max_treedepth"} or any string with \code{"tree"} or \code{"depth"} in it (not case sensitive)}{returns: Maximum treedepth for each chain. Args: \code{inc_warmup}} + \item{\code{"avg_stepsize"} or any string with \code{"step"} in it (not case sensitive)}{returns: Average stepsize for each chain. Args: \code{inc_warmup}} } } \note{ @@ -43,17 +44,14 @@ Sampler diagnostics (e.g. \code{"avg_accept_stat"}) only available for models originally fit using Stan. } \examples{ -\dontrun{ -# assume 'X' is a shinystan object with parameters -# 'beta[1]', 'beta[2]', 'sigma[1]', 'sigma[2]'" - -retrieve(X, "rhat") -retrieve(X, "mean", pars = c('beta[1]', 'sigma[1]')) -retrieve(X, "quantiles") - -retrieve(X, "max_treedepth") # equivalent to retrieve(X, "depth"), retrieve(X, "tree"), etc. -retrieve(X, "prop_divergent", inc_warmup = FALSE) # don't include warmup iterations -} +# Using example shinystan object 'eight_schools' +sso <- eight_schools +retrieve(sso, "rhat") +retrieve(sso, "mean", pars = c('theta[1]', 'mu')) +retrieve(sso, "quantiles") +retrieve(sso, "max_treedepth") # equivalent to retrieve(sso, "depth"), retrieve(sso, "tree"), etc. +retrieve(sso, "prop_divergent") +retrieve(sso, "prop_divergent", inc_warmup = TRUE) } diff --git a/man/shinystan-class.Rd b/man/shinystan-class.Rd index 464356fe..6109e542 100644 --- a/man/shinystan-class.Rd +++ b/man/shinystan-class.Rd @@ -1,38 +1,54 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/shinystan-class.R +% Please edit documentation in R/shinystan-objects.R \docType{class} \name{shinystan-class} \alias{shinystan} \alias{shinystan-class} -\title{S4 shinystan objects (sso)} +\title{S4 shinystan objects} \description{ -shinystan objects +See \code{\link{as.shinystan}} for documentation on creating + shinystan objects and \code{\link{eight_schools}} for an example object. } -\section{Creating shinystan objects}{ +\section{Slots}{ +\describe{ +\item{\code{model_name}}{(\code{"character"}) Model name.} -See \code{\link{as.shinystan}}. -} +\item{\code{param_names}}{(\code{"character"}) Parameter names.} -\section{Hosting your own ShinyStan apps online}{ +\item{\code{param_dims}}{(\code{"list"}) Parameter dimensions.} +\item{\code{posterior_sample}}{(\code{"array"}) MCMC sample.} -See \code{\link{deploy_shinystan}}. -} +\item{\code{summary}}{(\code{"matrix"}) Summary stats for \code{posterior_sample}.} + +\item{\code{sampler_params}}{(\code{"list"}) Sampler parameters (for certain Stan +models only).} + +\item{\code{n_chain}}{(\code{"integer"}) Number of chains.} + +\item{\code{n_iter}}{(\code{"integer"}) Number of iterations per chain.} -\section{Functions for manipulating shinystan objects}{ +\item{\code{n_warmup}}{(\code{"integer"}) Number of warmup iterations per chain.} +\item{\code{user_model_info}}{(\code{"character"}) Notes to display on ShinyStan's +\strong{Notepad} page.} -\code{\link{notes}} Add to or replace notes. +\item{\code{model_code}}{(\code{"character"}) Model code to display on ShinyStan's +\strong{Model Code} page.} -\code{\link{rename_model}} Change the model name. +\item{\code{misc}}{(\code{"list"}) Miscellaneous, for internal use.} +}} +\seealso{ +\code{\link{as.shinystan}} for creating shinystan objects. -\code{\link{generate_quantity}} Add new parameters/quantities as a function -of one or two existing parameters. +\code{\link{drop_parameters}} to remove parameters from a shinystan + object. -\code{\link{model_code}} Add or change model code. +\code{\link{generate_quantity}} to add a new quantity to a shinystan + object. -\code{\link{update_sso}} Update a shinystan object created by an older version -of the package. +\code{\link{shinystan-metadata}} to view or change metadata + associated with a shinystan object. } diff --git a/man/shinystan-metadata.Rd b/man/shinystan-metadata.Rd new file mode 100644 index 00000000..074881ce --- /dev/null +++ b/man/shinystan-metadata.Rd @@ -0,0 +1,134 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/sso-metadata.R +\name{shinystan-metadata} +\alias{model_code} +\alias{model_name} +\alias{notes} +\alias{shinystan-metadata} +\alias{sso_info} +\title{View or change metadata associated with a shinystan object} +\usage{ +sso_info(sso) + +model_code(sso, code = NULL) + +notes(sso, note = NULL, replace = FALSE) + +model_name(sso, name = NULL) +} +\arguments{ +\item{sso}{A \code{\link[=as.shinystan]{shinystan object}}.} + +\item{code}{A string, containing model code to be added, that can be +used as an argument to \code{\link{cat}}. See \strong{Examples}.} + +\item{note}{A string containing a note to add to any existing notes +or replace existing notes, depending on the value of \code{replace}.} + +\item{replace}{If \code{TRUE} the existing notes are overwritten by +\code{note} if \code{note} is specified. If \code{FALSE} (the default) +if \code{note} is specified then its content is appended to the existing +notes.} + +\item{name}{A string giving the new model name to use.} +} +\value{ +\code{sso_info} prints basic metadata including number of parameters, + chains, iterations, warmup iterations, etc. It does not return anything. + +\code{model_code} returns or replaces model code stored in a + shinystan object. If \code{code} is \code{NULL} then any existing model + code stored in \code{sso} is returned as a character string. If \code{code} + is specified then an updated shinystan object is returned with \code{code} + added. For shinystan objects created from stanfit (\pkg{rstan}) and stanreg + (\pkg{rstanarm}) objects, model code is automatically taken from that + object and does not need to be added manually. From within the ShinyStan + interface model code can be viewed on the \strong{Model Code} page. + +\code{notes} returns, amends, or replaces notes stored in a shinystan + object. If \code{note} is \code{NULL} then any existing notes stored in + \code{sso} are returned as a character string. If \code{note} is specified + then an updated shinystan object is returned with either \code{note} added + to the previous notes (if \code{replace=FALSE}) or overwritten by + \code{note} (if \code{replace = TRUE}). From within the ShinyStan + interface, notes are viewable on the \strong{Notepad} page. + +\code{model_name} returns or replaces the model name associated with + a shinystan object. If \code{name} is \code{NULL} then the current model + name is returned. If \code{name} is specified then \code{sso} is returned + with an updated model name. +} +\description{ +View or change metadata associated with a shinystan object +} +\examples{ +# use eight_schools example object +sso <- eight_schools + +################ +### sso_info ### +################ + +sso_info(sso) + +################## +### model_code ### +################## + +# view model code in example shinystan object 'eight_schools' +cat(model_code(sso)) + +# change the model code in sso +# some jags style code +my_code <- " + model { + for (i in 1:length(Y)) { + Y[i] ~ dpois(lambda[i]) + log(lambda[i]) <- inprod(X[i,], theta[]) + } + for (j in 1:J) { + theta[j] ~ dt(0.0, 1.0, 1.0) + } + } +" +sso <- model_code(sso, my_code) +cat(model_code(sso)) + +############# +### notes ### +############# + +# view existing notes +notes(sso) + +# add a note to the existing notes +sso <- notes(sso, "New note") +notes(sso) +cat(notes(sso)) + +# replace existing notes +sso <- notes(sso, "replacement note", replace = TRUE) +notes(sso) + +################## +### model_name ### +################## + +# view model name +model_name(sso) + +# change model name +sso <- model_name(sso, "some other name") +identical(model_name(sso), "some other name") + +} +\seealso{ +\code{\link{as.shinystan}} for creating shinystan objects. + +\code{\link{drop_parameters}} to remove parameters from a shinystan + object. + +\code{\link{generate_quantity}} to add a new quantity to a shinystan + object. +} + diff --git a/man/shinystan-package.Rd b/man/shinystan-package.Rd index 36634ad8..d5456da4 100644 --- a/man/shinystan-package.Rd +++ b/man/shinystan-package.Rd @@ -3,37 +3,38 @@ \docType{package} \name{shinystan-package} \alias{shinystan-package} -\title{The ShinyStan interface and shinystan R package} +\title{ShinyStan interface and shinystan R package} \description{ Applied Bayesian data analysis is primarily implemented through - the MCMC algorithms offered by various software packages. When analyzing a - posterior sample obtained by one of these algorithms the first step is to - check for signs that the chains have converged to the target distribution - and and also for signs that the algorithm might require tuning or might be - ill-suited for the given model. There may also be theoretical problems or - practical inefficiencies with the specification of the model. ShinyStan - provides interactive plots and tables helpful for analyzing a posterior - sample, with particular attention to identifying potential problems with - the performance of the MCMC algorithm or the specification of the model. - ShinyStan is powered by RStudio's Shiny web application framework and works - with the output of MCMC programs written in any programming language (and - has extended functionality for models fit using the rstan package and the - No-U-Turn sampler). + the Markov chain Monte Carlo (MCMC) algorithms offered by various software + packages. When analyzing a posterior sample obtained by one of these + algorithms the first step is to check for signs that the chains have + converged to the target distribution and and also for signs that the + algorithm might require tuning or might be ill-suited for the given model. + There may also be theoretical problems or practical inefficiencies with the + specification of the model. ShinyStan provides interactive plots and tables + helpful for analyzing a posterior sample, with particular attention to + identifying potential problems with the performance of the MCMC algorithm + or the specification of the model. ShinyStan is powered by RStudio's Shiny + web application framework and works with the output of MCMC programs + written in any programming language (and has extended functionality for + models fit using the rstan package and the No-U-Turn sampler). } \section{ShinyStan has extended functionality for Stan models}{ + - - Stan (\url{http://mc-stan.org}) models can be run in R using the - \pkg{rstan} package. +Stan (\url{http://mc-stan.org}) models can be run in R using the +\pkg{\link[rstan]{rstan}} and \pkg{\link[rstanarm]{rstanarm}} packages. } \section{Saving and sharing}{ - The \pkg{shinystan} package allows you to store the basic components of an + The \pkg{shinystan} package allows you to store the basic components of an entire project (code, posterior samples, graphs, tables, notes) in a single - object. Users can save many of the plots as ggplot2 objects for further - customization and easy integration in reports or post-processing for + object, a \code{\link[=as.shinystan]{shinystan object}} (sso, for short). + Users can save many of the plots as ggplot2 objects for further + customization and easy integration in reports or post-processing for publication. The \code{\link{deploy_shinystan}} function lets you easily deploy your own @@ -56,3 +57,19 @@ Applied Bayesian data analysis is primarily implemented through one of your own models using \code{\link{launch_shinystan}}. } +\section{Help and bug reports}{ + +\itemize{ + \item Stan Users Google group (\url{https://groups.google.com/forum/#!forum/stan-users}) + \item ShinyStan issue tracker (\url{https://github.com/stan-dev/shinystan/issues}) +} +} +\seealso{ +\code{\link{as.shinystan}} for creating shinystan objects. + +\code{\link{launch_shinystan_demo}} to try a demo. + +\code{\link{launch_shinystan}} to launch the ShinyStan interface + using a particular shinystan object. +} + diff --git a/man/sso_info.Rd b/man/sso_info.Rd deleted file mode 100644 index db2ea79f..00000000 --- a/man/sso_info.Rd +++ /dev/null @@ -1,16 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/sso_info.R -\name{sso_info} -\alias{sso_info} -\title{Print summary of shinystan object} -\usage{ -sso_info(sso) -} -\arguments{ -\item{sso}{A \code{shinystan} object.} -} -\description{ -Prints basic summary info including number of parameters, chains, iterations, -warmup iterations, etc. -} - diff --git a/man/update_sso.Rd b/man/update_sso.Rd index 111a4c11..d01d56d2 100644 --- a/man/update_sso.Rd +++ b/man/update_sso.Rd @@ -2,25 +2,34 @@ % Please edit documentation in R/update_sso.R \name{update_sso} \alias{update_sso} -\title{Update an object created by an earlier version of shinystan} +\title{Update an object created by the previous version of shinystan} \usage{ -update_sso(old_sso) +update_sso(sso) } \arguments{ -\item{old_sso}{An old shinystan object to update.} +\item{sso}{A \code{\link[=as.shinystan]{shinystan object}}.} } \value{ -sso, updated. +If \code{sso} is already compatible with your version of + \pkg{shinystan} then \code{sso} itself is returned and a message is printed + indicating that \code{sso} is already up-to-date. Otherwise an updated + version of \code{sso} is returned unless an error is encountered. } \description{ -Before you can use an old shinystan object (sso) with the new version of -shinystan you might need to run \code{update_sso}. The updated sso -will then have all the slots that will be accessed by the ShinyStan app. +If you encounter any errors when using a shinystan object (\code{sso}) +created by a previous version of \pkg{shinystan}, you might need to run +\code{update_sso}. If \code{update_sso} does not resolve the problem and +you still have the object (e.g. stanfit, stanreg, mcmc.list) from which +\code{sso} was originally created, you can create a new shinystan object +using \code{\link{as.shinystan}}. } \examples{ \dontrun{ -sso_new <- update_sso(sso_old) -} +sso_new <- update_sso(sso) +} } +\seealso{ +\code{\link{as.shinystan}} for creating shinystan objects. +} diff --git a/tests/testthat/data_for_retrieve_tests.R b/tests/testthat/data_for_retrieve_tests.R new file mode 100644 index 00000000..9eb90c34 --- /dev/null +++ b/tests/testthat/data_for_retrieve_tests.R @@ -0,0 +1,73 @@ +test_answer_median <- + structure(c(7.66326915430084, 10.5456377610072, 7.62721910209057, + 6.15397157549917, 7.39187255777517, 4.81489509942057, 5.82967264983337, + 10.4250076101431, 8.16827693076258, 6.07598566812009, -18.7547506507413 + ), .Names = c("mu", "theta[1]", "theta[2]", "theta[3]", "theta[4]", + "theta[5]", "theta[6]", "theta[7]", "theta[8]", "tau", "log-posterior" + )) +test_answer_mean <- + structure(c(7.61278931524295, 11.4016705206937, 7.66568078208364, + 5.67748189168343, 7.33867075036529, 4.43757702342367, 5.61772900604455, + 10.9224001073223, 8.35604656671243, 7.32821612535776, -18.3099036670394 + ), .Names = c("mu", "theta[1]", "theta[2]", "theta[3]", "theta[4]", + "theta[5]", "theta[6]", "theta[7]", "theta[8]", "tau", "log-posterior" + )) +test_answer_rhat <- + structure(c(1.00193274614794, 1.00452938626942, 1.00125455903399, + 1.00127022064874, 1.00165198336501, 1.00372002563809, 1.00307636169776, + 1.00300332586848, 1.00086600376535, 1.0135621070749, 1.02233385888746 + ), .Names = c("mu", "theta[1]", "theta[2]", "theta[3]", "theta[4]", + "theta[5]", "theta[6]", "theta[7]", "theta[8]", "tau", "log-posterior" + )) +test_answer_ess <- + structure(c(695.050921695149, 692.572280147228, 1209.37138131348, + 1297.32046732778, 1115.68142297175, 866.803880031437, 1008.24598387706, + 689.500717669359, 1349.69098807226, 271.485295178596, 164.76144165741 + ), .Names = c("mu", "theta[1]", "theta[2]", "theta[3]", "theta[4]", + "theta[5]", "theta[6]", "theta[7]", "theta[8]", "tau", "log-posterior" + )) +test_answer_sd <- + structure(c(5.26323739262692, 8.69982993302657, 6.52019611729075, + 8.10150161148801, 6.69543707787934, 6.47930101606355, 6.85333063955901, + 7.15623795593227, 8.34539836623598, 5.41072834729483, 5.29638545596557 + ), .Names = c("mu", "theta[1]", "theta[2]", "theta[3]", "theta[4]", + "theta[5]", "theta[6]", "theta[7]", "theta[8]", "tau", "log-posterior" + )) +test_answer_accept_stat <- + structure(c(0.824390178845497, 0.95133395868425, 0.915935600387729, + 0.920407393897412), .Names = c("chain1", "chain2", "chain3", + "chain4")) +test_answer_divergent <- + structure(c(0.006, 0.003, 0, 0.002), .Names = c("chain1", "chain2", + "chain3", "chain4")) +test_answer_mcse <- + structure(c(0.199638660406913, 0.330581244601373, 0.187491168280733, + 0.224927153813632, 0.200451279211605, 0.220073491463301, 0.215833291826995, + 0.272531942571016, 0.227158973991041, 0.32838444299762, 0.412621442147415 + ), .Names = c("mu", "theta[1]", "theta[2]", "theta[3]", "theta[4]", + "theta[5]", "theta[6]", "theta[7]", "theta[8]", "tau", "log-posterior")) +test_answer_quantiles <- + structure(c(-2.45077906182123, -3.31983983310261, -4.57962616838214, + -12.4578126839486, -6.62936539181392, -9.08938973639197, -8.63855924130489, + -1.72877568253281, -8.31237064690878, 1.09201252476925, -27.7751080865317, + 4.12068194893101, 5.73411025831149, 3.17044970534105, 1.24377962416165, + 2.97370388347474, 0.237131301746035, 1.41862522514148, 5.98638086164563, + 3.29894150026978, 3.36183993309446, -21.9839223409667, 7.66326915430084, + 10.5456377610072, 7.62721910209057, 6.15397157549917, 7.39187255777517, + 4.81489509942057, 5.82967264983337, 10.4250076101431, 8.16827693076258, + 6.07598566812009, -18.7547506507413, 10.954089111466, 16.0154148818468, + 11.8226936192307, 10.783351812759, 11.6861908782556, 9.0714064733997, + 10.0979677042868, 14.9916757839673, 13.0025275234939, 9.82027519277038, + -14.9290381144071, 18.049454172935, 31.9617117712557, 20.8705874040468, + 20.807183632335, 20.5249077599984, 15.7663003355112, 18.3397826218994, + 26.8872295016415, 26.4856883459691, 20.7118172250858, -7.05699018362593 + ), .Dim = c(11L, 5L), .Dimnames = list(c("mu", "theta[1]", "theta[2]", + "theta[3]", "theta[4]", "theta[5]", "theta[6]", "theta[7]", "theta[8]", + "tau", "log-posterior"), c("2.5%", "25%", "50%", "75%", "97.5%"))) +test_answer_stepsize <- + structure(c(0.265382735953881, 0.0917792726985177, 0.18419718916482, + 0.110787656205807), .Names = c("chain1", "chain2", "chain3", + "chain4")) +test_answer_treedepth <- + structure(c(6, 7, 6, 6), .Names = c("chain1", "chain2", "chain3", + "chain4")) diff --git a/tests/testthat/data_for_tests.R b/tests/testthat/data_for_tests.R deleted file mode 100644 index 2036a69c..00000000 --- a/tests/testthat/data_for_tests.R +++ /dev/null @@ -1,35 +0,0 @@ -demo_median <- -structure(c(7.66326915430084, 10.5456377610072, 7.62721910209057, -6.15397157549917, 7.39187255777517, 4.81489509942057, 5.82967264983337, -10.4250076101431, 8.16827693076258, 6.07598566812009, -18.7547506507413 -), .Names = c("mu", "theta[1]", "theta[2]", "theta[3]", "theta[4]", -"theta[5]", "theta[6]", "theta[7]", "theta[8]", "tau", "lp__" -)) -demo_mean <- -structure(c(7.61278931524295, 11.4016705206937, 7.66568078208364, -5.67748189168343, 7.33867075036529, 4.43757702342367, 5.61772900604455, -10.9224001073223, 8.35604656671243, 7.32821612535776, -18.3099036670394 -), .Names = c("mu", "theta[1]", "theta[2]", "theta[3]", "theta[4]", -"theta[5]", "theta[6]", "theta[7]", "theta[8]", "tau", "lp__" -)) -demo_rhat <- -structure(c(1.00193274614794, 1.00452938626942, 1.00125455903399, -1.00127022064874, 1.00165198336501, 1.00372002563809, 1.00307636169776, -1.00300332586848, 1.00086600376535, 1.0135621070749, 1.02233385888746 -), .Names = c("mu", "theta[1]", "theta[2]", "theta[3]", "theta[4]", -"theta[5]", "theta[6]", "theta[7]", "theta[8]", "tau", "lp__" -)) -demo_ess <- -structure(c(695.050921695149, 692.572280147228, 1209.37138131348, -1297.32046732778, 1115.68142297175, 866.803880031437, 1008.24598387706, -689.500717669359, 1349.69098807226, 271.485295178596, 164.76144165741 -), .Names = c("mu", "theta[1]", "theta[2]", "theta[3]", "theta[4]", -"theta[5]", "theta[6]", "theta[7]", "theta[8]", "tau", "lp__" -)) -demo_sd <- -structure(c(5.26323739262692, 8.69982993302657, 6.52019611729075, -8.10150161148801, 6.69543707787934, 6.47930101606355, 6.85333063955901, -7.15623795593227, 8.34539836623598, 5.41072834729483, 5.29638545596557 -), .Names = c("mu", "theta[1]", "theta[2]", "theta[3]", "theta[4]", -"theta[5]", "theta[6]", "theta[7]", "theta[8]", "tau", "lp__" -)) diff --git a/tests/testthat/old_sso_for_tests.rda b/tests/testthat/old_sso_for_tests.rda new file mode 100644 index 00000000..d324daf7 Binary files /dev/null and b/tests/testthat/old_sso_for_tests.rda differ diff --git a/tests/testthat/stanfit2_for_tests.rda b/tests/testthat/stanfit2_for_tests.rda new file mode 100644 index 00000000..2a70c0d5 Binary files /dev/null and b/tests/testthat/stanfit2_for_tests.rda differ diff --git a/tests/testthat/test_creating_sso.R b/tests/testthat/test_creating_sso.R index a1fe3f81..dc937579 100644 --- a/tests/testthat/test_creating_sso.R +++ b/tests/testthat/test_creating_sso.R @@ -1,36 +1,154 @@ library(shinystan) +suppressPackageStartupMessages(library(rstanarm)) +library(coda) -context("Creating sso") - -array_test1 <- array(rnorm(300), dim = c(25, 4, 3)) -array_test2 <- array(rnorm(300), dim = c(100, 3)) +sso <- eight_schools +array1 <- array(rnorm(300), dim = c(25, 4, 3)) +array2 <- array(rnorm(300), dim = c(100, 3)) +chains1 <- list(chain1 = cbind(beta1 = rnorm(100), beta2 = rnorm(100), sigma = rexp(100)), + chain2 = cbind(beta1 = rnorm(100), beta2 = rnorm(100), sigma = rexp(100))) data(line, package = "coda") -mcmc_test1 <- line -mcmc_test2 <- line[[1L]] +mcmc1 <- line +mcmc2 <- line[[1L]] -chain1 <- cbind(beta1 = rnorm(100), beta2 = rnorm(100), sigma = rexp(100)) -chain2 <- cbind(beta1 = rnorm(100), beta2 = rnorm(100), sigma = rexp(100)) -chains_test <- list(chain1, chain2) +stanreg1 <- suppressWarnings(stan_glm(mpg ~ wt, data = mtcars, seed = 12345, iter = 200, refresh = 0)) +stanfit1 <- stanreg1$stanfit +# load 'old_sso', a shinystan object created by previous shinystan version +load("old_sso_for_tests.rda") -test_that("as.shinystan creates sso", { - expect_that(is.shinystan(as.shinystan(array_test1)), is_true()) - expect_that(is.shinystan(as.shinystan(mcmc_test1)), is_true()) - expect_that(is.shinystan(as.shinystan(chains_test)), is_true()) +context("Checking shinystan objects") +# sso_check --------------------------------------------------------------- +test_that("sso_check throws errors", { + expect_error(sso_check(array1)) + expect_error(sso_check(chain2)) + expect_error(sso_check(chains1)) + + expect_true(sso_check(sso)) + expect_true(sso_check(as.shinystan(array1))) + + expect_error(sso_check(old_sso), + regexp = "use the 'update_sso' function to update your object") }) -test_that("sso_check throws errors", { - expect_that(sso_check(array_test1), throws_error()) - expect_that(sso_check(chain2), throws_error()) - expect_that(sso_check(chains_test), throws_error()) - expect_that(sso_check(eight_schools), is_true()) - expect_that(sso_check(as.shinystan(array_test1)), is_true()) - expect_that(sso_check(as.shinystan(mcmc_test1)), is_true()) - expect_that(sso_check(as.shinystan(chains_test)), is_true()) + +# is.shinystan ------------------------------------------------------------ +test_that("is.shinystan, is.stanfit, is.stanreg work", { + expect_true(is.shinystan(sso)) + expect_false(is.shinystan(sso@posterior_sample)) + + expect_true(is.stanfit(stanfit1)) + expect_false(is.stanfit(stanreg1)) + + expect_true(is.stanreg(stanreg1)) + expect_false(is.stanreg(stanfit1)) +}) + + +context("Creating shinystan objects") +# as.shinystan helpers ---------------------------------------------------- +test_that("as.shinystan stanfit helpers work", { + expect_is(.rstan_max_treedepth(stanfit1), "integer") + expect_equal(.rstan_warmup(stanfit1), 0) + expect_equal(length(.rstan_sampler_params(stanfit1)), ncol(stanfit1)) + expect_is(.rstan_summary(stanfit1), "matrix") + expect_identical(.stan_algorithm(stanfit1), "NUTS") + expect_false(.used_vb(stanfit1)) + expect_false(.from_cmdstan(stanfit1)) + expect_is(.stan_args(stanfit1), "list") + expect_true(all(c("iter", "seed", "warmup") %in% names(.stan_args(stanfit1)))) + + stanfit1@stan_args[[1]]$method <- "variational" + expect_true(.used_vb(stanfit1)) + expect_identical(.rstan_sampler_params(stanfit1), list(NA)) + + stanfit1@stan_args[[1]]$control$max_treedepth <- NULL + expect_equal(.rstan_max_treedepth(stanfit1), 11) +}) + + + +# as.shinystan ------------------------------------------------------------ +test_that("as.shinystan creates sso", { + # array + expect_is(x <- as.shinystan(array1, model_name = "test", note = "test"), "shinystan") + expect_identical(sso_version(x), utils::packageVersion("shinystan")) + + # mcmc.list + expect_is(as.shinystan(mcmc1, model_name = "test", note = "test", model_code = "test"), "shinystan") + expect_is(as.shinystan(mcmc1[1]), "shinystan") + expect_identical(sso_version(x), utils::packageVersion("shinystan")) + + # list of matrices + expect_is(as.shinystan(chains1, model_code = "test"), "shinystan") + expect_is(as.shinystan(chains1[1]), "shinystan") + colnames(chains1[[1]]) <- colnames(chains1[[2]]) <- c(paste0("beta[",1:2,"]"), "sigma") + sso2 <- as.shinystan(chains1, param_dims = list(beta = 2, sigma = 0)) + expect_identical(sso2@param_dims, list(beta = 2, sigma = numeric(0))) + expect_identical(sso_version(x), utils::packageVersion("shinystan")) + + # stanreg + expect_is(as.shinystan(stanreg1, model_name = "test"), "shinystan") + expect_identical(sso_version(x), utils::packageVersion("shinystan")) + + # stanfit + expect_is(as.shinystan(stanfit1, model_name = "test", note = "test"), "shinystan") + expect_identical(sso_version(x), utils::packageVersion("shinystan")) }) test_that("as.shinystan throws errors", { - expect_that(as.shinystan(array_test2), throws_error()) - expect_that(as.shinystan(mcmc_test2), throws_error()) + expect_error(as.shinystan(array2)) + expect_error(as.shinystan(mcmc2)) +}) + +test_that("as.shinystan arguments works with rstanarm example", { + sso1 <- as.shinystan(stanreg1) + sso2 <- as.shinystan(stanreg1, ppd = FALSE) + expect_is(sso1, "shinystan") + expect_is(sso2, "shinystan") + expect_false(is.null(sso1@misc$pp_check_plots)) + expect_null(sso2@misc$pp_check_plots) +}) + +test_that("as.shinystan 'pars' argument works with rstan example", { + # load 'stanfit2' saved stanfit object + load("stanfit2_for_tests.rda") + + expect_error(as.shinystan(stanfit2, pars = c("alpha[1,1]", "lp__")), + "elements of non-scalar parameters not allowed") + + sso0 <- as.shinystan(stanfit2) + sso1 <- as.shinystan(stanfit2, pars = "alpha") + sso2 <- as.shinystan(stanfit2, pars = "beta") + sso3 <- as.shinystan(stanfit2, pars = c("alpha", "beta")) + + expect_identical(sso0, sso3) + + sso1names <- c("alpha[1,1]", "alpha[2,1]", "alpha[1,2]", "alpha[2,2]", + "alpha[1,3]", "alpha[2,3]", "log-posterior") + expect_identical(sso1@param_names, sso1names) + expect_identical(rownames(sso1@summary), sort(sso1names)) + expect_identical(sso2@param_names, c("beta", "log-posterior")) + expect_identical(rownames(sso2@summary), c("beta", "log-posterior")) + + expect_equal(dim(sso1@posterior_sample), c(200, 2, 7)) + expect_equal(dim(sso2@posterior_sample), c(200, 2, 2)) +}) + + +# update_sso --------------------------------------------------------------- +context("Updating shinystan objects") +test_that("update_sso errors and messages are correct", { + expect_error(update_sso(1234)) + expect_message(sso2 <- update_sso(sso), "already up-to-date") + expect_is(sso2, "shinystan") + + expect_message(sso3 <- update_sso(old_sso), "object updated") + expect_is(sso3, "shinystan") + expect_identical(sso_version(sso3), utils::packageVersion("shinystan")) + + sso3@misc[["sso_version"]] <- "2.9.5" + expect_error(update_sso(sso3), + regexp = "was created using a more recent version of shinystan") }) diff --git a/tests/testthat/test_deploy_shinystan.R b/tests/testthat/test_deploy_shinystan.R new file mode 100644 index 00000000..0395b86e --- /dev/null +++ b/tests/testthat/test_deploy_shinystan.R @@ -0,0 +1,34 @@ +library(shinystan) +context("Deploying") + +sso <- eight_schools + +# load 'old_sso', a shinystan object created by previous shinystan version +load("old_sso_for_tests.rda") +old_sso_msg <- "use the 'update_sso' function to update your object" + +test_that("deploy_shinystan error checking works", { + expect_error(deploy_shinystan(old_sso), old_sso_msg) + expect_error(deploy_shinystan(sso@posterior_sample), + regexp = "specify a shinystan object") + expect_error(deploy_shinystan(sso), + regexp = "'appName' is required") +}) + +test_that("deploy_shinystan preprocessing doesn't error", { + expect_silent(deploy_test <- deploy_shinystan(sso, appName = "test", deploy = FALSE)) + expect_true(grepl("shinystan", deploy_test, ignore.case = TRUE)) + expect_true(dir.exists(deploy_test)) +}) + +test_that("deploy_shinystan pp_check processing functions ok", { + x <- "123454321" + expect_output(cat(.y_lines(x)), x) + expect_output(cat(.yrep_lines(x)), x) + + deploy_pp_test <- deploy_shinystan(sso, appName = "test", deploy = FALSE, + ppcheck_data = rep(1, 8), + ppcheck_yrep = "yrep") + expect_true(dir.exists(deploy_pp_test)) +}) + diff --git a/tests/testthat/test_manipulating_sso.R b/tests/testthat/test_manipulating_sso.R deleted file mode 100644 index f6ab332f..00000000 --- a/tests/testthat/test_manipulating_sso.R +++ /dev/null @@ -1,27 +0,0 @@ -library(shinystan) - -context("Working with sso") - -source("data_for_tests.R") -sso <- eight_schools - -test_that("retrieve works", { - whats <- c("median", "mean", "rhat", "ess", "sd") - for (what in whats) { - expect_equal(retrieve(sso, what), get(paste0("demo_",what))) - } -}) -test_that("simple sso functions work", { - sso2 <- rename_model(sso, "test_rename") - expect_identical(sso2@model_name, "test_rename") - - sso2 <- model_code(sso, "test_code") - expect_identical(model_code(sso2), "test_code") - expect_identical(model_code(sso2), slot(sso2, "model_code")) - - sso2 <- notes(sso, "test_notes_replace", replace = TRUE) - expect_identical(slot(sso2, "user_model_info"), "test_notes_replace") - sso2 <- notes(sso2, "test_notes_keep", replace = FALSE) - expect_identical(slot(sso2, "user_model_info"), notes(sso2)) -}) - diff --git a/tests/testthat/test_options.R b/tests/testthat/test_misc.R similarity index 50% rename from tests/testthat/test_options.R rename to tests/testthat/test_misc.R index b50f6db6..d98cea74 100644 --- a/tests/testthat/test_options.R +++ b/tests/testthat/test_misc.R @@ -1,10 +1,9 @@ library(shinystan) - -context("launch options") +context("Misc") test_that("options set when package loads", { - expect_that(getOption("shinystan.rstudio"), is_false()) + expect_false(getOption("shinystan.rstudio")) options(shinystan.rstudio = TRUE) - expect_that(getOption("shinystan.rstudio"), is_true()) + expect_true(getOption("shinystan.rstudio")) options(shinystan.rstudio = FALSE) }) diff --git a/tests/testthat/test_using_sso.R b/tests/testthat/test_using_sso.R new file mode 100644 index 00000000..04784c20 --- /dev/null +++ b/tests/testthat/test_using_sso.R @@ -0,0 +1,158 @@ +library(shinystan) +context("Using shinystan objects") + +sso <- eight_schools +not_sso <- sso@model_name +not_sso_msg <- "specify a shinystan object" + +# load 'old_sso', a shinystan object created by previous shinystan version +load("old_sso_for_tests.rda") +old_sso_msg <- "use the 'update_sso' function to update your object" + + +# launch_shinystan -------------------------------------------------------- +test_that("launch_shinystan throws appropriate errors", { + expect_error(launch_shinystan(sso@summary), "not a valid input") + expect_error(launch_shinystan(old_sso), old_sso_msg) +}) + + +# model_name -------------------------------------------------------------- +test_that("model_name works", { + expect_error(model_name(old_sso), old_sso_msg) + expect_error(model_name(not_sso), not_sso_msg) + sso2 <- model_name(sso, "test_rename") + expect_identical(model_name(sso2), "test_rename") + expect_error(model_name(sso, 1234), "should be a single string") + expect_error(model_name(sso, c("a", "b")), "should be a single string") +}) + +# model_code -------------------------------------------------------------- +test_that("model_code works", { + expect_error(model_code(old_sso), old_sso_msg) + expect_error(model_code(not_sso), not_sso_msg) + sso2 <- model_code(sso, "test_code") + expect_identical(model_code(sso2), "test_code") + expect_identical(model_code(sso2), slot(sso2, "model_code")) + expect_error(model_code(sso, 1234), "should be NULL or a string") +}) + +# notes ------------------------------------------------------------------- +test_that("notes works", { + expect_error(notes(old_sso), old_sso_msg) + expect_error(notes(not_sso), not_sso_msg) + sso2 <- notes(sso, "test_notes_replace", replace = TRUE) + expect_identical(slot(sso2, "user_model_info"), "test_notes_replace") + sso2 <- notes(sso2, "test_notes_keep", replace = FALSE) + expect_identical(slot(sso2, "user_model_info"), notes(sso2)) + expect_error(notes(sso, 1234), "should be a single string") + expect_error(notes(sso, c("a", "b")), "should be a single string") +}) + + +# retrieve ---------------------------------------------------------------- +test_that("retrieve works", { + source("data_for_retrieve_tests.R") + expect_error(retrieve(old_sso), old_sso_msg) + expect_error(retrieve(not_sso), not_sso_msg) + expect_error(retrieve(not_sso, what = "mean"), not_sso_msg) + + stats1 <- c("median", "mean", "rhat", "ess", "sd", "mcse") + whats <- c(stats1, "quantiles", "divergent", "treedepth", "stepsize", "accept_stat") + for (what in whats) + expect_equal(retrieve(sso, what), get(paste0("test_answer_", what))) + + for (what in stats1) + expect_equal(names(retrieve(sso, what, pars = c("mu", "tau"))), c("mu", "tau")) + + expect_equal(rownames(retrieve(sso, what = "quantiles", pars = c("mu", "theta[2]"))), + c("mu", "theta[2]")) +}) + + +# generate_quantity ------------------------------------------------------- +test_that("generate_quantity works", { + expect_error(generate_quantity(old_sso), old_sso_msg) + expect_error(generate_quantity(not_sso), not_sso_msg) + + sso2 <- generate_quantity(sso, fun = function(x) x^2, + param1 = "tau", new_name = "tau_sq") + expect_equivalent(sso2@posterior_sample[,, "tau_sq", drop=FALSE], + sso@posterior_sample[,, "tau", drop=FALSE]^2) + + sso2 <- generate_quantity(sso, fun = "-", + param1 = "theta[1]", param2 = "theta[2]", + new_name = "theta1minus2") + expect_equivalent(sso2@posterior_sample[,, "theta1minus2", drop=FALSE], + sso@posterior_sample[,, "theta[1]", drop=FALSE] - + sso@posterior_sample[,, "theta[2]", drop=FALSE]) + + # test when sso only has one chain + sso3 <- as.shinystan(list(cbind(b1 = rnorm(100), b2 = rnorm(100), s = rexp(100)))) + sso3 <- generate_quantity(sso3, param1 = "b1", param2 = "b2", + fun = "+", new_name = "b1plusb2") + expect_equivalent(sso3@posterior_sample[,, "b1plusb2", drop=FALSE], + sso3@posterior_sample[,, "b1", drop=FALSE] + + sso3@posterior_sample[,, "b2", drop=FALSE]) +}) + + +# drop_parameters --------------------------------------------------------- +test_that("drop_parameters throws correct warnings/errors", { + expect_error(drop_parameters(old_sso, pars = "mu"), old_sso_msg) + expect_error(drop_parameters(not_sso, pars = "mu"), not_sso_msg) + expect_error(drop_parameters(sso, pars = "log-posterior"), + "log-posterior can't be dropped") + expect_error(drop_parameters(sso, pars = c("theta[1]", "mu")), + regexp = "individual elements") + expect_error(drop_parameters(sso, pars = "omega"), regexp = "No matches") + expect_warning(drop_parameters(sso, pars = c("mu", "omega")), + regexp = "not found and ignored: omega") +}) +test_that("drop_parameters works", { + pn <- sso@param_names + pd <- sso@param_dims + s <- sso@summary + samp <- sso@posterior_sample + + sso2 <- drop_parameters(sso, pars = "mu") + expect_identical(sso2@param_names, pn[pn != "mu"]) + expect_identical(sso2@param_dims, pd[names(pd) != "mu"]) + expect_identical(sso2@summary, s[rownames(s) != "mu", ]) + expect_identical(sso2@posterior_sample, samp[,, dimnames(samp)[[3]] != "mu"]) + + sso2 <- drop_parameters(sso, pars = "theta") + expect_identical(sso2@param_names, grep("theta", pn, value = TRUE, invert = TRUE)) + expect_identical(sso2@param_dims, pd[names(pd) != "theta"]) + tmp <- s[grep("theta", rownames(s), value = TRUE, invert = TRUE), ] + expect_identical(sso2@summary, tmp) + tmp <- samp[,, grep("theta", dimnames(samp)[[3]], value = TRUE, invert = TRUE)] + expect_identical(sso2@posterior_sample, tmp) + + sso2 <- drop_parameters(sso, pars = c("theta", "tau")) + tmp <- grep("theta|tau", pn, value = TRUE, invert = TRUE) + expect_identical(sso2@param_names, tmp) + tmp <- pd[grep("theta|tau", names(pd), value = TRUE, invert = TRUE)] + expect_identical(sso2@param_dims, tmp) + tmp <- s[grep("theta|tau", rownames(s), value = TRUE, invert = TRUE), ] + expect_identical(sso2@summary, tmp) + tmp <- samp[,, grep("theta|tau", dimnames(samp)[[3]], value = TRUE, invert = TRUE)] + expect_identical(sso2@posterior_sample, tmp) +}) + + +# sso_info ---------------------------------------------------------------- +test_that("sso_info error checking", { + expect_error(sso_info(old_sso), old_sso_msg) + expect_error(sso_info(sso@posterior_sample), "specify a shinystan object") +}) + +test_that("sso_info prints output", { + expect_output(sso_info(sso), "sso") + expect_output(sso_info(sso), "Model name: Demo") + expect_output(sso_info(sso), "Parameters: 11") + expect_output(sso_info(sso), "Chains: 4") + expect_output(sso_info(sso), "Has model code: TRUE") + expect_output(sso_info(sso), "Has user notes: FALSE") +}) + diff --git a/vignettes/deploy_shinystan.Rmd b/vignettes/deploy_shinystan.Rmd index a144ac1c..3bb05203 100644 --- a/vignettes/deploy_shinystan.Rmd +++ b/vignettes/deploy_shinystan.Rmd @@ -16,22 +16,31 @@ Create a ShinyStan app unique to your model and host it online with RStudio's Sh **Signup** -To deploy your app to RStudio's shinyapps.io you will need a ShinyApps account. If you don't already have one you can sign up at http://www.shinyapps.io/. +To deploy your app to RStudio's shinyapps.io you will need a ShinyApps account. +If you don't already have one you can sign up at http://www.shinyapps.io/. -The only limit to the number of different ShinyStan apps you can deploy is the limit set by RStudio for the [type of ShinyApps account](https://www.shinyapps.io/#pricing) you sign up for. +The only limit to the number of different ShinyStan apps you can deploy is the +limit set by RStudio for the [type of ShinyApps +account](https://www.shinyapps.io/#pricing) you sign up for. **Setup** -After signing up for a ShinyApps account, follow the instructions for setting up your account on your local system using the `setAccountInfo` function in the `rsconnect` package. If you don't have the `rsconnect` package installed you can install it by running +When you finish signing up for your ShinyApps account there will be instructions +for setting up your account on your local system using `rsconnect::setAccountInfo`. +If you have the most recent version of **shinystan** then you will already have +**rsconnect** installed and you can call ```r -devtools::install_github("rstudio/rsconnect") +rsconnect::setAccountInfo(name, token, secret) ``` +where `name` is your ShinyApps account name, and `token` and `secret` can be +found from your ShinyApps account web page. ## Step 2: Use `deploy_shinystan` to deploy your app to shinyapps.io -The `deploy_shinystan` function will deploy a ShinyStan app unique to your model to RStudio's ShinyApps service. +The `deploy_shinystan` function will deploy a ShinyStan app unique to your model +to RStudio's ShinyApps service. For the example below assume that diff --git a/vignettes/shinystan-package.Rmd b/vignettes/shinystan-package.Rmd index dcaeea7b..1010afc5 100644 --- a/vignettes/shinystan-package.Rmd +++ b/vignettes/shinystan-package.Rmd @@ -156,10 +156,10 @@ sso <- model_code(sso, code = my_code) On the home page ShinyStan will display the model name associated with the shinystan object being used. This name can be set by adding the `model_name` argument to `as.shinystan` when creating a shinystan object. For an existing -shinystan object you can use the `rename_model` function like this: +shinystan object you can use the `model_name` function like this: ```r -sso <- rename_model(sso, "new_model_name") +sso <- model_name(sso, "new_model_name") ``` where `"new_model_name"` is the new name you want to give your model.