Newer
Older
# ------------------------------------------------------------------------------
# Desc:
# Published Location:
# Email: fairbour@msu.edu, manskisc@msu.edu
#
# For questions or concerns, please email the authors. This work is licensed
# under a Creative Commons Attribution-ShareAlike 4.0 International License
# (https://creativecommons.org/licenses/by-sa/4.0/).
# ------------------------------------------------------------------------------
# loading packages
library(shiny)
library(ggplot2)
library(dplyr)
library(BHH2)
library(gridExtra)
library(shinyjs)
# Sources objects, functions, etc, from OneProportionSource.R
# This file contains the html code for the editable table,
# the decimalcount function, the dotplot_locs function, and
# custom ggplot2 themes.
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
# defines the presets
Presets <- list()
# Presets`preset name` <- c(Probability of Success, Sample Size)
Presets$`Coin Flipping` <- c(0.5, 10)
Presets$`Medical Consultant` <- c(0.048, 62)
Presets$Custom <- c("", "")
# colors for plots
hist.fill.color <- "grey70" # histogram bar fill color
hist.outline.color <- "black" # histogram bar outline color
dot.fill.color <- "grey70" # dotplot dot fill color
cutoff.color <- "#F05133" # color for cutoff values
ui <- fluidPage(useShinyjs(),
titlePanel("One Proportion Resampling Test"),
sidebarLayout(
sidebarPanel(
tabsetPanel(
tabPanel("Shuffle",
tags$div(class="header", checked = NA,
tags$p(" ")
),
hr(),
selectInput("plot", "Plot Type", c("Dotplot", "Histogram")),
selectInput("prop.counts", "Proportion or Counts", c("Proportion",
"Counts")),
selectInput("presets", "Presets", choices = names(Presets), selected = "Custom"),
numericInput("probability", "Probability of Success", value = 0.5, min = 0, max = 1),
numericInput("sampsize", "Sample Size", value = 10, min = 1),
actionButton("Reset", "Reset"),
numericInput("numsamp", "Number of Samples", value = 100, min = 1),
tags$div(class="header", checked = NA,
tags$p("Enter a value from 1 to 5000")
),
actionButton("Replicate", "Draw Samples")
),
tabPanel("Instructions",
tags$div(class="header", checked = NA,
tags$p("Enter the value of the population (or model) proportion
in the 'Probability of Success' field."),
tags$p("Choose your sample size and the number of samples you
wish the app to generate. Then press the 'Draw Samples'
button."),
tags$p("Enter the value of your observed proportion in the text
under the graph. Selecting 'greater/less than' will highlight the
samples that are greater/less than your observed value."),
tags$p("Selecting 'further from center than' will highlight the samples that are
further away from (either above or below) the 'Probability of Success'
than your observed value."),
tags$p("Press the Reset button whenever you change the Probability of Success
or the Sample Size."),
hr(),
hr(),
tags$p("Written by Scott Manski"),
tags$p("This work is licensed under a "),
tags$a(href="http://creativecommons.org/licenses/by-sa/4.0/",
"Creative Commons Attribution-ShareAlike 4.0 International License")
)
))),
mainPanel(
plotOutput("SamplingDistribution"),
checkboxInput("show.curve", "Overlay Normal Curve", FALSE),
checkboxInput("show.summary", "Show summary statistics", FALSE),
textOutput("summary"),
fluidRow(
column(textOutput("count.samples"), width = 3),
column(selectInput("inequality", NULL, c("greater than", "less than", "further from center than")), width = 3),
column(textInput("cutoff", NULL), width = 4),
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
)
)
)
server <- function(input, output, session) {
# initialize values for use in server
values <- reactiveValues()
values$props <- vector()
# disable or enable the "Shuffle" button
# the "Shuffle" button in enabled when the number of shuffles is less than
# 5,000 and the total number of shuffles is less than 20,000
# sample size and probability must also be valid (n > 0 and 0 <= p <= 1)
observeEvent(c(input$Reset, input$numsamp, input$probability, input$sampsize), {
if (is.numeric(input$numsamp) & is.numeric(input$probability) & is.numeric(input$sampsize)){
if (input$numsamp > 5000 || input$numsamp < 1 || !is.integer(input$numsamp)){
disable("Replicate")
} else if (input$probability < 0 | input$probability > 1){
disable("Replicate")
} else if (input$sampsize <= 0) {
disable("Replicate")
} else if (length(values$props) <= 20000) {
enable("Replicate")
}
} else {
disable("Replicate")
}
})
# reset the values if "Reset" is pressed or if n or p are changed
observeEvent(c(input$Reset, input$presets, input$probability, input$sampsize), {
values$props <- vector()
if (input$prop.counts == "Proportion"){
values$mean <- input$probability
} else {
values$mean <- input$sampsize*input$probability
}
})
# appropriately change values if Proportions or Counts is selected
observeEvent(input$prop.counts, {
if (input$prop.counts == "Proportion"){
values$props <- values$props/input$sampsize
values$mean <- input$probability
} else {
values$props <- values$props*input$sampsize
values$mean <- input$sampsize*input$probability
}
if (!is.na(as.numeric(input$cutoff))){
if (input$prop.counts == "Proportion"){
updateTextInput(session, "cutoff", value = as.numeric(input$cutoff)/input$sampsize)
} else {
updateTextInput(session, "cutoff", value = as.numeric(input$cutoff)*input$sampsize)
}
}
})
# update the values when shuffle is pressed
update_vals <- eventReactive(input$Replicate, {
if (input$prop.counts == "Proportion"){
new.vals <- rbinom(input$numsamp, input$sampsize, input$probability)/input$sampsize
} else {
new.vals <- rbinom(input$numsamp, input$sampsize, input$probability)
}
values$props <- c(values$props, new.vals)
if (length(values$props) >= 20000){
disable("Replicate")
} else {
enable("Replicate")
}
})
# update the counts for the cutoff if there are any changes
update_counts <- eventReactive(c(input$cutoff, input$Replicate, input$Reset, input$inequality, input$presets), {
if (!is.na(as.numeric(input$cutoff))){
# the error is used to handle rounded values of input$cutoff
num.decimals <- decimalcount(as.character(input$cutoff))
error <- ifelse(num.decimals <= 2, 0, 0.1^num.decimals/2)
# for "greater than", finds the number and proportion of values greater than
# input$cutoff - error. For "less than", finds the number and proportion of
# values less than input$cutoff + error. For "further from center than", finds the number and
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
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
# proportion of values less than (mean - diff) + error and values greater than
# (mean + diff) - error, where diff is |input$cutoff - mean|
if (input$inequality == "greater than"){
values$prob <- sum(values$props >= as.numeric(input$cutoff)-error)/length(values$props)
values$count <- sum(values$props >= as.numeric(input$cutoff)-error)
} else if (input$inequality == "less than") {
values$prob <- sum(values$props <= as.numeric(input$cutoff)+error)/length(values$props)
values$count <- sum(values$props <= as.numeric(input$cutoff)+error)
} else {
values$prob <- (sum(values$props <= (values$mean-abs(values$mean-as.numeric(input$cutoff)))+error)+
sum(values$props >= (values$mean+abs(values$mean-as.numeric(input$cutoff)))-error))/length(values$props)
values$count <- sum(values$props <= (values$mean-abs(values$mean-as.numeric(input$cutoff)))+error)+
sum(values$props >= (values$mean+abs(values$mean-as.numeric(input$cutoff)))-error)
}
}
})
# create the desired plot
output$SamplingDistribution <- renderPlot({
update_vals()
if (length(values$props) != 0){ # after reset, values$props is empty
if (input$plot == "Dotplot"){ # plot == TRUE is dotplot, FALSE is histogram
# n is the number of columns for the dotplot. Large datasets will have n <- 1
if (input$sampsize > 1000){
n <- 1
} else {
n <- 4
}
# gets the dotplot locations for the dotplot
df <- dotplot_locs(values$props, n, input$cutoff, cutoff.color,
dot.fill.color, input$inequality, values$mean)
# creates dotplot with appropriate fill colors
if (!is.na(as.numeric(input$cutoff))){
myplot <- ggplot(df) +
geom_point(aes(x ,y, colour = fill.color), size=min(n, 50/length(values$props)^0.5)) +
scale_colour_manual(name = cutoff.color, values = levels(df$fill.color)) +
theme(legend.position="none")
} else {
myplot <- ggplot(df) +
geom_point(aes(x ,y, colour = fill.color), size=min(n, 50/length(values$props)^0.5)) +
scale_colour_manual(name = dot.fill.color, values = levels(df$fill.color)) +
theme(legend.position="none")
}
finalplot <- myplot + scale_y_continuous(limits = c(0, max(n*7.5,max(df$y)*1.01)))
} else {
# creates histogram
df <- data.frame("x" = values$props)
unique.vals <- sort(unique(as.numeric(as.character(df$x))))
if (!is.na(as.numeric(input$cutoff))){
num.decimals <- decimalcount(as.character(input$cutoff))
error <- ifelse(num.decimals <= 2, 0, 0.1^num.decimals/2)
# a histogram is created to determine the bars that need to be colored
myplot <- ggplot(df, aes(x=x)) + geom_histogram(binwidth = max(diff(unique.vals)))
names.counts <- ggplot_build(myplot)$data[[1]]$x
if (input$inequality == "greater than"){
to.color <- which(names.counts >= as.numeric(input$cutoff)-error)
} else if (input$inequality == "less than"){
to.color <- which(names.counts <= as.numeric(input$cutoff)+error)
} else{
to.color <- c(which(names.counts <= (values$mean-abs(values$mean-as.numeric(input$cutoff)))+error),
which(names.counts >= (values$mean+abs(values$mean-as.numeric(input$cutoff)))-error))
}
fill.color <- rep(dot.fill.color, length(names.counts))
fill.color[to.color] <- cutoff.color
myplot <- ggplot(df, aes(x=x)) + geom_histogram(binwidth = max(diff(unique.vals)),
fill = fill.color, col = hist.outline.color)
} else {
myplot <- ggplot(df, aes(x=x)) + geom_histogram(binwidth = max(diff(unique.vals)),
fill = hist.fill.color,
col = hist.outline.color)
}
finalplot <- myplot
}
# make appropriate changes if Proportions or Counts is selected
xlabel <- ifelse(input$prop.counts == "Proportion", "Proportion of Successes", "Number of Successes")
MEAN <- ifelse(input$prop.counts == "Proportion", input$probability, input$probability*input$sampsize)
SD <- ifelse(input$prop.counts == "Proportion", sqrt(input$probability*(1-input$probability)/input$sampsize),
sqrt(input$probability*(1-input$probability)*input$sampsize))
finalplot <- finalplot + plaintheme + axistheme + labs(x = xlabel, y = "Count")
# adds normal curve if checkbox is selected
if (input$show.curve == TRUE){
if (input$plot == "Dotplot"){
finalplot <- finalplot +
stat_function(fun = function(x) dnorm(x, mean = MEAN, sd = SD) * max(df$y) / dnorm(MEAN, MEAN, SD))
} else {
finalplot <- finalplot +
stat_function(fun = function(x) dnorm(x, mean = MEAN, sd = SD) * max(diff(unique.vals)) * length(values$props))
}
}
finalplot
}
})
# calculate the summary statistics when checkbox is TRUE
# summary statistics are different for Proportions and Counts
output$summary <- renderText({
if (input$show.summary && length(values$props != 0)){
if (input$prop.counts == "Proportion"){
mymean <- input$probability
mysd <- sqrt(input$probability*(1-input$probability)/input$sampsize)
} else {
mymean <- input$sampsize*input$probability
mysd <- sqrt(input$probability*(1-input$probability)*input$sampsize)
}
paste("Mean = ", round(mymean, 2), " SD = ", round(mysd, 4), sep = "")
}
})
# text for sample counts
output$count.samples <- renderText({
"Count Samples"
})
# counts when cutoff is specified
output$counts <- renderText({
update_counts()
if (!is.null(values$prob)){
if (is.na(values$prob)){
" "
} else if (!is.na(as.numeric(input$cutoff))){
paste("<font color=", cutoff.color, "><b>",values$count, "/",
length(values$props), " (", round(values$prob, 4), ")",
"</b></font>", sep = "")
} else {
" "
}
}
})
# updates probability and sample size when preset is chosen
observeEvent(input$presets, {
preset <- which(names(Presets) == input$presets)
updateNumericInput(session, "probability", value = Presets[[preset]][1])
updateNumericInput(session, "sampsize", value = Presets[[preset]][2])
})
}
shinyApp(ui = ui, server = server, options = list(height = 1080))