1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
|
source_ui <- function(...) {
source(
file.path("ui_files", ...),
local = TRUE
)$value
}
save_and_close_button <- function() {
tags$button(
id = 'save_and_close_button',
type = "button",
class = "btn action-button",
onclick = "window.close();",
"Save & Close"
)
}
shinystan_version <- function() {
# prevents error when deployed to shinyapps.io
ver <- try(utils::packageVersion("shinystan"))
if (inherits(ver, "try-error"))
return()
else
strong(paste("Version", ver))
}
logo_and_name <- function() {
div(div(
img(
src = "wide_ensemble.png",
class = "wide-ensemble",
width = "100%"
)
),
div(
style = "margin-top: 25px",
img(src = "stan_logo.png", class = "stan-logo"),
div(id = "shinystan-title", "ShinyStan")
))
}
# save and close reminder -------------------------------------------------
save_and_close_reminder <- function(id) {
helpText(
id = id,
p(
"To make sure the changes aren't lost, use the",
span(class = "save-close-reminder", "Save & Close"),
"button in the top left corner to exit the app before",
"closing the browser window."
)
)
}
# show/hide options/glossary ---------------------------------------------
a_options <- function(name) {
lab <- if (name == "table")
"Table Options" else "Show/Hide Options"
div(class = "aoptions",
checkboxInput(
inputId = paste0(name, "_options_show"),
label = strong(style = "margin-top: 20px; color: #222222;", lab),
value = FALSE
))
}
a_glossary <- function(id) {
div(class = "aoptions",
actionLink(
inputId = id,
label = strong(style = "margin-top: 20px; color: #222222;", "Glossary"),
icon = icon("book", lib = "glyphicon")
))
}
# plotOutput generators ---------------------------------------------------
dygraphOutput_175px <- function(id)
dygraphs::dygraphOutput(id, height = "175px")
plotOutput_200px <- function(id, ...)
plotOutput(id, height = "200px")
plotOutput_400px <- function(id, ...)
plotOutput(id, height = "400px")
# conditionalPanel generator for EXPLORE/density -------------------------
condPanel_dens_together <- function(...) {
conditionalPanel(condition = "input.dens_chain_split == 'Together'", ...)
}
condPanel_dens_prior <- function(dist, ...) {
cond <- paste0("input.dens_prior ==","'", dist,"'")
conditionalPanel(cond, ...)
}
# conditional transparency settings ---------------------------------------
alpha_calc_pt <- function(N) {
if (N <= 100) return(1)
else if (N <= 200) return(0.75)
else if (N >= 1500) return(0.15)
else 1 - pnorm(N/1500)
}
alpha_calc_lines <- function(N) {
if (N < 50) return(0.5)
if (N < 500) return(0.4)
if (N < 1000) return(0.3)
if (N < 5000) return(0.2)
else return(0.1)
}
# transformations ---------------------------------------------------------
transformation_selectInput <- function(id) {
selectInput(
id,
label = NULL,
choices = transformation_choices,
selected = "identity"
)
}
transform_helpText <- function(var = "x") {
div(
if (var == "x")
helpText(style = "font-size: 13px;",
"To apply a transformation",
"select a function and click",
code("Transform"))
else if (var == "x,y")
helpText(style = "font-size: 13px;",
"To apply transformations",
"select a function for x and/or y",
"and click", code("Transform"))
else
helpText(style = "font-size: 13px;",
"To apply transformations",
"select a function for x, y, and/or z",
"and click", code("Transform"))
)
}
# diagnostics help text ---------------------------------------------------
hT11 <- function(...)
helpText(style = "font-size: 11px;", ...)
help_interval <- hT11("Highlighted interval shows \\(\\bar{x} \\pm sd(x)\\)")
help_lines <- hT11("Lines are mean (solid) and median (dashed)")
help_max_td <- hT11("Horizontal line indicates the max_treedepth setting")
help_points <- hT11(
"Large red points indicate which (if any) iterations",
"encountered a divergent transition. Yellow indicates",
"a transition hitting the maximum treedepth."
)
help_dynamic <- hT11(
"Use your mouse to select a range in the traceplot to zoom into. ",
"The other plots on the screen will update accordingly. ",
"Double-click to reset."
)
# ppcheck plot descriptions ----------------------------------------------
plot_descriptions <-
c(
plot_hists_rep_vs_obs = "Distributions of observed data and a random sample of replications",
plot_dens_rep_vs_obs = "Density estimate of observed data (blue) and a random sample of replications",
plot_obs_vs_avg_y_rep = "Observations vs average simulated value",
plot_hist_resids = "Residuals",
plot_avg_rep_vs_avg_resid_rep = "Average simulated value vs average residual",
plot_test_statistics = "Distributions of test statistics \\(T(y^{rep})\\)"
)
# stan manual reference ---------------------------------------------------
stan_manual <- function() {
helpText(
style = "font-size: 12px;",
"Glossary entries are compiled (with minor edits) from various excerpts of the",
a(
"Stan Modeling Language User's Guide and Reference Manual",
href = "http://mc-stan.org/documentation/"
),
"(",
a(href = "http://creativecommons.org/licenses/by/3.0/", "CC BY (v3)"),
")"
)
}
# objects to use in ui.R and ui_files -------------------------------------
if (!exists(".SHINYSTAN_OBJECT")) {
.SHINYSTAN_OBJECT <- shinystan:::.sso_env[[".SHINYSTAN_OBJECT"]]
}
.model_name <- slot(.SHINYSTAN_OBJECT, "model_name")
.param_names <- slot(.SHINYSTAN_OBJECT, "param_names")
.param_list <- .make_param_list(.SHINYSTAN_OBJECT)
.param_list_with_groups <- .make_param_list_with_groups(.SHINYSTAN_OBJECT)
.nChains <- slot(.SHINYSTAN_OBJECT, "n_chain")
.nIter <- slot(.SHINYSTAN_OBJECT, "n_iter")
.nWarmup <- slot(.SHINYSTAN_OBJECT, "n_warmup")
.model_code <- slot(.SHINYSTAN_OBJECT, "model_code")
.notes <- slot(.SHINYSTAN_OBJECT, "user_model_info")
.has_rstanarm_ppcs <-
isTRUE(.SHINYSTAN_OBJECT@misc$stanreg) &&
!is.null(.SHINYSTAN_OBJECT@misc$pp_check_plots)
if (exists("object"))
rm(object)
if (exists(".SHINYSTAN_OBJECT"))
rm(.SHINYSTAN_OBJECT)
gc()
|
