Nothing
# 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 <http://www.gnu.org/licenses/>.
#' Drop parameters from a \code{shinystan} object
#'
#' Remove selected parameters from a \code{shinystan} object. This is useful if
#' you have a very large \code{shinystan} object when you only want to look at a
#' subset of parameters. With a smaller \code{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
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.