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

current version (04/29/2019)

parent d59a2565
No related branches found
No related tags found
No related merge requests found
# ------------------------------------------------------------------------------
# File: TwoProportionResamplingTest.R
# Authors: Camille Fairbourn, Scott Manski
# Date: 03/26/2019
# Date: 04/29/2019
# Desc: This app performs a two proportion test via randomization. The
# resampling test mimics Fisher's Exact Test.
# Published Location:
......@@ -29,6 +29,12 @@ enableBookmarking(store = "server")
# custom ggplot2 themes.
source("TwoProportionSource.R")
# 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
# defines the presets
Presets <- list()
# Presets`preset name` <- c(Top Left, Bottom Left, Top Right, Bottom Right,
......@@ -84,7 +90,6 @@ ui <- function(request) {
samples that are greater/less than your value."),
tags$p("Selecting 'beyond' will highlight the samples that are further away
from 0 than your value."),
tags$p("Press the Reset button whenever you change the values in the table."),
hr(),
hr(),
tags$p("Written by Scott Manski"),
......@@ -116,12 +121,6 @@ server <- function(input, output, session) {
values$props <- vector()
values$table <- matrix(rep(NA, 9), ncol=3)
# colors for plots
values$hist.fill.color <- "grey70" # histogram bar fill color
values$hist.outline.color <- "black" # histogram bar outline color
values$dot.fill.color <- "grey70" # dotplot dot fill color
values$cutoff.color <- "#F05133" # color for cutoff values
# observe any changes in table
observe({
values$table[1, 1] <- as.numeric(input$TL) # top left position
......@@ -288,8 +287,8 @@ server <- function(input, output, session) {
n <- 4
}
# gets the dotplot locations for the dotplot
df <- dotplot_locs(values$props, n, input$cutoff, values$cutoff.color,
values$dot.fill.color, input$inequality)
df <- dotplot_locs(values$props, n, input$cutoff, cutoff.color,
dot.fill.color, input$inequality)
df <- df[df$x < values$x.lim & df$x > -values$x.lim, ]
myplot <- ggplot(df) +
......@@ -325,12 +324,12 @@ server <- function(input, output, session) {
} else {
to.color <- NA
}
fill.color <- rep(values$hist.fill.color, length(names.counts))
fill.color[to.color] <- values$cutoff.color
fill.color <- rep(hist.fill.color, length(names.counts))
fill.color[to.color] <- cutoff.color
# the histogram is plotted
myplot <- ggplot(df, aes(x=x)) +
geom_histogram(binwidth = max(diff(unique.vals)), fill = fill.color,
col = values$hist.outline.color) +
col = hist.outline.color) +
labs(x = "Shuffled Difference in Proportions", y = "Count") +
scale_x_continuous(limits = c(-values$x.lim, values$x.lim)) +
plaintheme + axistheme
......@@ -360,7 +359,7 @@ server <- function(input, output, session) {
if (is.na(values$prob)){
" "
} else if (!is.na(as.numeric(input$cutoff))){
paste("<font color=", values$cutoff.color, "><b>",values$count, "/",
paste("<font color=", cutoff.color, "><b>",values$count, "/",
length(values$props), " (", round(values$prob, 4), ")",
"</b></font>", sep = "")
} else if (nchar(input$cutoff)!=0){
......
......@@ -65,18 +65,18 @@ html_table <- HTML("<script type='text/javascript'>
<tbody>
<tr>
<td></td>
<td><input size='1' id='C1N'type = 'text' onchange='Expand2();' oninput='Expand2();' value='Column A'></td>
<td><input size='1' id='C2N'type = 'text' onchange='Expand3();' oninput='Expand3();' value='Column B'></td>
<td><input size='10' id='C1N'type = 'text' onchange='Expand2();' oninput='Expand2();' value='Column A'></td>
<td><input size='10' id='C2N'type = 'text' onchange='Expand3();' oninput='Expand3();' value='Column B'></td>
<td><div style='padding: 1px 8px'>Total</div></td>
</tr>
<tr>
<td><input size='1' id='R1N'type = 'text' onchange='Expand1();' oninput='Expand1();' value='Row 1'></td>
<td><input size='6' id='R1N'type = 'text' onchange='Expand1();' oninput='Expand1();' value='Row 1'></td>
<td><input size='1' id='TL' type='text' onchange='Expand2();' oninput='Expand2();' value='0'></td>
<td><input size='1' id='TR' type = 'text' onchange='Expand3();' oninput='Expand3();' value='0'></td>
<td><div size='1' style='padding: 1px 8px' id='TRT' class='shiny-text-output'></div></td>
</tr>
<tr>
<td><input size='1' id='R2N' type = 'text' onchange='Expand1();' oninput='Expand1();' value='Row 2'></td>
<td><input size='6' id='R2N' type = 'text' onchange='Expand1();' oninput='Expand1();' value='Row 2'></td>
<td><input size='1' id='BL' type = 'text' onchange='Expand2();' oninput='Expand2();' value='0'></td>
<td><input size='1' id='BR' type = 'text' onchange='Expand3();' oninput='Expand3();' value='0'></td>
<td><div size='1' style='padding: 1px 8px' id='TRB' class='shiny-text-output'></div></td>
......
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