Skip to content
Snippets Groups Projects
Commit 8d677d58 authored by Manski, Scott's avatar Manski, Scott
Browse files

current version (04/22/2019)

parent 953259ab
No related branches found
No related tags found
No related merge requests found
# ------------------------------------------------------------------------------
# File: OneProportionTest.R
# Authors: Camille Fairbourn, Scott Manski
# Date: 04/22/2019
# 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.
source("OneProportionSource.R")
# 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 value."),
tags$p("Selecting 'beyond' will highlight the samples that are further away
from the 'Probability of Success' than your 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", "beyond")), width = 3),
column(textInput("cutoff", NULL), width = 4),
textOutput("counts"))
)
)
)
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 "beyond", finds the number and
# 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(values$count, "/", length(values$props), " (", round(values$prob, 4), ")", sep = "")
} else if (nchar(input$cutoff)!=0){
"Invalid Cutoff!"
} 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))
#theme for plots
plaintheme <- theme_bw() +
theme(plot.background = element_blank(),
panel.grid.major = element_blank(),
panel.grid.minor = element_blank() ) +
theme(axis.line.x = element_line(color="black", size = 1),
axis.line.y = element_line(color="black", size = 1))+
theme(legend.position = "none")
#axis theme for plots
axistheme <- theme(plot.title = element_text(hjust = 0.5, color = "black", face = "bold", size=20)) +
theme(axis.title = element_text(color = "black", size = 16)) +
theme(axis.text.x = element_text(size = 14, color = "black")) +
theme(axis.text.y = element_text(size = 14, color = "black"))
#determines the number of decimal places of a number
decimalcount<-function(x){stopifnot(class(x)=="character")
x<-gsub("(.*)(\\.)|([0]*$)","",x)
as.numeric(nchar(x))
}
# create dotplot locations from data x
dotplot_locs <- function(x, n, cutoff, cutoff.color, dot.fill.color, inequality, Mean){
counts <- table(x)
x.locs <- as.numeric(names(counts))
# find minimum difference between points, with an exeption for a single point
if (length(names(counts)) == 1){
point_dist <- min(diff(c(0, as.numeric(names(counts)))))/(n+2)
} else {
point_dist <- min(diff(as.numeric(names(counts))))/(n+2)
}
# define the standard x coordinates to be used
x.coord <- sapply(x.locs, function(x) x + ((1:n)-(n+1)/2)*point_dist)
x.coords <- vector()
y.coords <- vector()
to.color <- vector()
names.counts <- as.numeric(names(counts))
# loop through each count, defining new x and y coordinates for "dotplot"
for (i in 1:length(counts)){
if (n == 1){
x.coords <- c(x.coords, rep(x.coord[i], counts[i]/n))
} else {
x.coords <- c(x.coords, rep(x.coord[, i], counts[i]/n),
x.coord[0:(counts[i] %% n), i])
}
if (counts[i] > n){
y.coords <- c(y.coords, sort(rep(1:(counts[i]/n), n)),
rep(ceiling(counts[i]/n), counts[i] %% n))
} else {
y.coords <- c(y.coords, sort(rep(1:(counts[i]/n), counts[i])))
}
# defines color of dots when cutoff defined
if(!is.na(as.numeric(cutoff))){
num.decimals <- decimalcount(as.character(cutoff))
# error term for rounded cutoff values
error <- ifelse(num.decimals <= 2, 0, 0.1^num.decimals/2)
if (inequality == "greater than"){
if (names.counts[i] >= as.numeric(cutoff)-error){
to.color <- c(to.color, rep(cutoff.color, counts[i]))
} else {
to.color <- c(to.color, rep(dot.fill.color, counts[i]))
}
} else if (inequality == "less than") {
if (names.counts[i] <= as.numeric(cutoff)+error){
to.color <- c(to.color, rep(cutoff.color, counts[i]))
} else {
to.color <- c(to.color, rep(dot.fill.color, counts[i]))
}
} else {
dist <- abs(Mean - (abs(as.numeric(cutoff))-error))
if ((names.counts[i] <= Mean - dist) |
(names.counts[i] >= Mean + dist)){
to.color <- c(to.color, rep(cutoff.color, counts[i]))
} else {
to.color <- c(to.color, rep(dot.fill.color, counts[i]))
}
}
} else {
to.color <- c(to.color, rep(dot.fill.color, counts[i]))
}
}
return(data.frame("x" = x.coords, "y" = y.coords*n,
"fill.color" = to.color))
}
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment