inst/application/app.R
In jdgagnon/plotGrouper: Shiny app GUI wrapper for ggplot with built-in statistical analysis
# Copyright 2017-2018 John Gagnon
# This program is distributed under the terms of the GNU General Public License
# UI ----------------------------------------------------------------------
. <- "Stop NOTE"
debugThis <- FALSE
ui <- function(request) {
fluidPage(
title = "plotGrouper",
theme = shinythemes::shinytheme("cosmo"),
navbarPage(
id = "navbar",
(
shiny::tags$img(
src = "logo_white_small.png",
width = "100px",
height = "100px"
)
),
fluid = TRUE,
position = "fixed-top",
tabPanel(
h2("Plot", style = "margin-top: 30px; margin-bottom: 30px"),
fluidPage(
##### Plot sidebarPanel ####
sidebarPanel(
shiny::tags$style(type = "text/css", "body {padding-top: 140px;}"),
bookmarkButton(),
actionButton("sampleFile", "Iris"),
hr(),
#### File input ####
fileInput("file",
"Data file",
accept = c(".csv",
".tsv",
".xlsx",
".xls")),
hr(),
#### Save plot ####
h4("Save current plot"),
fluidRow(
column(8, textInput("filename",
"Filename",
"Plot1")),
column(
4,
style = "margin-top: 30px;",
downloadButton(
"downloadPlot",
"Save",
class = "btn btn-primary btn-sm",
style = "color: #fff;
background-color: #337ab7;
border-color: #2e6da4"
)
)
),
hr(),
#### Sheet selection ####
h4("Build plot"),
fluidRow(column(
8,
selectInput(
"sheet",
"Sheet(s)",
multiple = TRUE,
choices = NULL
)
)),
selectInput(
"columns",
"Organizational variables",
multiple = TRUE,
choices = NULL
),
selectInput(
"variables",
"Variables to plot",
multiple = TRUE,
choices = NULL
),
#### Select comparison and grouping columns ####
fluidRow(column(
6, selectInput("comp",
"Comparisons",
choices = NULL)
),
column(
6,
selectInput("group",
"Independent variable",
choices = NULL)
)),
hr(),
#### Modify Y label ####
h4("Y-axis modifications"),
fluidRow(
column(8, textInput("y.lab",
"Replace y axis label",
value = NULL)),
column(
1.5,
style = "margin-top: 25px;",
checkboxInput("scientific",
"10^x",
value = FALSE)
)
),
#### Transform Y axis ####
fluidRow(
column(
4,
selectInput(
"trans.y",
"Transform y",
choices = c("identity", "log2", "log10"),
selected = "identity"
)
),
column(4,
numericInput("y.min",
"Y min",
value = NULL)),
column(4,
numericInput("y.max",
"Y max",
value = NULL))
),
hr(),
#### Modify group lables ####
h4("X-axis modifications"),
fluidRow(
column(6,
textInput("split.on",
"Split on text",
value = NULL)),
column(3,
style = "margin-top: 25px;",
checkboxInput("split",
"Split",
value = TRUE)),
column(3,
style = "margin-top: 25px;",
checkboxInput("angle.x",
"Angle",
value = FALSE))
),
textInput("trim",
"Trim text from right side of group labels",
value = "none"),
#### Format width and dodge ####
fluidRow(column(
6,
sliderInput(
"width",
"Group width",
min = 0,
max = 1,
step = 0.05,
value = 0.80
)
),
column(
6,
sliderInput(
"dodge",
"Comparison Dodge",
min = 0,
max = 2,
step = 0.05,
value = 0.80
)
)),
hr(),
#### Options for transforming counts ####
h4("Transform count data"),
fluidRow(
column(4,
selectInput("id",
"Unique ID",
choices = NULL)),
column(4,
selectInput(
"beadColumn",
"Beads/Sample",
choices = NULL
)),
column(
4,
selectInput("dilutionColumn",
"Dilution (1/x)",
choices = NULL)
)
)
),
mainPanel(
#### Plot type & legend options ####
fluidRow(
column(
3,
sliderInput(
"plotHeight",
"Plot height (mm)",
step = 2.5,
min = 10,
max = 150,
value = 30
)
),
column(
3,
sliderInput(
"plotWidth",
"Plot width (mm)",
step = 2.5,
min = 10,
max = 150,
value = 20
)
),
column(
4,
selectInput(
"geom",
"Geoms to plot",
choices = c(
"bar",
"crossbar",
"errorbar",
"point",
"point_noJitter",
"dot",
"stat",
"seg",
"box",
"violin",
"line",
"line_point",
"line_error",
"line_point_stat",
"density"
),
selected = c("bar",
"errorbar",
"point",
"stat",
"seg"),
multiple = TRUE
)
),
column(
2,
selectInput(
"legend",
"Legend position",
choices = c("top",
"right",
"bottom",
"left",
"none"),
selected = "right"
)
)
),
fluidRow(
column(
2,
style = "margin-top: 30px;",
actionButton(
"refreshData",
label = "Refresh current plot",
class = "btn btn-primary btn-sm",
style = "color: #fff;
background-color: #337ab7;
border-color: #2e6da4"
)
),
column(
2,
style = "margin-top: 30px;",
actionButton(
"plt2rprt",
label = "Add plot to report",
class = "btn btn-primary btn-sm",
style = "color: #fff;
background-color: #337ab7;
border-color: #2e6da4"
)
),
column(2,
selectInput("loadPlot",
"Report plot #",
choices = NULL)),
column(
2,
style = "margin-top: 30px;",
actionButton(
"load",
label = "Load plot from report",
class = "btn btn-primary btn-sm",
style = "color: #fff;
background-color: #337ab7;
border-color: #2e6da4"
)
),
column(
2,
style = "margin-top: 30px;",
actionButton(
"update",
label = "Update plot in report",
class = "btn btn-primary btn-sm",
style = "color: #fff;
background-color: #337ab7;
border-color: #2e6da4"
)
)
),
#### Font, point, stroke ####
fluidRow(
column(
3,
sliderInput(
"font",
"Font size",
min = 8,
max = 25,
value = 8,
step = 0.5
)
),
column(
3,
sliderInput(
"size",
"Point size",
min = 0.5,
max = 10,
value = 1,
step = 0.5
)
),
column(
3,
sliderInput(
"stroke",
"Stroke size",
min = 0.25,
max = 1,
value = 0.25,
step = 0.25
)
),
column(
3,
selectInput(
"comps",
"Order of comparisons",
multiple = TRUE,
choices = NULL
)
)
),
hr(),
#### Plot ####
fluidRow(column(
12,
align = "center",
imageOutput("myPlot",
height = "100%",
width = "100%")
)),
hr(),
#### Shape, color, fill UI ####
fluidRow(
column(4, h4("Shapes"), uiOutput("shapes")),
column(4, h4("Colors"), uiOutput("colors")),
column(4, h4("Fills"), uiOutput("fills"))
),
fluidRow(
column(4, checkboxInput("lock.shapes", "Lock", FALSE)),
column(4, checkboxInput("lock.cols", "Lock", FALSE)),
column(4, checkboxInput("lock.fills", "Lock", FALSE))
),
#### Select statistical method ####
fluidRow(
column(3, selectInput(
"method",
"Stat test",
choices = c("t.test",
"wilcox.test",
"anova",
"kruskal.test")
)),
column(
3,
style = "margin-top: 25px;",
checkboxInput("refGroup",
"Reference group",
value = FALSE)
),
column(2,
style = "margin-top: 25px;",
checkboxInput("paired",
"Paired",
value = FALSE)
),
column(2,
selectInput(
"pDisplay",
"Display p value",
choices = c("p.signif",
"p.adj.signif",
"p.format",
"p.adj"),
selected = "p.signif"
)
),
column(2,
selectInput(
"errortype",
"Errorbar format",
choices = c("SE", "SD"),
selected = "SD"
))
),
hr()
)
)
),
tabPanel(
h2("Report", style = "margin-top: 30px; margin-bottom: 30px"),
fluidPage(mainPanel(
#### Clear report objects ####
fluidRow(
column(
4,
actionButton(
"clear",
"Clear last",
class = "btn btn-primary btn-md",
style = "color: #fff;
background-color: #337ab7;
border-color: #2e6da4"
)
),
column(
4,
actionButton(
"clearAll",
"Clear all",
class = "btn btn-primary btn-md",
style = "color: #fff;
background-color: #337ab7;
border-color: #2e6da4"
)
),
column(
4,
actionButton(
"refresh",
"Refresh plots",
class = "btn btn-primary btn-md",
style = "color: #fff;
background-color: #337ab7;
border-color: #2e6da4"
)
)
),
#### Save report ####
fluidRow(
column(5, textInput("report",
"Filename",
"Report1")),
column(
5,
style = "margin-top: 25px;",
downloadButton(
"downloadReport",
"Save",
class = "btn btn-primary btn-md",
style = "color: #fff;
background-color: #337ab7;
border-color: #2e6da4"
)
)
),
#### Display report ####
fluidRow(column(
12,
align = "center",
imageOutput("myReport",
height = "100%",
width = "100%")
))
))
),
#### Statistics ####
tabPanel(
h2("Statistics", style = "margin-top: 30px; margin-bottom: 30px;"),
fluidPage(mainPanel(
dataTableOutput("stat_display"),
downloadButton(
"save.stat",
"Download",
style = "color: #fff;
background-color: #337ab7;
border-color: #2e6da4;"
)
))
),
#### Table of plotting data ####
tabPanel(
h2("Plot Data", style = "margin-top: 30px; margin-bottom: 30px"),
fluidPage(mainPanel(
dataTableOutput("data_table_display")
))
),
#### Raw import data ####
tabPanel(
h2("Raw Data", style = "margin-top: 30px; margin-bottom: 30px"),
fluidPage(mainPanel(
dataTableOutput("raw_data_table_display")
))
)
)
)
}
# Server ------------------------------------------------------------------
server <- function(input, output, session) {
options(shiny.maxRequestSize = 50 * 1024 ^ 2)
setBookmarkExclude(
c(
"file",
"loadPlot",
"plt2rprt",
"sampleFile",
"clear",
"clearAll",
"load",
"update"
)
)
`%>%` <- magrittr::`%>%`
fileExtension <- reactiveVal(NULL)
dataFrame <- reactiveVal(NULL)
rawData <- reactiveVal(NULL)
inFile <- reactiveVal(NULL)
reportHeight <- reactiveVal(10)
reportWidth <- reactiveVal(10)
inputs <- reactiveValues()
plotList <- reactiveValues()
plotListLength <- reactiveVal(0)
sheets <- reactiveVal(NULL)
wlist <- reactiveValues()
hlist <- reactiveValues()
palette_cols <- reactiveVal(c("#000000", "#000000"))
palette_fills <- reactiveVal(c("#444444", "#00000000", "#A33838"))
observeEvent(input$sampleFile, {
if (debugThis) {
print("Updating sheet with iris")
}
inFile(NULL)
updateSelectInput(
session = session,
inputId = "sheet",
choices = "iris",
selected = "iris"
)
}, priority = 100)
#### Get file/read sheets ####
observeEvent({
input$file
}, {
if (debugThis) {
print("File input changed")
}
inFile(input$file)
# Identify file type
fileExtension(stringr::word(input$file$name,-1,
sep = stringr::fixed(".")))
# Identify sheets and use them as choices to load file
if (fileExtension() %in% c("xlsx", "xls")) {
sheets(readxl::excel_sheets(input$file$datapath))
}
if (fileExtension() %in% c("tsv", "csv")) {
sheets(input$file$name)
}
updateSelectInput(
session = session,
inputId = "sheet",
label = "Sheet(s)",
choices = sheets(),
selected = sheets()[1]
)
}, priority = 1)
#### Make tibble from file ####
observeEvent({
input$sheet
}, {
req(input$sheet)
if (debugThis) {
print("Sheet changed")
}
# Use iris data
if (is.null(inFile())) {
if (debugThis) {
print("using iris data")
}
f <- iris %>%
dplyr::mutate(Species = as.character(Species)) %>%
dplyr::group_by(Species) %>%
dplyr::mutate(Sample = paste0(Species, "_", dplyr::row_number()),
Sheet = input$sheet) %>%
dplyr::select(Sheet, Sample, Species, dplyr::everything())
}
# Read excel file in
if (!is.null(inFile())) {
if (fileExtension() %in% c("xlsx", "xls")) {
f <- plotGrouper::readData(sheet = input$sheet,
file = input$file$datapath)
}
if (fileExtension() == "csv") {
f <- readr::read_csv(input$file$datapath, col_names = TRUE) %>%
dplyr::mutate("Sheet" = input$sheet) %>%
dplyr::select(Sheet, dplyr::everything())
}
if (fileExtension() == "tsv") {
f <- readr::read_tsv(input$file$datapath, col_names = TRUE) %>%
dplyr::mutate("Sheet" = input$sheet) %>%
dplyr::select(Sheet, dplyr::everything())
}
}
if (debugThis) {
print("dataframe created")
}
rawData(f)
vars <- names(f)
columns_select <- c(
"Experiment",
"Sheet",
"Genotype",
"Sample",
"Condition",
"Mouse",
"Target",
"Species",
"Dilution",
"Total Bead",
"Pairs"
)
variables <- vars[which(!vars %in% c(columns_select,
"Bead %",
"Bead #",
"Beads %",
"Beads #"))]
current_columns <- input$columns
if (is.null(input$columns)) {
current_columns <- "empty"
}
if (!all(current_columns %in% vars)) {
if (debugThis) {
print("updating columns")
}
updateSelectInput(session,
"columns",
choices = vars,
selected = vars[which(vars %in% columns_select)])
} else if (all(current_columns %in% vars)) {
if (debugThis) {
print("updating column choices; keeping selected")
}
updateSelectInput(session,
"columns",
choices = vars,
selected = input$columns)
}
current_variables <- input$variables
if (is.null(input$variables)) {
current_variables <- "empty"
}
if (!all(current_variables %in% variables)) {
if (debugThis) {
print("updating variables")
}
updateSelectInput(session,
"variables",
choices = variables,
selected = variables[1])
} else if (all(current_variables %in% variables)) {
if (debugThis) {
print("updating variable choices; keeping selected")
}
updateSelectInput(session,
"variables",
choices = variables,
selected = input$variables)
}
current_comp <- input$comp
if (is.null(input$comp)) {
current_comp <- "empty"
}
if (!current_comp %in% vars) {
if (debugThis) {
print("updating comp")
}
updateSelectInput(session,
"comp",
choices = vars,
selected = vars[which(vars %in% c("Genotype",
"Condition",
"Species"))])
} else if (all(current_comp %in% vars)) {
if (debugThis) {
print("updating comp choices; keeping selected")
}
updateSelectInput(session,
"comp",
choices = vars,
selected = input$comp)
}
current_group <- input$group
if (is.null(input$group)) {
current_group <- "empty"
}
if (!current_group %in% vars) {
if (debugThis) {
print("updating group")
}
updateSelectInput(session,
"group",
choices = c("variable", vars),
selected = "variable")
} else if (current_group %in% vars) {
if (debugThis) {
print("updating group choices; keeping selected")
}
updateSelectInput(
session,
"group",
choices = c("variable", vars),
selected = input$group
)
}
current_id <- input$id
if (is.null(input$id)) {
current_id <- "empty"
}
if (!current_id %in% vars) {
if (debugThis) {
print("updating id")
}
updateSelectInput(session,
"id",
choices = vars,
selected = "Sample")
} else if (current_id %in% vars) {
if (debugThis) {
print("updating id choices; keeping selected")
}
updateSelectInput(session,
"id",
choices = vars,
selected = input$id)
}
updateSelectInput(session,
"beadColumn",
choices = c("none", vars),
selected = "Total Bead")
updateSelectInput(
session,
"dilutionColumn",
choices = c("none", vars),
selected = "Dilution"
)
}, priority = 3)
#### Update comps ####
observeEvent({
input$sheet
input$comp
}, {
req(input$sheet,
input$comp)
if (debugThis) {
print("updating comps")
}
vars <- unique(rawData()[[input$comp]])
if (is.null(vars)) {
vars <- character(0)
}
updateSelectInput(session,
"comps",
choices = vars,
selected = vars)
}, priority = 2)
#### Filter tibble ####
observeEvent({
input$refreshData
input$columns
input$variables
input$comp
input$group
input$comps
input$id
input$beadColumn
input$dilutionColumn
}, {
req(
input$sheet,
input$columns,
input$variables,
input$comp,
input$group,
length(input$comps) > 1,
input$id
)
if (debugThis) {
print("organizing dataframe")
}
d <- plotGrouper::organizeData(
data = rawData(),
exclude = input$columns,
comp = input$comp,
comps = input$comps,
variables = input$variables,
id = input$id,
beadColumn = input$beadColumn,
dilutionColumn = input$dilutionColumn
)
dataFrame(d)
}, priority = 1)
#### Create plot object ####
plotInput <- function() {
if (debugThis) {
print("running plotting function")
}
variables <- c(input$variables)
groups <- unique(dataFrame()[[input$group]])
comparisons <- unique(dataFrame()[[input$comp]])
comps <- c(input$comps)
errortype <-
ifelse(input$errortype == "SE", "mean_se", "mean_sdl")
y.min <- ifelse(is.null(input$y.min), NA, input$y.min)
y.max <- ifelse(is.null(input$y.max), NA, input$y.max)
y.lim <- c(y.min, y.max)
if (input$split.on == "") {
split_str <- NULL
} else {
split_str <- input$split.on
}
if (input$y.lab == "") {
y.lab <- NULL
} else {
y.lab <- input$y.lab
}
ref.group <- NULL
if (input$refGroup) {
ref.group <- comps[1]
}
levs.comps <- order(factor(unique(dataFrame()[[input$comp]]),
levels = comps))
levs <- order(factor(unique(dataFrame()[[input$group]]),
levels = variables))
cols <- c()
fills <- c()
shapes <- c()
lapply(seq_len(length(comparisons)), function(i) {
cols[i] <<- input[[paste0("col", i)]]
fills[i] <<- input[[paste0("fill", i)]]
shapes[i] <<- as.numeric(input[[paste0("shape", i)]])
})
if (input$trim == "") {
updateTextInput(session, "trim", value = "none")
}
plotGrouper::gplot(
dataset = dataFrame(),
comparison = input$comp,
group.by = input$group,
geom = input$geom,
errortype = errortype,
method = input$method,
paired = input$paired,
ref.group = ref.group,
p = input$pDisplay,
size = input$size,
stroke = input$stroke,
width = input$width,
dodge = input$dodge,
font_size = input$font,
plotWidth = input$plotWidth,
plotHeight = input$plotHeight,
trans.y = input$trans.y,
y.lim = y.lim,
split = input$split,
split_str = split_str,
trim = input$trim,
angle = input$angle.x,
y.lab = y.lab,
leg.pos = input$legend,
levs = levs,
levs.comps = levs.comps,
color.groups = cols,
fill.groups = fills,
shape.groups = shapes,
sci = input$scientific
)
}
#### Create current plot ####
currentPlot <- reactive({
if (debugThis) {
print("currentPlot triggered")
}
req(!is.null(dataFrame()),
all(dataFrame()$variable %in% colnames(rawData())))
lapply(seq_len(length(unique(dataFrame(
)[[input$comp]]))), function(i) {
req(input[[paste0("shape", i)]],
input[[paste0("col", i)]],
input[[paste0("fill", i)]])
})
if (debugThis) {
print("Generating current plot")
}
plotInput()
})
#### Store current plot height ####
cpHeight <- reactive({
if (debugThis) {
print("calculating plot height")
}
if (is.null(dataFrame())) {
return(1)
}
req(currentPlot())
pheight <-
sum(as.numeric(grid::convertUnit(currentPlot()$heights, "mm")))
# return total height in pixels
return(pheight * 3.7795275591)
})
#### Store current plot width ####
cpWidth <- reactive({
if (debugThis) {
print("calculating plot width")
}
if (is.null(dataFrame())) {
return(1)
}
req(currentPlot())
pwidth <-
sum(as.numeric(grid::convertUnit(currentPlot()$widths, "mm")))
return(pwidth * 3.7795275591)
})
#### Calculate stats ####
stats <- function() {
if (debugThis) {
print("calculating statistics")
}
variables <- c(input$variables)
groups <- unique(dataFrame()[[input$group]])
comps <- c(input$comps)
errortype <-
ifelse(input$errortype == "SE", "mean_se", "mean_sdl")
if (input$group == "variable") {
levs <- order(factor(unique(dataFrame()[[input$group]]),
levels = variables))
} else {
levs <- order(factor(groups), levels = groups)
}
levs.comps <- order(factor(unique(dataFrame()[[input$comp]]),
levels = comps))
ref.group <- NULL
if (input$refGroup) {
ref.group <- comps[1]
}
plotGrouper::gplot(
dataset = dataFrame(),
comparison = input$comp,
group.by = input$group,
errortype = errortype,
method = input$method,
paired = input$paired,
ref.group = ref.group,
levs = levs,
levs.comps = levs.comps,
stats = TRUE
)
}
#### Calculate report dimensions ####
reportDims <- function(current_numcol = NULL) {
widths <- unlist(reactiveValuesToList(wlist), use.names = FALSE)
heights <-
unlist(reactiveValuesToList(hlist), use.names = FALSE)
length(widths) <- suppressWarnings(prod(dim(matrix(widths,
ncol = current_numcol))))
length(heights) <- suppressWarnings(prod(dim(
matrix(heights,
ncol = current_numcol)
)))
widths[is.na(widths)] <- 0
heights[is.na(heights)] <- 0
wdims <- tibble::as.tibble(matrix(widths,
ncol = current_numcol,
byrow = TRUE)) %>%
dplyr::mutate(rowSums = rowSums(., na.rm = TRUE))
hdims <- tibble::as.tibble(matrix(heights,
ncol = current_numcol,
byrow = TRUE))
reportWidth(ceiling(max(wdims$rowSums, na.rm = TRUE)))
reportHeight(ceiling(max(colSums(hdims, na.rm = TRUE), na.rm = TRUE)))
}
#### Create shape picker ####
output$shapes <- renderUI({
req(input$sheet,
input$comp,
length(input$comps) > 1,
input$group)
if (debugThis) {
print("shape picker")
}
comparisons <- c(input$comps)
options <- c(19, 21, 17, 24, 15, 22)
choices <- c(19, 21, 17, 24, 15, 22)
comps <- input$comps
if (input$lock.shapes) {
choices <- c()
lapply(seq_len(length(comparisons)), function(i) {
choices[i] <<- as.numeric(input[[paste0("shape", i)]])
})
}
selection <- rep(choices[seq_len(length(comparisons))],
length(comparisons))
lapply(1:length(comparisons), function(i) {
shiny::tags$div(
style = "margin-bottom:25px;",
selectInput(
inputId = paste0("shape", i),
label = comparisons[i],
choices = options,
selected = selection[i]
)
)
})
})
#### Create color picker ####
output$colors <- renderUI({
req(input$sheet,
input$comp,
length(input$comps) > 1,
input$group)
if (debugThis) {
print("color picker")
}
comparisons <- c(input$comps)
choices <- palette_cols()
comps <- input$comps
if (input$lock.cols) {
choices <- c()
lapply(seq_len(length(comparisons)), function(i) {
choices[i] <<- input[[paste0("col", i)]]
})
}
selection <- rep(choices, length(comparisons))
lapply(seq_len(length(comparisons)), function(i) {
colourpicker::colourInput(
inputId = paste0("col", i),
label = comparisons[i],
value = selection[i]
)
})
})
#### Create fill picker ####
output$fills <- renderUI({
req(input$sheet,
input$comp,
length(input$comps) > 1,
input$group)
if (debugThis) {
print("fill picker")
}
comparisons <- c(input$comps)
comps <- input$comps
choices <- palette_fills()
if (input$lock.fills) {
choices <- c()
lapply(seq_len(length(comparisons)), function(i) {
choices[i] <<- input[[paste0("fill", i)]]
})
}
selection <- rep(choices, length(comparisons))
lapply(1:length(comparisons), function(i) {
colourpicker::colourInput(
inputId = paste0("fill", i),
label = comparisons[i],
value = selection[i],
allowTransparent = TRUE
)
})
})
#### Plot the data ####
output$myPlot <- renderImage({
if (debugThis) {
print("rendering plot")
}
# A temp file to save the output.
# This file will be removed later by renderImage
outfile <- tempfile(fileext = ".png")
# Generate the PNG
png(
outfile,
width = cpWidth() * 3,
height = cpHeight() * 3,
res = 72 * 3
)
gridExtra::grid.arrange(currentPlot())
dev.off()
# Return a list containing the filename
list(
src = outfile,
contentType = "image/png",
width = cpWidth(),
height = cpHeight(),
alt = "This is alternate text"
)
}, deleteFile = TRUE)
#### Save plot ####
output$downloadPlot <- downloadHandler(
file = function() {
paste0(input$filename, ".pdf")
},
content = function(file) {
ggplot2::ggsave(
file,
plot = isolate(currentPlot()),
useDingbats = FALSE,
height = isolate(cpHeight()) / 3.7795275591,
width = isolate(cpWidth()) / 3.7795275591,
units = "mm",
device = "pdf"
)
}
)
#### Create stats table ####
output$stat_display <- renderDataTable({
if (debugThis) {
print("creating datatable of statistics")
}
req(input$variables)
stats()
})
#### Save stats table ####
output$save.stat <- downloadHandler(
file = function() {
paste0(input$file, "_stats", ".csv")
},
content = function(file) {
readr::write_csv(stats(), file, col_names = TRUE)
}
)
#### Create table of plotted data ####
output$data_table_display <- renderDataTable({
if (debugThis) {
print("creating datatable of plotted data")
}
req(input$variables)
dataFrame()
})
#### Create table with raw data ####
output$raw_data_table_display <- renderDataTable({
if (debugThis) {
print("creating datatable of raw data")
}
req(input$variables)
rawData()
})
#### Add current plot to report ####
observeEvent(input$plt2rprt, {
req(input$sheet)
if (debugThis) {
print("plt2rprt was clicked")
}
comparisons <- unique(dataFrame()[[input$comp]])
previous_plotListLength <- plotListLength()
plotListLength(previous_plotListLength + 1)
current_plotListLength <- previous_plotListLength + 1
prev_numcol <- ifelse(previous_plotListLength == 0, 1,
floor(sqrt(previous_plotListLength)))
current_numcol <- floor(sqrt(current_plotListLength))
prev_numrow <- ifelse(previous_plotListLength == 0,
1,
ceiling(previous_plotListLength / prev_numcol))
current_numrow <-
ceiling(current_plotListLength / current_numcol)
wlist[[as.character(current_plotListLength)]] <- cpWidth()
hlist[[as.character(current_plotListLength)]] <- cpHeight()
reportDims(current_numcol = current_numcol)
plotList[[as.character(current_plotListLength)]] <-
isolate(currentPlot())
inputs[[as.character(current_plotListLength)]] <-
isolate(reactiveValuesToList(input))
reportPlots <- as.character(1:current_plotListLength)
cols <- c()
fills <- c()
shapes <- c()
lapply(seq_len(length(comparisons)), function(i) {
cols[i] <<- input[[paste0("col", i)]]
fills[i] <<- input[[paste0("fill", i)]]
shapes[i] <<- as.numeric(input[[paste0("shape", i)]])
})
inputs[[as.character(current_plotListLength)]]$cols <- cols
inputs[[as.character(current_plotListLength)]]$fills <- fills
inputs[[as.character(current_plotListLength)]]$shapes <- shapes
updateSelectInput(session,
"loadPlot",
choices = reportPlots,
selected = reportPlots[current_plotListLength])
})
#### Clear last plot from report ####
observeEvent(input$clear, {
if (debugThis) {
print("clear last plot from report was clicked")
}
previous_plotListLength <- plotListLength()
if (previous_plotListLength > 1) {
current_plotListLength <- previous_plotListLength - 1
plotListLength(current_plotListLength)
prev_numcol <- floor(sqrt(previous_plotListLength))
current_numcol <- floor(sqrt(current_plotListLength))
prev_numrow <- ceiling(previous_plotListLength / prev_numcol)
current_numrow <-
ceiling(current_plotListLength / current_numcol)
wlist[[as.character(previous_plotListLength)]] <- NULL
hlist[[as.character(previous_plotListLength)]] <- NULL
plotList[[as.character(previous_plotListLength)]] <-
grid::nullGrob(vp = NULL)
inputs[[as.character(previous_plotListLength)]] <- NULL
reportDims(current_numcol = current_numcol)
reportPlots <- as.character(1:current_plotListLength)
updateSelectInput(session,
"loadPlot",
choices = reportPlots,
selected = reportPlots[current_plotListLength])
}
if (previous_plotListLength == 1) {
plotList[[as.character(1)]] <- grid::nullGrob(vp = NULL)
inputs[[as.character(1)]] <- NULL
wlist[[as.character(1)]] <- NULL
hlist[[as.character(1)]] <- NULL
plotListLength(0)
reportHeight(10)
reportWidth(10)
updateSelectInput(session,
"loadPlot",
choices = "",
selected = "")
}
})
#### Clear all plots from report ####
observeEvent(input$clearAll, {
if (debugThis) {
print("clear all plots from report was clicked")
}
previous_plotListLength <- plotListLength()
for (i in seq_len(previous_plotListLength)) {
plotList[[as.character(i)]] <- grid::nullGrob(vp = NULL)
inputs[[as.character(i)]] <- NULL
wlist[[as.character(i)]] <- NULL
hlist[[as.character(i)]] <- NULL
}
plotListLength(0)
reportHeight(10)
reportWidth(10)
updateSelectInput(session,
"loadPlot",
choices = "",
selected = "")
})
#### Update plot in report ####
observeEvent(input$update, {
if (debugThis) {
print("updating plot in report")
}
req(plotListLength() >= 1)
comparisons <- unique(dataFrame()[[input$comp]])
current_plotListLength <- plotListLength()
current_numcol <- floor(sqrt(current_plotListLength))
wlist[[as.character(input$loadPlot)]] <- cpWidth()
hlist[[as.character(input$loadPlot)]] <- cpHeight()
reportDims(current_numcol = current_numcol)
plotList[[input$loadPlot]] <- isolate(currentPlot())
inputs[[input$loadPlot]] <- isolate(reactiveValuesToList(input))
cols <- c()
fills <- c()
shapes <- c()
lapply(seq_len(length(comparisons)), function(i) {
cols[i] <<- input[[paste0("col", i)]]
fills[i] <<- input[[paste0("fill", i)]]
shapes[i] <<- as.numeric(input[[paste0("shape", i)]])
})
inputs[[input$loadPlot]]$cols <- cols
inputs[[input$loadPlot]]$fills <- fills
inputs[[input$loadPlot]]$shapes <- shapes
})
#### Create report ####
output$myReport <- renderImage({
if (debugThis) {
print("rendering report image")
}
current_plotListLength <- plotListLength()
# A temp file to save the output.
# This file will be removed later by renderImage
outfile <- tempfile(fileext = ".png")
# Generate the PNG
png(
outfile,
width = reportWidth() * 3,
height = reportHeight() * 3,
res = 72 * 3
)
if (current_plotListLength > 0) {
numcol <- floor(sqrt(current_plotListLength))
gridExtra::grid.arrange(
grobs = reactiveValuesToList(plotList)[1:current_plotListLength],
ncol = numcol)
}
dev.off()
# Return a list containing the filename
list(
src = outfile,
contentType = "image/png",
width = reportWidth(),
height = reportHeight(),
alt = "Nothing added to report yet."
)
}, deleteFile = TRUE)
#### Download report ####
output$downloadReport <- downloadHandler(
file = function() {
paste(input$report, "pdf", sep = ".")
},
content = function(file) {
ggplot2::ggsave(
file,
plot =
if (plotListLength() > 0) {
numcol <- floor(sqrt(plotListLength()))
gridExtra::arrangeGrob(grobs = reactiveValuesToList(plotList)
[1:isolate(plotListLength())],
ncol = numcol)
},
useDingbats = FALSE,
height = (reportHeight() / 3.7795275591) + 25,
width = (reportWidth() / 3.7795275591) + 25,
units = "mm",
device = "pdf",
limitsize = FALSE
)
}
)
#### Load plot from report ####
observeEvent(input$load, {
req(plotListLength() >= 1)
if (debugThis) {
print("Loading last sheet")
}
updateSelectInput(session,
"sheet",
selected = inputs[[input$loadPlot]]$sheet)
}, priority = -1)
observeEvent(input$load, {
req(plotListLength() >= 1)
if (debugThis) {
print("Loading last columns")
}
updateSelectInput(session,
"columns",
selected = inputs[[input$loadPlot]]$columns)
}, priority = -2)
observeEvent(input$load, {
req(plotListLength() >= 1)
if (debugThis) {
print("Loading last variables")
}
updateSelectInput(session,
"variables",
selected = inputs[[input$loadPlot]]$variables)
}, priority = -3)
observeEvent(input$load, {
req(plotListLength() >= 1)
if (debugThis) {
print("Loading last comparisons")
}
updateSelectInput(session,
"comp",
selected = inputs[[input$loadPlot]]$comp)
}, priority = -4)
observeEvent(input$load, {
req(plotListLength() >= 1)
if (debugThis) {
print("Loading last id")
}
updateSelectInput(session,
"id",
selected = inputs[[input$loadPlot]]$id)
}, priority = -5)
observeEvent(input$load, {
req(plotListLength() >= 1)
if (debugThis) {
print("Loading last group")
}
updateSelectInput(session,
"group",
selected = inputs[[input$loadPlot]]$group)
updateSelectInput(session,
"comps",
selected = inputs[[input$loadPlot]]$comps)
}, priority = -6)
observeEvent(input$load, {
req(plotListLength() >= 1)
if (debugThis) {
print("Loading independent inputs")
}
updateSelectInput(session,
"beadColumn",
selected = inputs[[input$loadPlot]]$beadColumn)
updateSelectInput(session,
"dilutionColumn",
selected = inputs[[input$loadPlot]]$dilutionColumn)
updateTextInput(session,
"y.lab",
value = inputs[[input$loadPlot]]$y.lab)
updateSelectInput(session,
"geom",
selected = inputs[[input$loadPlot]]$geom)
updateSelectInput(session,
"method",
selected = inputs[[input$loadPlot]]$method)
updateSelectInput(session,
"trans.y",
selected = inputs[[input$loadPlot]]$trans.y)
updateSelectInput(session,
"legend",
selected = inputs[[input$loadPlot]]$legend)
updateSelectInput(session,
"errortype",
selected = inputs[[input$loadPlot]]$errortype)
updateSliderInput(session,
"font",
value = inputs[[input$loadPlot]]$font)
updateSliderInput(session,
"size",
value = inputs[[input$loadPlot]]$size)
updateSliderInput(session,
"stroke",
value = inputs[[input$loadPlot]]$stroke)
updateSliderInput(session,
"plotWidth",
value = inputs[[input$loadPlot]]$plotWidth)
updateSliderInput(session,
"plotHeight",
value = inputs[[input$loadPlot]]$plotHeight)
updateSliderInput(session,
"width",
value = inputs[[input$loadPlot]]$width)
updateSliderInput(session,
"dodge",
value = inputs[[input$loadPlot]]$dodge)
updateTextInput(session,
"trim",
value = inputs[[input$loadPlot]]$trim)
updateTextInput(session,
"split.on",
value = inputs[[input$loadPlot]]$split.on)
updateCheckboxInput(session,
"split",
value = inputs[[input$loadPlot]]$split)
updateCheckboxInput(session,
"angle.x",
value = inputs[[input$loadPlot]]$angle.x)
updateCheckboxInput(session,
"refGroup",
value = inputs[[input$loadPlot]]$refGroup)
updateCheckboxInput(session,
"paired",
value = inputs[[input$loadPlot]]$paired)
updateSelectInput(session,
"pDisplay",
selected = inputs[[input$loadPlot]]$pDisplay)
updateCheckboxInput(session,
"scientific",
value = inputs[[input$loadPlot]]$scientific)
}, priority = -7)
observeEvent(input$load, {
req(plotListLength() >= 1)
if (debugThis) {
print("updating colors, fills, shapes")
}
for (i in 1:length(unique(dataFrame()[[input$comp]]))) {
colourpicker::updateColourInput(session,
paste0("col", i),
value = inputs[[input$loadPlot]][[paste0(
"col",
i)]])
colourpicker::updateColourInput(session,
paste0("fill", i),
value = inputs[[input$loadPlot]][[paste0(
"fill",
i)]])
updateSelectInput(session,
paste0("shape", i),
selected = inputs[[input$loadPlot]][[paste0(
"shape",
i)]])
}
}, priority = -8)
#### Refresh plots in report ####
observeEvent(input$refresh, {
req(input$file,
plotListLength() >= 1)
for (i in as.character(seq_len(plotListLength()))) {
if (debugThis) {
print(paste0("refreshing plot: ", i))
}
if (fileExtension() %in% c("xlsx", "xls")) {
rData <- plotGrouper::readData(sheet = input$sheet,
file = input$file$datapath)
}
if (fileExtension() == "csv") {
rData <- readr::read_csv(input$file$datapath, col_names = TRUE) %>%
dplyr::mutate("Sheet" = input$sheet) %>%
dplyr::select(Sheet, dplyr::everything())
}
if (fileExtension() == "tsv") {
rData <- readr::read_tsv(input$file$datapath, col_names = TRUE) %>%
dplyr::mutate("Sheet" = input$sheet) %>%
dplyr::select(Sheet, dplyr::everything())
}
oData <- plotGrouper::organizeData(
data = rData,
exclude = inputs[[i]]$columns,
comp = inputs[[i]]$comp,
comps = inputs[[i]]$comps,
variables = inputs[[i]]$variables,
id = inputs[[i]]$id,
beadColumn = inputs[[i]]$beadColumn,
dilutionColumn = inputs[[i]]$dilutionColumn
)
errortype <-
ifelse(inputs[[i]]$errortype == "SE", "mean_se", "mean_sdl")
if (inputs[[i]]$split.on == "") {
split_str <- NULL
} else {
split_str <- inputs[[i]]$split.on
}
if (inputs[[i]]$y.lab == "") {
y.lab <- NULL
} else {
y.lab <- inputs[[i]]$y.lab
}
ref.group <- NULL
if (inputs[[i]]$refGroup) {
ref.group <- inputs[[i]]$comps[1]
}
levs.comps <- order(factor(unique(oData[[inputs[[i]]$comp]]),
levels = inputs[[i]]$comps))
levs <- order(factor(unique(oData[[inputs[[i]]$group]]),
levels = inputs[[i]]$variables))
cols <- inputs[[i]]$cols
fills <- inputs[[i]]$fills
shapes <- inputs[[i]]$shapes
if (inputs[[i]]$trim == "") {
updateTextInput(session, "trim", value = "none")
}
cPlot <- plotGrouper::gplot(
dataset = oData,
comparison = inputs[[i]]$comp,
group.by = inputs[[i]]$group,
geom = inputs[[i]]$geom,
errortype = errortype,
method = inputs[[i]]$method,
paired = inputs[[i]]$paired,
ref.group = ref.group,
p = inputs[[i]]$pDisplay,
size = inputs[[i]]$size,
stroke = inputs[[i]]$stroke,
width = inputs[[i]]$width,
dodge = inputs[[i]]$dodge,
font_size = inputs[[i]]$font,
plotWidth = inputs[[i]]$plotWidth,
plotHeight = inputs[[i]]$plotHeight,
trans.y = inputs[[i]]$trans.y,
split = inputs[[i]]$split,
split_str = split_str,
trim = inputs[[i]]$trim,
angle = inputs[[i]]$angle.x,
y.lab = y.lab,
leg.pos = inputs[[i]]$legend,
levs = levs,
levs.comps = levs.comps,
color.groups = cols,
fill.groups = fills,
shape.groups = shapes,
sci = inputs[[i]]$scientific
)
pheight <-
sum(as.numeric(grid::convertUnit(cPlot$heights, "mm"))) *
3.7795275591
pwidth <-
sum(as.numeric(grid::convertUnit(cPlot$widths, "mm"))) *
3.7795275591
wlist[[i]] <- pwidth
hlist[[i]] <- pheight
plotList[[i]] <- cPlot
}
current_plotListLength <- plotListLength()
current_numcol <- floor(sqrt(current_plotListLength))
reportDims(current_numcol = current_numcol)
})
#### Bookmarking values ####
onBookmark(function(state) {
state$values$plotList <- reactiveValuesToList(plotList)
state$values$inputs <- reactiveValuesToList(inputs)
state$values$plotListLength <- isolate(plotListLength())
state$values$hlist <- reactiveValuesToList(hlist)
state$values$wlist <- reactiveValuesToList(wlist)
})
#### Restoring values ####
onRestored(function(state) {
if (debugThis) {
print("Restoring report")
}
plotListLength(state$values$plotListLength)
for (i in seq_len(isolate(plotListLength()))) {
inputs[[as.character(i)]] <- state$values$inputs[[as.character(i)]]
plotList[[as.character(i)]] <-
state$values$plotList[[as.character(i)]]
hlist[[as.character(i)]] <-
state$values$hlist[[as.character(i)]]
wlist[[as.character(i)]] <-
state$values$wlist[[as.character(i)]]
}
plotListPlots <-
as.character(seq_len(isolate(plotListLength())))
updateSelectInput(session,
"loadPlot",
choices = plotListPlots,
selected = tail(plotListPlots, 1))
current_plotListLength <- plotListLength()
current_numcol <- floor(sqrt(current_plotListLength))
reportDims(current_numcol = current_numcol)
})
#### Stop app on close ####
session$onSessionEnded(function() {
graphics.off()
})
session$onSessionEnded(stopApp)
}
shiny::shinyApp(ui, server, enableBookmarking = "server")
jdgagnon/plotGrouper documentation built on May 14, 2019, 11:12 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
# Copyright 2017-2018 John Gagnon
# This program is distributed under the terms of the GNU General Public License
# UI ----------------------------------------------------------------------
. <- "Stop NOTE"
debugThis <- FALSE
ui <- function(request) {
fluidPage(
title = "plotGrouper",
theme = shinythemes::shinytheme("cosmo"),
navbarPage(
id = "navbar",
(
shiny::tags$img(
src = "logo_white_small.png",
width = "100px",
height = "100px"
)
),
fluid = TRUE,
position = "fixed-top",
tabPanel(
h2("Plot", style = "margin-top: 30px; margin-bottom: 30px"),
fluidPage(
##### Plot sidebarPanel ####
sidebarPanel(
shiny::tags$style(type = "text/css", "body {padding-top: 140px;}"),
bookmarkButton(),
actionButton("sampleFile", "Iris"),
hr(),
#### File input ####
fileInput("file",
"Data file",
accept = c(".csv",
".tsv",
".xlsx",
".xls")),
hr(),
#### Save plot ####
h4("Save current plot"),
fluidRow(
column(8, textInput("filename",
"Filename",
"Plot1")),
column(
4,
style = "margin-top: 30px;",
downloadButton(
"downloadPlot",
"Save",
class = "btn btn-primary btn-sm",
style = "color: #fff;
background-color: #337ab7;
border-color: #2e6da4"
)
)
),
hr(),
#### Sheet selection ####
h4("Build plot"),
fluidRow(column(
8,
selectInput(
"sheet",
"Sheet(s)",
multiple = TRUE,
choices = NULL
)
)),
selectInput(
"columns",
"Organizational variables",
multiple = TRUE,
choices = NULL
),
selectInput(
"variables",
"Variables to plot",
multiple = TRUE,
choices = NULL
),
#### Select comparison and grouping columns ####
fluidRow(column(
6, selectInput("comp",
"Comparisons",
choices = NULL)
),
column(
6,
selectInput("group",
"Independent variable",
choices = NULL)
)),
hr(),
#### Modify Y label ####
h4("Y-axis modifications"),
fluidRow(
column(8, textInput("y.lab",
"Replace y axis label",
value = NULL)),
column(
1.5,
style = "margin-top: 25px;",
checkboxInput("scientific",
"10^x",
value = FALSE)
)
),
#### Transform Y axis ####
fluidRow(
column(
4,
selectInput(
"trans.y",
"Transform y",
choices = c("identity", "log2", "log10"),
selected = "identity"
)
),
column(4,
numericInput("y.min",
"Y min",
value = NULL)),
column(4,
numericInput("y.max",
"Y max",
value = NULL))
),
hr(),
#### Modify group lables ####
h4("X-axis modifications"),
fluidRow(
column(6,
textInput("split.on",
"Split on text",
value = NULL)),
column(3,
style = "margin-top: 25px;",
checkboxInput("split",
"Split",
value = TRUE)),
column(3,
style = "margin-top: 25px;",
checkboxInput("angle.x",
"Angle",
value = FALSE))
),
textInput("trim",
"Trim text from right side of group labels",
value = "none"),
#### Format width and dodge ####
fluidRow(column(
6,
sliderInput(
"width",
"Group width",
min = 0,
max = 1,
step = 0.05,
value = 0.80
)
),
column(
6,
sliderInput(
"dodge",
"Comparison Dodge",
min = 0,
max = 2,
step = 0.05,
value = 0.80
)
)),
hr(),
#### Options for transforming counts ####
h4("Transform count data"),
fluidRow(
column(4,
selectInput("id",
"Unique ID",
choices = NULL)),
column(4,
selectInput(
"beadColumn",
"Beads/Sample",
choices = NULL
)),
column(
4,
selectInput("dilutionColumn",
"Dilution (1/x)",
choices = NULL)
)
)
),
mainPanel(
#### Plot type & legend options ####
fluidRow(
column(
3,
sliderInput(
"plotHeight",
"Plot height (mm)",
step = 2.5,
min = 10,
max = 150,
value = 30
)
),
column(
3,
sliderInput(
"plotWidth",
"Plot width (mm)",
step = 2.5,
min = 10,
max = 150,
value = 20
)
),
column(
4,
selectInput(
"geom",
"Geoms to plot",
choices = c(
"bar",
"crossbar",
"errorbar",
"point",
"point_noJitter",
"dot",
"stat",
"seg",
"box",
"violin",
"line",
"line_point",
"line_error",
"line_point_stat",
"density"
),
selected = c("bar",
"errorbar",
"point",
"stat",
"seg"),
multiple = TRUE
)
),
column(
2,
selectInput(
"legend",
"Legend position",
choices = c("top",
"right",
"bottom",
"left",
"none"),
selected = "right"
)
)
),
fluidRow(
column(
2,
style = "margin-top: 30px;",
actionButton(
"refreshData",
label = "Refresh current plot",
class = "btn btn-primary btn-sm",
style = "color: #fff;
background-color: #337ab7;
border-color: #2e6da4"
)
),
column(
2,
style = "margin-top: 30px;",
actionButton(
"plt2rprt",
label = "Add plot to report",
class = "btn btn-primary btn-sm",
style = "color: #fff;
background-color: #337ab7;
border-color: #2e6da4"
)
),
column(2,
selectInput("loadPlot",
"Report plot #",
choices = NULL)),
column(
2,
style = "margin-top: 30px;",
actionButton(
"load",
label = "Load plot from report",
class = "btn btn-primary btn-sm",
style = "color: #fff;
background-color: #337ab7;
border-color: #2e6da4"
)
),
column(
2,
style = "margin-top: 30px;",
actionButton(
"update",
label = "Update plot in report",
class = "btn btn-primary btn-sm",
style = "color: #fff;
background-color: #337ab7;
border-color: #2e6da4"
)
)
),
#### Font, point, stroke ####
fluidRow(
column(
3,
sliderInput(
"font",
"Font size",
min = 8,
max = 25,
value = 8,
step = 0.5
)
),
column(
3,
sliderInput(
"size",
"Point size",
min = 0.5,
max = 10,
value = 1,
step = 0.5
)
),
column(
3,
sliderInput(
"stroke",
"Stroke size",
min = 0.25,
max = 1,
value = 0.25,
step = 0.25
)
),
column(
3,
selectInput(
"comps",
"Order of comparisons",
multiple = TRUE,
choices = NULL
)
)
),
hr(),
#### Plot ####
fluidRow(column(
12,
align = "center",
imageOutput("myPlot",
height = "100%",
width = "100%")
)),
hr(),
#### Shape, color, fill UI ####
fluidRow(
column(4, h4("Shapes"), uiOutput("shapes")),
column(4, h4("Colors"), uiOutput("colors")),
column(4, h4("Fills"), uiOutput("fills"))
),
fluidRow(
column(4, checkboxInput("lock.shapes", "Lock", FALSE)),
column(4, checkboxInput("lock.cols", "Lock", FALSE)),
column(4, checkboxInput("lock.fills", "Lock", FALSE))
),
#### Select statistical method ####
fluidRow(
column(3, selectInput(
"method",
"Stat test",
choices = c("t.test",
"wilcox.test",
"anova",
"kruskal.test")
)),
column(
3,
style = "margin-top: 25px;",
checkboxInput("refGroup",
"Reference group",
value = FALSE)
),
column(2,
style = "margin-top: 25px;",
checkboxInput("paired",
"Paired",
value = FALSE)
),
column(2,
selectInput(
"pDisplay",
"Display p value",
choices = c("p.signif",
"p.adj.signif",
"p.format",
"p.adj"),
selected = "p.signif"
)
),
column(2,
selectInput(
"errortype",
"Errorbar format",
choices = c("SE", "SD"),
selected = "SD"
))
),
hr()
)
)
),
tabPanel(
h2("Report", style = "margin-top: 30px; margin-bottom: 30px"),
fluidPage(mainPanel(
#### Clear report objects ####
fluidRow(
column(
4,
actionButton(
"clear",
"Clear last",
class = "btn btn-primary btn-md",
style = "color: #fff;
background-color: #337ab7;
border-color: #2e6da4"
)
),
column(
4,
actionButton(
"clearAll",
"Clear all",
class = "btn btn-primary btn-md",
style = "color: #fff;
background-color: #337ab7;
border-color: #2e6da4"
)
),
column(
4,
actionButton(
"refresh",
"Refresh plots",
class = "btn btn-primary btn-md",
style = "color: #fff;
background-color: #337ab7;
border-color: #2e6da4"
)
)
),
#### Save report ####
fluidRow(
column(5, textInput("report",
"Filename",
"Report1")),
column(
5,
style = "margin-top: 25px;",
downloadButton(
"downloadReport",
"Save",
class = "btn btn-primary btn-md",
style = "color: #fff;
background-color: #337ab7;
border-color: #2e6da4"
)
)
),
#### Display report ####
fluidRow(column(
12,
align = "center",
imageOutput("myReport",
height = "100%",
width = "100%")
))
))
),
#### Statistics ####
tabPanel(
h2("Statistics", style = "margin-top: 30px; margin-bottom: 30px;"),
fluidPage(mainPanel(
dataTableOutput("stat_display"),
downloadButton(
"save.stat",
"Download",
style = "color: #fff;
background-color: #337ab7;
border-color: #2e6da4;"
)
))
),
#### Table of plotting data ####
tabPanel(
h2("Plot Data", style = "margin-top: 30px; margin-bottom: 30px"),
fluidPage(mainPanel(
dataTableOutput("data_table_display")
))
),
#### Raw import data ####
tabPanel(
h2("Raw Data", style = "margin-top: 30px; margin-bottom: 30px"),
fluidPage(mainPanel(
dataTableOutput("raw_data_table_display")
))
)
)
)
}
# Server ------------------------------------------------------------------
server <- function(input, output, session) {
options(shiny.maxRequestSize = 50 * 1024 ^ 2)
setBookmarkExclude(
c(
"file",
"loadPlot",
"plt2rprt",
"sampleFile",
"clear",
"clearAll",
"load",
"update"
)
)
`%>%` <- magrittr::`%>%`
fileExtension <- reactiveVal(NULL)
dataFrame <- reactiveVal(NULL)
rawData <- reactiveVal(NULL)
inFile <- reactiveVal(NULL)
reportHeight <- reactiveVal(10)
reportWidth <- reactiveVal(10)
inputs <- reactiveValues()
plotList <- reactiveValues()
plotListLength <- reactiveVal(0)
sheets <- reactiveVal(NULL)
wlist <- reactiveValues()
hlist <- reactiveValues()
palette_cols <- reactiveVal(c("#000000", "#000000"))
palette_fills <- reactiveVal(c("#444444", "#00000000", "#A33838"))
observeEvent(input$sampleFile, {
if (debugThis) {
print("Updating sheet with iris")
}
inFile(NULL)
updateSelectInput(
session = session,
inputId = "sheet",
choices = "iris",
selected = "iris"
)
}, priority = 100)
#### Get file/read sheets ####
observeEvent({
input$file
}, {
if (debugThis) {
print("File input changed")
}
inFile(input$file)
# Identify file type
fileExtension(stringr::word(input$file$name,-1,
sep = stringr::fixed(".")))
# Identify sheets and use them as choices to load file
if (fileExtension() %in% c("xlsx", "xls")) {
sheets(readxl::excel_sheets(input$file$datapath))
}
if (fileExtension() %in% c("tsv", "csv")) {
sheets(input$file$name)
}
updateSelectInput(
session = session,
inputId = "sheet",
label = "Sheet(s)",
choices = sheets(),
selected = sheets()[1]
)
}, priority = 1)
#### Make tibble from file ####
observeEvent({
input$sheet
}, {
req(input$sheet)
if (debugThis) {
print("Sheet changed")
}
# Use iris data
if (is.null(inFile())) {
if (debugThis) {
print("using iris data")
}
f <- iris %>%
dplyr::mutate(Species = as.character(Species)) %>%
dplyr::group_by(Species) %>%
dplyr::mutate(Sample = paste0(Species, "_", dplyr::row_number()),
Sheet = input$sheet) %>%
dplyr::select(Sheet, Sample, Species, dplyr::everything())
}
# Read excel file in
if (!is.null(inFile())) {
if (fileExtension() %in% c("xlsx", "xls")) {
f <- plotGrouper::readData(sheet = input$sheet,
file = input$file$datapath)
}
if (fileExtension() == "csv") {
f <- readr::read_csv(input$file$datapath, col_names = TRUE) %>%
dplyr::mutate("Sheet" = input$sheet) %>%
dplyr::select(Sheet, dplyr::everything())
}
if (fileExtension() == "tsv") {
f <- readr::read_tsv(input$file$datapath, col_names = TRUE) %>%
dplyr::mutate("Sheet" = input$sheet) %>%
dplyr::select(Sheet, dplyr::everything())
}
}
if (debugThis) {
print("dataframe created")
}
rawData(f)
vars <- names(f)
columns_select <- c(
"Experiment",
"Sheet",
"Genotype",
"Sample",
"Condition",
"Mouse",
"Target",
"Species",
"Dilution",
"Total Bead",
"Pairs"
)
variables <- vars[which(!vars %in% c(columns_select,
"Bead %",
"Bead #",
"Beads %",
"Beads #"))]
current_columns <- input$columns
if (is.null(input$columns)) {
current_columns <- "empty"
}
if (!all(current_columns %in% vars)) {
if (debugThis) {
print("updating columns")
}
updateSelectInput(session,
"columns",
choices = vars,
selected = vars[which(vars %in% columns_select)])
} else if (all(current_columns %in% vars)) {
if (debugThis) {
print("updating column choices; keeping selected")
}
updateSelectInput(session,
"columns",
choices = vars,
selected = input$columns)
}
current_variables <- input$variables
if (is.null(input$variables)) {
current_variables <- "empty"
}
if (!all(current_variables %in% variables)) {
if (debugThis) {
print("updating variables")
}
updateSelectInput(session,
"variables",
choices = variables,
selected = variables[1])
} else if (all(current_variables %in% variables)) {
if (debugThis) {
print("updating variable choices; keeping selected")
}
updateSelectInput(session,
"variables",
choices = variables,
selected = input$variables)
}
current_comp <- input$comp
if (is.null(input$comp)) {
current_comp <- "empty"
}
if (!current_comp %in% vars) {
if (debugThis) {
print("updating comp")
}
updateSelectInput(session,
"comp",
choices = vars,
selected = vars[which(vars %in% c("Genotype",
"Condition",
"Species"))])
} else if (all(current_comp %in% vars)) {
if (debugThis) {
print("updating comp choices; keeping selected")
}
updateSelectInput(session,
"comp",
choices = vars,
selected = input$comp)
}
current_group <- input$group
if (is.null(input$group)) {
current_group <- "empty"
}
if (!current_group %in% vars) {
if (debugThis) {
print("updating group")
}
updateSelectInput(session,
"group",
choices = c("variable", vars),
selected = "variable")
} else if (current_group %in% vars) {
if (debugThis) {
print("updating group choices; keeping selected")
}
updateSelectInput(
session,
"group",
choices = c("variable", vars),
selected = input$group
)
}
current_id <- input$id
if (is.null(input$id)) {
current_id <- "empty"
}
if (!current_id %in% vars) {
if (debugThis) {
print("updating id")
}
updateSelectInput(session,
"id",
choices = vars,
selected = "Sample")
} else if (current_id %in% vars) {
if (debugThis) {
print("updating id choices; keeping selected")
}
updateSelectInput(session,
"id",
choices = vars,
selected = input$id)
}
updateSelectInput(session,
"beadColumn",
choices = c("none", vars),
selected = "Total Bead")
updateSelectInput(
session,
"dilutionColumn",
choices = c("none", vars),
selected = "Dilution"
)
}, priority = 3)
#### Update comps ####
observeEvent({
input$sheet
input$comp
}, {
req(input$sheet,
input$comp)
if (debugThis) {
print("updating comps")
}
vars <- unique(rawData()[[input$comp]])
if (is.null(vars)) {
vars <- character(0)
}
updateSelectInput(session,
"comps",
choices = vars,
selected = vars)
}, priority = 2)
#### Filter tibble ####
observeEvent({
input$refreshData
input$columns
input$variables
input$comp
input$group
input$comps
input$id
input$beadColumn
input$dilutionColumn
}, {
req(
input$sheet,
input$columns,
input$variables,
input$comp,
input$group,
length(input$comps) > 1,
input$id
)
if (debugThis) {
print("organizing dataframe")
}
d <- plotGrouper::organizeData(
data = rawData(),
exclude = input$columns,
comp = input$comp,
comps = input$comps,
variables = input$variables,
id = input$id,
beadColumn = input$beadColumn,
dilutionColumn = input$dilutionColumn
)
dataFrame(d)
}, priority = 1)
#### Create plot object ####
plotInput <- function() {
if (debugThis) {
print("running plotting function")
}
variables <- c(input$variables)
groups <- unique(dataFrame()[[input$group]])
comparisons <- unique(dataFrame()[[input$comp]])
comps <- c(input$comps)
errortype <-
ifelse(input$errortype == "SE", "mean_se", "mean_sdl")
y.min <- ifelse(is.null(input$y.min), NA, input$y.min)
y.max <- ifelse(is.null(input$y.max), NA, input$y.max)
y.lim <- c(y.min, y.max)
if (input$split.on == "") {
split_str <- NULL
} else {
split_str <- input$split.on
}
if (input$y.lab == "") {
y.lab <- NULL
} else {
y.lab <- input$y.lab
}
ref.group <- NULL
if (input$refGroup) {
ref.group <- comps[1]
}
levs.comps <- order(factor(unique(dataFrame()[[input$comp]]),
levels = comps))
levs <- order(factor(unique(dataFrame()[[input$group]]),
levels = variables))
cols <- c()
fills <- c()
shapes <- c()
lapply(seq_len(length(comparisons)), function(i) {
cols[i] <<- input[[paste0("col", i)]]
fills[i] <<- input[[paste0("fill", i)]]
shapes[i] <<- as.numeric(input[[paste0("shape", i)]])
})
if (input$trim == "") {
updateTextInput(session, "trim", value = "none")
}
plotGrouper::gplot(
dataset = dataFrame(),
comparison = input$comp,
group.by = input$group,
geom = input$geom,
errortype = errortype,
method = input$method,
paired = input$paired,
ref.group = ref.group,
p = input$pDisplay,
size = input$size,
stroke = input$stroke,
width = input$width,
dodge = input$dodge,
font_size = input$font,
plotWidth = input$plotWidth,
plotHeight = input$plotHeight,
trans.y = input$trans.y,
y.lim = y.lim,
split = input$split,
split_str = split_str,
trim = input$trim,
angle = input$angle.x,
y.lab = y.lab,
leg.pos = input$legend,
levs = levs,
levs.comps = levs.comps,
color.groups = cols,
fill.groups = fills,
shape.groups = shapes,
sci = input$scientific
)
}
#### Create current plot ####
currentPlot <- reactive({
if (debugThis) {
print("currentPlot triggered")
}
req(!is.null(dataFrame()),
all(dataFrame()$variable %in% colnames(rawData())))
lapply(seq_len(length(unique(dataFrame(
)[[input$comp]]))), function(i) {
req(input[[paste0("shape", i)]],
input[[paste0("col", i)]],
input[[paste0("fill", i)]])
})
if (debugThis) {
print("Generating current plot")
}
plotInput()
})
#### Store current plot height ####
cpHeight <- reactive({
if (debugThis) {
print("calculating plot height")
}
if (is.null(dataFrame())) {
return(1)
}
req(currentPlot())
pheight <-
sum(as.numeric(grid::convertUnit(currentPlot()$heights, "mm")))
# return total height in pixels
return(pheight * 3.7795275591)
})
#### Store current plot width ####
cpWidth <- reactive({
if (debugThis) {
print("calculating plot width")
}
if (is.null(dataFrame())) {
return(1)
}
req(currentPlot())
pwidth <-
sum(as.numeric(grid::convertUnit(currentPlot()$widths, "mm")))
return(pwidth * 3.7795275591)
})
#### Calculate stats ####
stats <- function() {
if (debugThis) {
print("calculating statistics")
}
variables <- c(input$variables)
groups <- unique(dataFrame()[[input$group]])
comps <- c(input$comps)
errortype <-
ifelse(input$errortype == "SE", "mean_se", "mean_sdl")
if (input$group == "variable") {
levs <- order(factor(unique(dataFrame()[[input$group]]),
levels = variables))
} else {
levs <- order(factor(groups), levels = groups)
}
levs.comps <- order(factor(unique(dataFrame()[[input$comp]]),
levels = comps))
ref.group <- NULL
if (input$refGroup) {
ref.group <- comps[1]
}
plotGrouper::gplot(
dataset = dataFrame(),
comparison = input$comp,
group.by = input$group,
errortype = errortype,
method = input$method,
paired = input$paired,
ref.group = ref.group,
levs = levs,
levs.comps = levs.comps,
stats = TRUE
)
}
#### Calculate report dimensions ####
reportDims <- function(current_numcol = NULL) {
widths <- unlist(reactiveValuesToList(wlist), use.names = FALSE)
heights <-
unlist(reactiveValuesToList(hlist), use.names = FALSE)
length(widths) <- suppressWarnings(prod(dim(matrix(widths,
ncol = current_numcol))))
length(heights) <- suppressWarnings(prod(dim(
matrix(heights,
ncol = current_numcol)
)))
widths[is.na(widths)] <- 0
heights[is.na(heights)] <- 0
wdims <- tibble::as.tibble(matrix(widths,
ncol = current_numcol,
byrow = TRUE)) %>%
dplyr::mutate(rowSums = rowSums(., na.rm = TRUE))
hdims <- tibble::as.tibble(matrix(heights,
ncol = current_numcol,
byrow = TRUE))
reportWidth(ceiling(max(wdims$rowSums, na.rm = TRUE)))
reportHeight(ceiling(max(colSums(hdims, na.rm = TRUE), na.rm = TRUE)))
}
#### Create shape picker ####
output$shapes <- renderUI({
req(input$sheet,
input$comp,
length(input$comps) > 1,
input$group)
if (debugThis) {
print("shape picker")
}
comparisons <- c(input$comps)
options <- c(19, 21, 17, 24, 15, 22)
choices <- c(19, 21, 17, 24, 15, 22)
comps <- input$comps
if (input$lock.shapes) {
choices <- c()
lapply(seq_len(length(comparisons)), function(i) {
choices[i] <<- as.numeric(input[[paste0("shape", i)]])
})
}
selection <- rep(choices[seq_len(length(comparisons))],
length(comparisons))
lapply(1:length(comparisons), function(i) {
shiny::tags$div(
style = "margin-bottom:25px;",
selectInput(
inputId = paste0("shape", i),
label = comparisons[i],
choices = options,
selected = selection[i]
)
)
})
})
#### Create color picker ####
output$colors <- renderUI({
req(input$sheet,
input$comp,
length(input$comps) > 1,
input$group)
if (debugThis) {
print("color picker")
}
comparisons <- c(input$comps)
choices <- palette_cols()
comps <- input$comps
if (input$lock.cols) {
choices <- c()
lapply(seq_len(length(comparisons)), function(i) {
choices[i] <<- input[[paste0("col", i)]]
})
}
selection <- rep(choices, length(comparisons))
lapply(seq_len(length(comparisons)), function(i) {
colourpicker::colourInput(
inputId = paste0("col", i),
label = comparisons[i],
value = selection[i]
)
})
})
#### Create fill picker ####
output$fills <- renderUI({
req(input$sheet,
input$comp,
length(input$comps) > 1,
input$group)
if (debugThis) {
print("fill picker")
}
comparisons <- c(input$comps)
comps <- input$comps
choices <- palette_fills()
if (input$lock.fills) {
choices <- c()
lapply(seq_len(length(comparisons)), function(i) {
choices[i] <<- input[[paste0("fill", i)]]
})
}
selection <- rep(choices, length(comparisons))
lapply(1:length(comparisons), function(i) {
colourpicker::colourInput(
inputId = paste0("fill", i),
label = comparisons[i],
value = selection[i],
allowTransparent = TRUE
)
})
})
#### Plot the data ####
output$myPlot <- renderImage({
if (debugThis) {
print("rendering plot")
}
# A temp file to save the output.
# This file will be removed later by renderImage
outfile <- tempfile(fileext = ".png")
# Generate the PNG
png(
outfile,
width = cpWidth() * 3,
height = cpHeight() * 3,
res = 72 * 3
)
gridExtra::grid.arrange(currentPlot())
dev.off()
# Return a list containing the filename
list(
src = outfile,
contentType = "image/png",
width = cpWidth(),
height = cpHeight(),
alt = "This is alternate text"
)
}, deleteFile = TRUE)
#### Save plot ####
output$downloadPlot <- downloadHandler(
file = function() {
paste0(input$filename, ".pdf")
},
content = function(file) {
ggplot2::ggsave(
file,
plot = isolate(currentPlot()),
useDingbats = FALSE,
height = isolate(cpHeight()) / 3.7795275591,
width = isolate(cpWidth()) / 3.7795275591,
units = "mm",
device = "pdf"
)
}
)
#### Create stats table ####
output$stat_display <- renderDataTable({
if (debugThis) {
print("creating datatable of statistics")
}
req(input$variables)
stats()
})
#### Save stats table ####
output$save.stat <- downloadHandler(
file = function() {
paste0(input$file, "_stats", ".csv")
},
content = function(file) {
readr::write_csv(stats(), file, col_names = TRUE)
}
)
#### Create table of plotted data ####
output$data_table_display <- renderDataTable({
if (debugThis) {
print("creating datatable of plotted data")
}
req(input$variables)
dataFrame()
})
#### Create table with raw data ####
output$raw_data_table_display <- renderDataTable({
if (debugThis) {
print("creating datatable of raw data")
}
req(input$variables)
rawData()
})
#### Add current plot to report ####
observeEvent(input$plt2rprt, {
req(input$sheet)
if (debugThis) {
print("plt2rprt was clicked")
}
comparisons <- unique(dataFrame()[[input$comp]])
previous_plotListLength <- plotListLength()
plotListLength(previous_plotListLength + 1)
current_plotListLength <- previous_plotListLength + 1
prev_numcol <- ifelse(previous_plotListLength == 0, 1,
floor(sqrt(previous_plotListLength)))
current_numcol <- floor(sqrt(current_plotListLength))
prev_numrow <- ifelse(previous_plotListLength == 0,
1,
ceiling(previous_plotListLength / prev_numcol))
current_numrow <-
ceiling(current_plotListLength / current_numcol)
wlist[[as.character(current_plotListLength)]] <- cpWidth()
hlist[[as.character(current_plotListLength)]] <- cpHeight()
reportDims(current_numcol = current_numcol)
plotList[[as.character(current_plotListLength)]] <-
isolate(currentPlot())
inputs[[as.character(current_plotListLength)]] <-
isolate(reactiveValuesToList(input))
reportPlots <- as.character(1:current_plotListLength)
cols <- c()
fills <- c()
shapes <- c()
lapply(seq_len(length(comparisons)), function(i) {
cols[i] <<- input[[paste0("col", i)]]
fills[i] <<- input[[paste0("fill", i)]]
shapes[i] <<- as.numeric(input[[paste0("shape", i)]])
})
inputs[[as.character(current_plotListLength)]]$cols <- cols
inputs[[as.character(current_plotListLength)]]$fills <- fills
inputs[[as.character(current_plotListLength)]]$shapes <- shapes
updateSelectInput(session,
"loadPlot",
choices = reportPlots,
selected = reportPlots[current_plotListLength])
})
#### Clear last plot from report ####
observeEvent(input$clear, {
if (debugThis) {
print("clear last plot from report was clicked")
}
previous_plotListLength <- plotListLength()
if (previous_plotListLength > 1) {
current_plotListLength <- previous_plotListLength - 1
plotListLength(current_plotListLength)
prev_numcol <- floor(sqrt(previous_plotListLength))
current_numcol <- floor(sqrt(current_plotListLength))
prev_numrow <- ceiling(previous_plotListLength / prev_numcol)
current_numrow <-
ceiling(current_plotListLength / current_numcol)
wlist[[as.character(previous_plotListLength)]] <- NULL
hlist[[as.character(previous_plotListLength)]] <- NULL
plotList[[as.character(previous_plotListLength)]] <-
grid::nullGrob(vp = NULL)
inputs[[as.character(previous_plotListLength)]] <- NULL
reportDims(current_numcol = current_numcol)
reportPlots <- as.character(1:current_plotListLength)
updateSelectInput(session,
"loadPlot",
choices = reportPlots,
selected = reportPlots[current_plotListLength])
}
if (previous_plotListLength == 1) {
plotList[[as.character(1)]] <- grid::nullGrob(vp = NULL)
inputs[[as.character(1)]] <- NULL
wlist[[as.character(1)]] <- NULL
hlist[[as.character(1)]] <- NULL
plotListLength(0)
reportHeight(10)
reportWidth(10)
updateSelectInput(session,
"loadPlot",
choices = "",
selected = "")
}
})
#### Clear all plots from report ####
observeEvent(input$clearAll, {
if (debugThis) {
print("clear all plots from report was clicked")
}
previous_plotListLength <- plotListLength()
for (i in seq_len(previous_plotListLength)) {
plotList[[as.character(i)]] <- grid::nullGrob(vp = NULL)
inputs[[as.character(i)]] <- NULL
wlist[[as.character(i)]] <- NULL
hlist[[as.character(i)]] <- NULL
}
plotListLength(0)
reportHeight(10)
reportWidth(10)
updateSelectInput(session,
"loadPlot",
choices = "",
selected = "")
})
#### Update plot in report ####
observeEvent(input$update, {
if (debugThis) {
print("updating plot in report")
}
req(plotListLength() >= 1)
comparisons <- unique(dataFrame()[[input$comp]])
current_plotListLength <- plotListLength()
current_numcol <- floor(sqrt(current_plotListLength))
wlist[[as.character(input$loadPlot)]] <- cpWidth()
hlist[[as.character(input$loadPlot)]] <- cpHeight()
reportDims(current_numcol = current_numcol)
plotList[[input$loadPlot]] <- isolate(currentPlot())
inputs[[input$loadPlot]] <- isolate(reactiveValuesToList(input))
cols <- c()
fills <- c()
shapes <- c()
lapply(seq_len(length(comparisons)), function(i) {
cols[i] <<- input[[paste0("col", i)]]
fills[i] <<- input[[paste0("fill", i)]]
shapes[i] <<- as.numeric(input[[paste0("shape", i)]])
})
inputs[[input$loadPlot]]$cols <- cols
inputs[[input$loadPlot]]$fills <- fills
inputs[[input$loadPlot]]$shapes <- shapes
})
#### Create report ####
output$myReport <- renderImage({
if (debugThis) {
print("rendering report image")
}
current_plotListLength <- plotListLength()
# A temp file to save the output.
# This file will be removed later by renderImage
outfile <- tempfile(fileext = ".png")
# Generate the PNG
png(
outfile,
width = reportWidth() * 3,
height = reportHeight() * 3,
res = 72 * 3
)
if (current_plotListLength > 0) {
numcol <- floor(sqrt(current_plotListLength))
gridExtra::grid.arrange(
grobs = reactiveValuesToList(plotList)[1:current_plotListLength],
ncol = numcol)
}
dev.off()
# Return a list containing the filename
list(
src = outfile,
contentType = "image/png",
width = reportWidth(),
height = reportHeight(),
alt = "Nothing added to report yet."
)
}, deleteFile = TRUE)
#### Download report ####
output$downloadReport <- downloadHandler(
file = function() {
paste(input$report, "pdf", sep = ".")
},
content = function(file) {
ggplot2::ggsave(
file,
plot =
if (plotListLength() > 0) {
numcol <- floor(sqrt(plotListLength()))
gridExtra::arrangeGrob(grobs = reactiveValuesToList(plotList)
[1:isolate(plotListLength())],
ncol = numcol)
},
useDingbats = FALSE,
height = (reportHeight() / 3.7795275591) + 25,
width = (reportWidth() / 3.7795275591) + 25,
units = "mm",
device = "pdf",
limitsize = FALSE
)
}
)
#### Load plot from report ####
observeEvent(input$load, {
req(plotListLength() >= 1)
if (debugThis) {
print("Loading last sheet")
}
updateSelectInput(session,
"sheet",
selected = inputs[[input$loadPlot]]$sheet)
}, priority = -1)
observeEvent(input$load, {
req(plotListLength() >= 1)
if (debugThis) {
print("Loading last columns")
}
updateSelectInput(session,
"columns",
selected = inputs[[input$loadPlot]]$columns)
}, priority = -2)
observeEvent(input$load, {
req(plotListLength() >= 1)
if (debugThis) {
print("Loading last variables")
}
updateSelectInput(session,
"variables",
selected = inputs[[input$loadPlot]]$variables)
}, priority = -3)
observeEvent(input$load, {
req(plotListLength() >= 1)
if (debugThis) {
print("Loading last comparisons")
}
updateSelectInput(session,
"comp",
selected = inputs[[input$loadPlot]]$comp)
}, priority = -4)
observeEvent(input$load, {
req(plotListLength() >= 1)
if (debugThis) {
print("Loading last id")
}
updateSelectInput(session,
"id",
selected = inputs[[input$loadPlot]]$id)
}, priority = -5)
observeEvent(input$load, {
req(plotListLength() >= 1)
if (debugThis) {
print("Loading last group")
}
updateSelectInput(session,
"group",
selected = inputs[[input$loadPlot]]$group)
updateSelectInput(session,
"comps",
selected = inputs[[input$loadPlot]]$comps)
}, priority = -6)
observeEvent(input$load, {
req(plotListLength() >= 1)
if (debugThis) {
print("Loading independent inputs")
}
updateSelectInput(session,
"beadColumn",
selected = inputs[[input$loadPlot]]$beadColumn)
updateSelectInput(session,
"dilutionColumn",
selected = inputs[[input$loadPlot]]$dilutionColumn)
updateTextInput(session,
"y.lab",
value = inputs[[input$loadPlot]]$y.lab)
updateSelectInput(session,
"geom",
selected = inputs[[input$loadPlot]]$geom)
updateSelectInput(session,
"method",
selected = inputs[[input$loadPlot]]$method)
updateSelectInput(session,
"trans.y",
selected = inputs[[input$loadPlot]]$trans.y)
updateSelectInput(session,
"legend",
selected = inputs[[input$loadPlot]]$legend)
updateSelectInput(session,
"errortype",
selected = inputs[[input$loadPlot]]$errortype)
updateSliderInput(session,
"font",
value = inputs[[input$loadPlot]]$font)
updateSliderInput(session,
"size",
value = inputs[[input$loadPlot]]$size)
updateSliderInput(session,
"stroke",
value = inputs[[input$loadPlot]]$stroke)
updateSliderInput(session,
"plotWidth",
value = inputs[[input$loadPlot]]$plotWidth)
updateSliderInput(session,
"plotHeight",
value = inputs[[input$loadPlot]]$plotHeight)
updateSliderInput(session,
"width",
value = inputs[[input$loadPlot]]$width)
updateSliderInput(session,
"dodge",
value = inputs[[input$loadPlot]]$dodge)
updateTextInput(session,
"trim",
value = inputs[[input$loadPlot]]$trim)
updateTextInput(session,
"split.on",
value = inputs[[input$loadPlot]]$split.on)
updateCheckboxInput(session,
"split",
value = inputs[[input$loadPlot]]$split)
updateCheckboxInput(session,
"angle.x",
value = inputs[[input$loadPlot]]$angle.x)
updateCheckboxInput(session,
"refGroup",
value = inputs[[input$loadPlot]]$refGroup)
updateCheckboxInput(session,
"paired",
value = inputs[[input$loadPlot]]$paired)
updateSelectInput(session,
"pDisplay",
selected = inputs[[input$loadPlot]]$pDisplay)
updateCheckboxInput(session,
"scientific",
value = inputs[[input$loadPlot]]$scientific)
}, priority = -7)
observeEvent(input$load, {
req(plotListLength() >= 1)
if (debugThis) {
print("updating colors, fills, shapes")
}
for (i in 1:length(unique(dataFrame()[[input$comp]]))) {
colourpicker::updateColourInput(session,
paste0("col", i),
value = inputs[[input$loadPlot]][[paste0(
"col",
i)]])
colourpicker::updateColourInput(session,
paste0("fill", i),
value = inputs[[input$loadPlot]][[paste0(
"fill",
i)]])
updateSelectInput(session,
paste0("shape", i),
selected = inputs[[input$loadPlot]][[paste0(
"shape",
i)]])
}
}, priority = -8)
#### Refresh plots in report ####
observeEvent(input$refresh, {
req(input$file,
plotListLength() >= 1)
for (i in as.character(seq_len(plotListLength()))) {
if (debugThis) {
print(paste0("refreshing plot: ", i))
}
if (fileExtension() %in% c("xlsx", "xls")) {
rData <- plotGrouper::readData(sheet = input$sheet,
file = input$file$datapath)
}
if (fileExtension() == "csv") {
rData <- readr::read_csv(input$file$datapath, col_names = TRUE) %>%
dplyr::mutate("Sheet" = input$sheet) %>%
dplyr::select(Sheet, dplyr::everything())
}
if (fileExtension() == "tsv") {
rData <- readr::read_tsv(input$file$datapath, col_names = TRUE) %>%
dplyr::mutate("Sheet" = input$sheet) %>%
dplyr::select(Sheet, dplyr::everything())
}
oData <- plotGrouper::organizeData(
data = rData,
exclude = inputs[[i]]$columns,
comp = inputs[[i]]$comp,
comps = inputs[[i]]$comps,
variables = inputs[[i]]$variables,
id = inputs[[i]]$id,
beadColumn = inputs[[i]]$beadColumn,
dilutionColumn = inputs[[i]]$dilutionColumn
)
errortype <-
ifelse(inputs[[i]]$errortype == "SE", "mean_se", "mean_sdl")
if (inputs[[i]]$split.on == "") {
split_str <- NULL
} else {
split_str <- inputs[[i]]$split.on
}
if (inputs[[i]]$y.lab == "") {
y.lab <- NULL
} else {
y.lab <- inputs[[i]]$y.lab
}
ref.group <- NULL
if (inputs[[i]]$refGroup) {
ref.group <- inputs[[i]]$comps[1]
}
levs.comps <- order(factor(unique(oData[[inputs[[i]]$comp]]),
levels = inputs[[i]]$comps))
levs <- order(factor(unique(oData[[inputs[[i]]$group]]),
levels = inputs[[i]]$variables))
cols <- inputs[[i]]$cols
fills <- inputs[[i]]$fills
shapes <- inputs[[i]]$shapes
if (inputs[[i]]$trim == "") {
updateTextInput(session, "trim", value = "none")
}
cPlot <- plotGrouper::gplot(
dataset = oData,
comparison = inputs[[i]]$comp,
group.by = inputs[[i]]$group,
geom = inputs[[i]]$geom,
errortype = errortype,
method = inputs[[i]]$method,
paired = inputs[[i]]$paired,
ref.group = ref.group,
p = inputs[[i]]$pDisplay,
size = inputs[[i]]$size,
stroke = inputs[[i]]$stroke,
width = inputs[[i]]$width,
dodge = inputs[[i]]$dodge,
font_size = inputs[[i]]$font,
plotWidth = inputs[[i]]$plotWidth,
plotHeight = inputs[[i]]$plotHeight,
trans.y = inputs[[i]]$trans.y,
split = inputs[[i]]$split,
split_str = split_str,
trim = inputs[[i]]$trim,
angle = inputs[[i]]$angle.x,
y.lab = y.lab,
leg.pos = inputs[[i]]$legend,
levs = levs,
levs.comps = levs.comps,
color.groups = cols,
fill.groups = fills,
shape.groups = shapes,
sci = inputs[[i]]$scientific
)
pheight <-
sum(as.numeric(grid::convertUnit(cPlot$heights, "mm"))) *
3.7795275591
pwidth <-
sum(as.numeric(grid::convertUnit(cPlot$widths, "mm"))) *
3.7795275591
wlist[[i]] <- pwidth
hlist[[i]] <- pheight
plotList[[i]] <- cPlot
}
current_plotListLength <- plotListLength()
current_numcol <- floor(sqrt(current_plotListLength))
reportDims(current_numcol = current_numcol)
})
#### Bookmarking values ####
onBookmark(function(state) {
state$values$plotList <- reactiveValuesToList(plotList)
state$values$inputs <- reactiveValuesToList(inputs)
state$values$plotListLength <- isolate(plotListLength())
state$values$hlist <- reactiveValuesToList(hlist)
state$values$wlist <- reactiveValuesToList(wlist)
})
#### Restoring values ####
onRestored(function(state) {
if (debugThis) {
print("Restoring report")
}
plotListLength(state$values$plotListLength)
for (i in seq_len(isolate(plotListLength()))) {
inputs[[as.character(i)]] <- state$values$inputs[[as.character(i)]]
plotList[[as.character(i)]] <-
state$values$plotList[[as.character(i)]]
hlist[[as.character(i)]] <-
state$values$hlist[[as.character(i)]]
wlist[[as.character(i)]] <-
state$values$wlist[[as.character(i)]]
}
plotListPlots <-
as.character(seq_len(isolate(plotListLength())))
updateSelectInput(session,
"loadPlot",
choices = plotListPlots,
selected = tail(plotListPlots, 1))
current_plotListLength <- plotListLength()
current_numcol <- floor(sqrt(current_plotListLength))
reportDims(current_numcol = current_numcol)
})
#### Stop app on close ####
session$onSessionEnded(function() {
graphics.off()
})
session$onSessionEnded(stopApp)
}
shiny::shinyApp(ui, server, enableBookmarking = "server")
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.