Skip to content
Snippets Groups Projects
Commit 0452102c authored by CamilleFairbourn's avatar CamilleFairbourn
Browse files

Mosaic plot apps first upload

parent 99137299
No related branches found
No related tags found
No related merge requests found
Hide whitespace changes
Inline Side-by-side
Showing
with 748 additions and 0 deletions
MosaicPlotsThree/app.R 0 → 100644
+ 223
− 0
View file @ 0452102c
# ------------------------------------------------------------------------------
# File: TwoProportionMosaicPlotsThree/app.R
# Authors: Camille Fairbourn, Sang Kyu Lee
# Date: 05/07/2020
# Desc: This app makes a mosaic plot for three proportion case for 3 by 3 table.
# Published Location:
# Email: fairbour@msu.edu, leesa111@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/).
# ------------------------------------------------------------------------------
library(shiny)
library(ggplot2)
library(dplyr)
library(BHH2)
library(gridExtra)
library(shinyjs)
enableBookmarking(store = "server")
# Sources objects, functions, etc, from TwoProportionSource.R
# This file contains the html code for the editable table,
# the decimalcount function, the dotplot_locs function, and
# custom ggplot2 themes.
source("www/TwoProportionSourceThree.R")
# defines the presets
Presets <- list()
Presets$`Celebrating Christmas` <- c(8, 18, 4, 22, 12, 6, 7, 13, 5, "Not too", "Somewhat", "Strongly", "Conservative", "LIberal", "Moderate")
Presets$`Custom` <- c(0, 0, 0, 0, 0, 0, 0, 0, 0, "Column A", "Column B", "Column C", "Row 1", "Row 2", "Row 3")
ui <- function(request) {
fluidPage(useShinyjs(),
titlePanel("Three-by-three Mosaic Plot"),
sidebarLayout(
sidebarPanel(
tabsetPanel(
tabPanel("Instruction",
tags$div(class="header", checked = NA,
tags$p("Enter your data into the table
below, or choose one of the data
presets. Press the submit button
to make a mosaic plot. By clicking twice,
you can fix the numbers and the names."
)
),
hr(),
selectInput(inputId = "presets",
label = "Presets",
selected = "Custom", # selects the initial preset
choices = names(Presets)),
html_table1,
hr(),
actionButton("Replicate", "Submit"),
hr(),
tags$p("Written by Sang Kyu Lee"),
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"),
hr(),
bookmarkButton()
))),
mainPanel(
plotOutput("RandomPlot"),
textOutput("example")
)
)
)}
server <- function(input, output, session){
# initialize values for use in server
values <- reactiveValues()
values$props <- vector()
values$table <- matrix(rep(NA, 16), ncol=4)
# observe any changes in table
observe({
values$table[1, 1] <- as.numeric(input$One1) # (1,1) position
values$table[1, 2] <- as.numeric(input$One2) # (1,2) position
values$table[1, 3] <- as.numeric(input$One3) # (1,3) position
values$table[2, 1] <- as.numeric(input$Two1) # (2,1) position
values$table[2, 2] <- as.numeric(input$Two2) # (2,2) position
values$table[2, 3] <- as.numeric(input$Two3) # (2,3) position
values$table[3, 1] <- as.numeric(input$Three1) # (3,1) position
values$table[3, 2] <- as.numeric(input$Three2) # (3,2) position
values$table[3, 3] <- as.numeric(input$Three3) # (3,3) position
values$table[1, 4] <- as.numeric(input$One1) + as.numeric(input$One2) + as.numeric(input$One3) # first row sum
values$table[2, 4] <- as.numeric(input$Two1) + as.numeric(input$Two2) + as.numeric(input$Two3) # second row sum
values$table[3, 4] <- as.numeric(input$Three1) + as.numeric(input$Three2) + as.numeric(input$Three3) # third row sum
values$table[4, 1] <- as.numeric(input$One1) + as.numeric(input$Two1) + as.numeric(input$Three1) # first column sum
values$table[4, 2] <- as.numeric(input$One2) + as.numeric(input$Two2) + as.numeric(input$Three2) # second column sum
values$table[4, 3] <- as.numeric(input$One3) + as.numeric(input$Two3) + as.numeric(input$Three3) # third column sum
values$table[4, 4] <- as.numeric(input$One1) + as.numeric(input$One2) + as.numeric(input$One3) +
as.numeric(input$Two1) + as.numeric(input$Two2) + as.numeric(input$Two3) +
as.numeric(input$Three1) + as.numeric(input$Three2) + as.numeric(input$Three3)
values$table.names[1] <- as.character(input$C1N)
values$table.names[2] <- as.character(input$C2N)
values$table.names[3] <- as.character(input$C3N)
values$table.names[4] <- as.character(input$R1N)
values$table.names[5] <- as.character(input$R2N)
values$table.names[6] <- as.character(input$R3N)
})
# output for values of table if there is a change
output$TR1 <- renderText({ # TRT
values$table[1, 4]
})
output$TR2 <- renderText({ # TRB
values$table[2, 4]
})
output$TR3 <- renderText({
values$table[3, 4]
})
output$TC1 <- renderText({ # TBL
values$table[4, 1]
})
output$TC2 <- renderText({ # TBR
values$table[4, 2]
})
output$TC3 <- renderText({
values$table[4, 3]
})
output$Total <- renderText({
values$table[4, 4]
})
observeEvent(c(input$One1, input$One2, input$One3, input$Two1, input$Two2, input$Two3, input$Three1,
input$Three2, input$Three3, input$C1N, input$C2N, input$C3N,
input$R1N, input$R2N, input$R3N), {
# combine the current table inputs into a vector
current <- c(input$One1, input$One2, input$One3, input$Two1, input$Two2, input$Two3, input$Three1,
input$Three2, input$Three3, input$C1N, input$C2N, input$C3N,
input$R1N, input$R2N, input$R3N)
# loops through each preset and determines the number of cells that match the current table
preset <- unlist(lapply(names(Presets), function(i) {
sum(Presets[[i]] == current)
}))
# if all cells match, change the SelectInput value to that preset,
# otherwise change the value to "Custom"
if (sum(preset == 15) > 0) {
updateSelectInput(session, "presets", selected = names(Presets)[which(preset == 15)])
} else {
updateSelectInput(session, "presets", selected = "Custom")
}
}, ignoreInit = TRUE)
# trigger when the submit is pressed
observeEvent(input$Replicate, {
if(!is.na(values$table[4,1])) values$props <- TRUE
})
observeEvent(input$presets, {
values$props <- vector()
enable("Replicate")
if (input$presets != "Custom") {
preset_index <- which(names(Presets) == input$presets)
preset <- Presets[[preset_index]]
DF <- data.frame("X1" = as.numeric(preset[1:3]),
"X2" = as.numeric(preset[4:6]),
"X3" = as.numeric(preset[7:9]))
DF[4, ] <- apply(DF, 2, sum)
DF[, 4] <- apply(DF, 1, sum)
values$table <- DF
values$table.names <- preset[10:15]
updateTextInput(session, "One1", value = values$table[1,1])
updateTextInput(session, "One2", value = values$table[1,2])
updateTextInput(session, "One3", value = values$table[1,3])
updateTextInput(session, "Two1", value = values$table[2,1])
updateTextInput(session, "Two2", value = values$table[2,2])
updateTextInput(session, "Two3", value = values$table[2,3])
updateTextInput(session, "Three1", value = values$table[3,1])
updateTextInput(session, "Three2", value = values$table[3,2])
updateTextInput(session, "Three3", value = values$table[3,3])
updateTextInput(session, "C1N", value = values$table.names[1])
updateTextInput(session, "C2N", value = values$table.names[2])
updateTextInput(session, "C3N", value = values$table.names[3])
updateTextInput(session, "R1N", value = values$table.names[4])
updateTextInput(session, "R2N", value = values$table.names[5])
updateTextInput(session, "R3N", value = values$table.names[6])
}
})
output$RandomPlot <- renderPlot({
if (length(values$props) != 0){
df <- values$table
names <- values$table.names
tab <- as.table(matrix(data=c(df[1:3,1], df[1:3,2], df[1:3,3]), nrow=3, byrow=TRUE))
dimnames(tab) <- list(Column=names[1:3], Row=names[4:6])
mosaicplot(tab, main= " ", ylab=" ", xlab = " ",
color=c("#569BBD", "#4C721D", "#F4DC00"), cex.axis = 1)
}
})
# when the bookmark button is pressed, the current values of props and table are saved
onBookmark(function(state) {
state$values$props <- values$props
state$values$table <- values$table
})
# when opening a bookmarked page, props is restored
onRestored(function(state) {
values$props <- state$values$props
})
# when opening a bookmarked page, table is restored
onRestore(function(state) {
values$table <- state$values$table
})
}
shinyApp(ui = ui, server = server, options = list(height = 1080), enableBookmarking = "server")
\ No newline at end of file
MosaicPlotsThree/www/TwoProportionSourceThree.R 0 → 100644
+ 125
− 0
View file @ 0452102c
# HTML code for editable table
html_table1 <- HTML("<script type='text/javascript'>
/*<![CDATA[*/
function Expand1(){
if (!R1N.savesize) R1N.savesize=R1N.size;
if (!R2N.savesize) R2N.savesize=R2N.size;
if (!R3N.savesize) R3N.savesize=R3N.size;
var isChrome = !!window.chrome && (!!window.chrome.webstore || !!window.chrome.runtime);
var isSafari = /constructor/i.test(window.HTMLElement) || (function (p) { return p.toString() === '[object SafariRemoteNotification]'; })(!window['safari'] || (typeof safari !== 'undefined' && safari.pushNotification));
var isIE = /*@cc_on!@*/false || !!document.documentMode;
offset = 0;
if (isSafari) offset = 4;
R1N.size=Math.max(R1N.savesize,R1N.value.length,R2N.value.length,R3N.value.length)-offset;
R2N.size=Math.max(R2N.savesize,R1N.value.length,R2N.value.length,R3N.value.length)-offset;
R3N.size=Math.max(R3N.savesize,R1N.value.length,R2N.value.length,R3N.value.length)-offset;
}
function Expand2(){
if (!C1N.savesize) C1N.savesize=C1N.size;
if (!One1.savesize) One1.savesize=One1.size;
if (!Two1.savesize) Two1.savesize=Two1.size;
if (!Three1.savesize) Three1.savesize=Three1.size;
var isChrome = !!window.chrome && (!!window.chrome.webstore || !!window.chrome.runtime);
var isSafari = /constructor/i.test(window.HTMLElement) || (function (p) { return p.toString() === '[object SafariRemoteNotification]'; })(!window['safari'] || (typeof safari !== 'undefined' && safari.pushNotification));
var isIE = /*@cc_on!@*/false || !!document.documentMode;
offset = 0;
if (isSafari) offset = 4;
C1N.size=Math.max(C1N.savesize,C1N.value.length,One1.value.length,Two1.value.length,Three1.value.length)-offset;
One1.size=Math.max(One1.savesize,C1N.value.length,One1.value.length,Two1.value.length,Three1.value.length)-offset;
Two1.size=Math.max(Two1.savesize,C1N.value.length,One1.value.length,Two1.value.length,Three1.value.length)-offset;
Three1.size=Math.max(Three1.savesize,C1N.value.length,One1.value.length,Two1.value.length,Three1.value.length)-offset;
}
function Expand3(){
if (!C2N.savesize) C2N.savesize=C2N.size;
if (!One2.savesize) One2.savesize=One2.size;
if (!Two2.savesize) Two2.savesize=Two2.size;
if (!Three2.savesize) Three2.savesize=Three2.size;
var isChrome = !!window.chrome && (!!window.chrome.webstore || !!window.chrome.runtime);
var isSafari = /constructor/i.test(window.HTMLElement) || (function (p) { return p.toString() === '[object SafariRemoteNotification]'; })(!window['safari'] || (typeof safari !== 'undefined' && safari.pushNotification));
var isIE = /*@cc_on!@*/false || !!document.documentMode;
offset = 0;
if (isSafari) offset = 4;
C2N.size=Math.max(C2N.savesize,C2N.value.length,One2.value.length,Two2.value.length,Three2.value.length)-offset;
One2.size=Math.max(One2.savesize,C2N.value.length,One2.value.length,Two2.value.length,Three2.value.length)-offset;
Two2.size=Math.max(Two2.savesize,C2N.value.length,One2.value.length,Two2.value.length,Three2.value.length)-offset;
Three2.size=Math.max(Three2.savesize,C2N.value.length,One2.value.length,Two2.value.length,Three2.value.length)-offset;
}
function Expand4(){
if (!C3N.savesize) C3N.savesize=C3N.size;
if (!One3.savesize) One3.savesize=One3.size;
if (!Two3.savesize) Two3.savesize=Two3.size;
if (!Three3.savesize) Three3.savesize=Three3.size;
var isChrome = !!window.chrome && (!!window.chrome.webstore || !!window.chrome.runtime);
var isSafari = /constructor/i.test(window.HTMLElement) || (function (p) { return p.toString() === '[object SafariRemoteNotification]'; })(!window['safari'] || (typeof safari !== 'undefined' && safari.pushNotification));
var isIE = /*@cc_on!@*/false || !!document.documentMode;
offset = 0;
if (isSafari) offset = 4;
C3N.size=Math.max(C3N.savesize,C3N.value.length,One3.value.length,Two3.value.length,Three3.value.length)-offset;
One3.size=Math.max(One3.savesize,C3N.value.length,One3.value.length,Two3.value.length,Three3.value.length)-offset;
Two3.size=Math.max(Two3.savesize,C3N.value.length,One3.value.length,Two3.value.length,Three3.value.length)-offset;
Three3.size=Math.max(Three3.savesize,C3N.value.length,One3.value.length,Two3.value.length,Three3.value.length)-offset;
}
/*]]>*/
</script><style>
table{
border-color: #f3f7fb;
display: block;
overflow-x: auto;
}
th, td {
border: 1px solid black;
border-collapse: collapse;
padding: 6px;
}
input {
border: 0;
width: auto;
padding: 1px 8px;
background-color: #f5f5f5;
font-size: 1em;
}
</style>
<table id = 'mytable'>
<tbody>
<tr>
<td></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><input size='10' id='C3N'type = 'text' onchange='Expand4();' oninput='Expand4();' value='Column C'></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='1' id='One1' type='text' onchange='Expand2();' oninput='Expand2();' value='0'></td>
<td><input size='1' id='One2' type = 'text' onchange='Expand3();' oninput='Expand3();' value='0'></td>
<td><input size='1' id='One3' type = 'text' onchange='Expand4();' oninput='Expand4();' value='0'></td>
<td><div size='1' style='padding: 1px 8px' id='TR1' 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='1' id='Two1' type = 'text' onchange='Expand2();' oninput='Expand2();' value='0'></td>
<td><input size='1' id='Two2' type = 'text' onchange='Expand3();' oninput='Expand3();' value='0'></td>
<td><input size='1' id='Two3' type = 'text' onchange='Expand4();' oninput='Expand4();' value='0'></td>
<td><div size='1' style='padding: 1px 8px' id='TR2' class='shiny-text-output'></div></td>
</tr>
<tr>
<td><input size='1' id='R3N' type = 'text' onchange='Expand1();' oninput='Expand1();' value='Row 3'></td>
<td><input size='1' id='Three1' type = 'text' onchange='Expand2();' oninput='Expand2();' value='0'></td>
<td><input size='1' id='Three2' type = 'text' onchange='Expand3();' oninput='Expand3();' value='0'></td>
<td><input size='1' id='Three3' type = 'text' onchange='Expand4();' oninput='Expand4();' value='0'></td>
<td><div size='1' style='padding: 1px 8px' id='TR3' class='shiny-text-output'></div></td>
</tr>
<tr>
<td><div style='padding: 1px 8px'>Total</div></td>
<td><div size='1' style='padding: 1px 8px' id='TC1' class='shiny-text-output'></div></td>
<td><div size='1' style='padding: 1px 8px' id='TC2' class='shiny-text-output'></div></td>
<td><div size='1' style='padding: 1px 8px' id='TC3' class='shiny-text-output'></div></td>
<td><div size='1' style='padding: 1px 8px' id='Total' class='shiny-text-output'></div></td>
</tr>
</tbody>
</table>")
MosaicPlotsTwo/app.R 0 → 100644
+ 218
− 0
View file @ 0452102c
# ------------------------------------------------------------------------------
# File: TwoProportionMosaicPlotsTwo/app.R
# Authors: Camille Fairbourn, Sang Kyu Lee
# Date: 06/21/2020
# Desc: This app makes a mosaic plot for two proportion case for 2 by 2 table.
# Published Location:
# Email: fairbour@msu.edu, leesa111@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(shinyjs)
library(ggplot2)
enableBookmarking(store = "server")
# Sources objects, functions, etc, from TwoProportionSource.R
# This file contains the html code for the editable table,
# the decimalcount function, the dotplot_locs function, and
# custom ggplot2 themes.
source("www/TwoProportionSource.R")
# defines the presets
Presets <- list()
# Presets`preset name` <- c(Top Left, Bottom Left, Top Right, Bottom Right,
# Column A Name, Column B name, Row A name, Row B name)
Presets$`Dolphin Therapy` <- c(10, 3, 5, 12, "Improved", "Did not improve",
"Dolphin therapy", "Control group")
Presets$`Duct Tape Therapy` <- c(22, 15, 4, 10, "Wart Gone", "Wart Remains",
"Duct Tape", "Cryotherapy")
Presets$`Gender Discrimination` <- c(21, 14, 3, 10, "Promotion", "No Promotion",
"Male", "Female")
Presets$`Opportunity Cost` <- c(56, 41, 19, 34, "buy DVD", "not buy DVD",
"control", "treatment")
Presets$`Avandia` <- c(2593, 5386, 65000, 154592, "Yes", "No", "Rosiglitazone",
"Pioglitazone")
Presets$`Custom` <- c(0, 0, 0, 0, "Column A", "Column B", "Row 1", "Row 2")
ui <- function(request) {
fluidPage(useShinyjs(),
titlePanel("Two Proportion Mosaic Plots"),
sidebarLayout(
sidebarPanel(
tabsetPanel(
tabPanel("Test",
hr(),
tags$div(class="header", checked = NA,
tags$p("Enter your data into the table
below, or choose one of the data
presets. Press the submit button
to make a mosaic plot. By clicking twice,
you can fix the numbers and the names."
)
),
hr(),
selectInput(inputId = "presets",
label = "Presets",
selected = "Custom", # selects the initial preset
choices = names(Presets)),
html_table,
hr(),
actionButton("Replicate", "Submit"),
hr(),
tags$p("Written by Sang Kyu Lee"),
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"),
hr(),
bookmarkButton()
))),
mainPanel(
plotOutput("RandomPlot"),
textOutput("example")
)
)
)}
server <- function(input, output, session) {
# initialize values for use in server
values <- reactiveValues()
values$props <- vector()
values$table <- matrix(rep(NA, 9), ncol=3)
# observe any changes in table
observe({
values$table[1, 1] <- as.numeric(input$TL) # top left position
values$table[1, 2] <- as.numeric(input$TR) # top right position
values$table[2, 1] <- as.numeric(input$BL) # bottom left position
values$table[2, 2] <- as.numeric(input$BR) # bottom right position
values$table[1, 3] <- as.numeric(input$TL) + as.numeric(input$TR) #top sum
values$table[2, 3] <- as.numeric(input$BL) + as.numeric(input$BR) # bottom sum
values$table[3, 1] <- as.numeric(input$TL) + as.numeric(input$BL) # left sum
values$table[3, 2] <- as.numeric(input$TR) + as.numeric(input$BR) # right sum
values$table[3, 3] <- as.numeric(input$TL) + as.numeric(input$TR) + # total sum
as.numeric(input$BL) + as.numeric(input$BR)
values$table.names[1] <- as.character(input$C1N)
values$table.names[2] <- as.character(input$C2N)
values$table.names[3] <- as.character(input$R1N)
values$table.names[4] <- as.character(input$R2N)
})
# output for values of table if there is a change
output$TRT <- renderText({
values$table[1, 3]
})
output$TRB <- renderText({
values$table[2, 3]
})
output$TBL <- renderText({
values$table[3, 1]
})
output$TBR <- renderText({
values$table[3, 2]
})
output$Total <- renderText({
values$table[3, 3]
})
# checks to see if the current table matches a preset, otherwise the preset is "Custom"
observeEvent(c(input$TL, input$TR, input$BL, input$BR, input$C1N,
input$C2N, input$R1N, input$R2N), {
# combine the current table inputs into a vector
current <- c(input$TL, input$BL, input$TR, input$BR, input$C1N, input$C2N,
input$R1N, input$R2N)
# loops through each preset and determines the number of cells that match the current table
preset <- unlist(lapply(names(Presets), function(i) {
sum(Presets[[i]] == current)
}))
# if all cells match, change the SelectInput value to that preset,
# otherwise change the value to "Custom"
if (sum(preset == 8) > 0) {
updateSelectInput(session, "presets", selected = names(Presets)[which(preset == 8)])
} else {
updateSelectInput(session, "presets", selected = "Custom")
}
}, ignoreInit = TRUE)
# trigger when the submit is pressed
observeEvent(input$Replicate, {
if(!is.na(values$table[3,1])) values$props <- TRUE
})
# changes table if a different preset is selected
observeEvent(input$presets, {
values$props <- vector()
enable("Replicate")
# if (input$presets == "Custom") values$table.names <- c("Column A", "Column B", "Row 1", "Row 2")
if (input$presets != "Custom") {
preset_index <- which(names(Presets) == input$presets)
preset <- Presets[[preset_index]]
DF <- data.frame("X1" = as.numeric(preset[1:2]),
"X2" = as.numeric(preset[3:4]))
DF[3, ] <- apply(DF, 2, sum)
DF[, 3] <- apply(DF, 1, sum)
values$table <- DF
values$table.names <- preset[5:8]
updateTextInput(session, "TL", value = values$table[1,1])
updateTextInput(session, "TR", value = values$table[1,2])
updateTextInput(session, "BL", value = values$table[2,1])
updateTextInput(session, "BR", value = values$table[2,2])
updateTextInput(session, "C1N", value = values$table.names[1])
updateTextInput(session, "C2N", value = values$table.names[2])
updateTextInput(session, "R1N", value = values$table.names[3])
updateTextInput(session, "R2N", value = values$table.names[4])
}
})
output$RandomPlot <- renderPlot({
if (length(values$props) != 0){
df <- values$table
names <- values$table.names
variable1 <- c(rep(names[1], df[1,1]), rep(names[2], df[1,2]),
rep(names[1], df[2,1]), rep(names[2], df[2,2]))
variable2 <- c(rep(names[3], (df[1,1] + df[1,2])), rep(names[4], (df[2,1] + df[2,2])))
mosaicplot(variable2~variable1, main = "", cex.axis = 1, xlab = "", ylab = "", color = c("#569BBD","#4C721D"))
}
})
## Bookmarking ##
# to remove bookmarking, remove bookmarkButton() from the ui
# when the bookmark button is pressed, the current values of props and table are saved
onBookmark(function(state) {
state$values$props <- values$props
state$values$table <- values$table
})
# when opening a bookmarked page, props is restored
onRestored(function(state) {
values$props <- state$values$props
})
# when opening a bookmarked page, table is restored
onRestore(function(state) {
values$table <- state$values$table
})
}
shinyApp(ui = ui, server = server, options = list(height = 1080), enableBookmarking = "server")
\ No newline at end of file
MosaicPlotsTwo/shiny_bookmarks/7fabb66f2612e344/input.rds 0 → 100644
+ 0
− 0
View file @ 0452102c
File added
MosaicPlotsTwo/shiny_bookmarks/7fabb66f2612e344/values.rds 0 → 100644
+ 0
− 0
View file @ 0452102c
File added
MosaicPlotsTwo/www/TwoProportionSource.R 0 → 100644
+ 182
− 0
View file @ 0452102c
# HTML code for editable table
html_table <- HTML("<script type='text/javascript'>
/*<![CDATA[*/
function Expand1(){
if (!R1N.savesize) R1N.savesize=R1N.size;
if (!R2N.savesize) R2N.savesize=R2N.size;
var isChrome = !!window.chrome && (!!window.chrome.webstore || !!window.chrome.runtime);
var isSafari = /constructor/i.test(window.HTMLElement) || (function (p) { return p.toString() === '[object SafariRemoteNotification]'; })(!window['safari'] || (typeof safari !== 'undefined' && safari.pushNotification));
var isIE = /*@cc_on!@*/false || !!document.documentMode;
offset = 0;
if (isSafari) offset = 3;
R1N.size=Math.max(R1N.savesize,R1N.value.length,R2N.value.length)-offset;
R2N.size=Math.max(R2N.savesize,R1N.value.length,R2N.value.length)-offset;
}
function Expand2(){
if (!C1N.savesize) C1N.savesize=C1N.size;
if (!TL.savesize) TL.savesize=TL.size;
if (!BL.savesize) BL.savesize=BL.size;
var isChrome = !!window.chrome && (!!window.chrome.webstore || !!window.chrome.runtime);
var isSafari = /constructor/i.test(window.HTMLElement) || (function (p) { return p.toString() === '[object SafariRemoteNotification]'; })(!window['safari'] || (typeof safari !== 'undefined' && safari.pushNotification));
var isIE = /*@cc_on!@*/false || !!document.documentMode;
offset = 0;
if (isSafari) offset = 3;
C1N.size=Math.max(C1N.savesize,C1N.value.length,TL.value.length,BL.value.length)-offset;
TL.size=Math.max(TL.savesize,C1N.value.length,TL.value.length,BL.value.length)-offset;
BL.size=Math.max(BL.savesize,C1N.value.length,TL.value.length,BL.value.length)-offset;
}
function Expand3(){
if (!C2N.savesize) C2N.savesize=C2N.size;
if (!TR.savesize) TR.savesize=TR.size;
if (!BR.savesize) BR.savesize=BR.size;
var isChrome = !!window.chrome && (!!window.chrome.webstore || !!window.chrome.runtime);
var isSafari = /constructor/i.test(window.HTMLElement) || (function (p) { return p.toString() === '[object SafariRemoteNotification]'; })(!window['safari'] || (typeof safari !== 'undefined' && safari.pushNotification));
var isIE = /*@cc_on!@*/false || !!document.documentMode;
offset = 0;
if (isSafari) offset = 3;
C2N.size=Math.max(C2N.savesize,C2N.value.length,TR.value.length,BR.value.length)-offset;
TR.size=Math.max(TR.savesize,C2N.value.length,TR.value.length,BR.value.length)-offset;
BR.size=Math.max(BR.savesize,C2N.value.length,TR.value.length,BR.value.length)-offset;
}
/*]]>*/
</script><style>
table{
border-color: #f3f7fb;
display: block;
overflow-x: auto;
}
th, td {
border: 1px solid black;
border-collapse: collapse;
padding: 6px;
}
input {
border: 0;
width: auto;
padding: 1px 8px;
background-color: #f5f5f5;
font-size: 1em;
}
</style>
<table id = 'mytable'>
<tbody>
<tr>
<td></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='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='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>
</tr>
<tr>
<td><div style='padding: 1px 8px'>Total</div></td>
<td><div size='1' style='padding: 1px 8px' id='TBL' class='shiny-text-output'></div></td>
<td><div size='1' style='padding: 1px 8px' id='TBR' class='shiny-text-output'></div></td>
<td><div size='1' style='padding: 1px 8px' id='Total' class='shiny-text-output'></div></td>
</tr>
</tbody>
</table>")
# 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){
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 {
if ((names.counts[i] <= -1*abs(as.numeric(cutoff))+error) |
(names.counts[i] >= abs(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 {
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))
}
# 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", plot.margin = margin(10, 10, 10, 10))
# 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"))
__MACOSX/._GettysburgSubmissionApp 0 → 100644
+ 0
− 0
View file @ 0452102c
File added
__MACOSX/GettysburgSubmissionApp/._.DS_Store 0 → 100644
+ 0
− 0
View file @ 0452102c
File added
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment