simplify the subset of a table using multiple conditions in R shiny - r

I am writing a shiny app (shinydashboard) that looks like the figure (the app run on my company private network,so I can't share the link to it).
The dataset consists of a table containing the expression values of different genes (rows) for different samples (columns).
The app should return a subset of that table based on the search criteria selected by the user. Information about the samples are stored in a different table (B38.Metadata in the code), that looks like this:
SampleID,RNA.ID,RNAseq.ID,Name,Description,Tissue Type,...
CP3027,CP3027,74,Hs514,Aortic_Endothelial,Vascular system,Endothelial,...
CP3028,CP3028,76,HEr1,Aortic_Endothelial,Vascular system,Endothelial,...
At every search, the metadata are checked and the main table is subset accordingly.
My approach has been to write a function for each search types (SearchByGene,SearchByTissue,...), and
use if-else statements to account for all the possible combinations.
For example, filter by GeneName, Tissue type, and Name, but not for the other options.
This led to a massive 14 if-else block, spanning almost 50 lines of code (see below).
everything works, but the code is dreadful to read and debug.
Furthermore the idea of adding additional search possibilities (e.g. search by sequencing technique)
made me shiver.
I considered using a switch construct, but, having multiple conditions to test I'm not sure it will clean the code too much.
Is there a way of simplify the if-else block with something easier to read and, especially, maintain?
Searchfunction <- function(dataSet2){
selectedTable <- reactive({
# Create a DF with only the gene names
DFgeneLevel <- DummyDFgeneLevel(dataSet2) # not used for now
# Subset by Columns first
if(is.null(input$tissues) && is.null(input$samples) && is.null(input$Name)){
TableByColumns <- dataSet2
} else if(!is.null(input$tissues) && !is.null(input$samples) && !is.null(input$Name)){
TableByTissue <- SearchByTissue(input$tissues,B38.metadata,dataSet2)
TableBySample <- SearchBySample(input$samples,TableByTissue)
TableByColumns <- SearchByName(input$Name,B38.metadata,TableBySample)
} else if(!is.null(input$tissues)){
if(is.null(input$samples) && is.null(input$Name)){
TableByColumns <- SearchByTissue(input$tissues,B38.metadata,dataSet2)
} else if(is.null(input$samples) && !is.null(input$Name)){
TableByTissue <- SearchByTissue(input$tissues,B38.metadata,dataSet2)
TableByColumns <- SearchByName(input$Name,B38.metadata,TableByTissue)
} else if(!is.null(input$samples) && is.null(input$Name)){
TableByTissue <- SearchByTissue(input$tissues,B38.metadata,dataSet2)
TableByColumns <- SearchBySample(input$samples,TableByTissue)
}
} else if(is.null(input$tissues)){
if(is.null(input$samples) && !is.null(input$Name)){
TableByColumns <- SearchByName(input$Name,B38.metadata,dataSet2)
} else if(!is.null(input$samples) && is.null(input$Name)){
TableByColumns <- SearchBySample(input$samples,dataSet2)
} else if(!is.null(input$samples) && !is.null(input$Name)){
TableByName <- SearchBySample(input$samples,dataSet2)
TableByColumns <- SearchByName(input$Name,B38.metadata,TableByName)
}
}
# Collect all the inputs & subset by Rows
#genes.Selected <- toupper(genes.Selected) # can't use it as some genes contains lowerletters
genesFromList <- unlist(strsplit(input$genesLists,","))
genes.Selected <- unlist(strsplit(input$SearchCrit," "))
if(input$SearchCrit == '' && input$genesLists == 0){
TableByRow <- TableByColumns
} else if(input$SearchCrit != '' && input$genesLists != 0){
TableByList <- subset(TableByColumns, TableByColumns$GeneName %in% genesFromList)
TableByRow <- subset(TableByList, TableByList$GeneName %in% genes.Selected)
} else if(input$SearchCrit != '' && input$genesLists == 0){
TableByRow <- subset(TableByColumns, TableByColumns$GeneName %in% genes.Selected)
} else if(input$SearchCrit == '' && input$genesLists != 0) {
TableByRow <- subset(TableByColumns, TableByColumns$GeneName %in% genesFromList)
}
return(TableByRow)
})
}

Is that what you are trying to achieve ?
Filter samples that match your attributes based on your metadata and display gene expressions only for these samples ?
library(shiny)
library(dplyr)
ui <- fluidPage(
titlePanel("mtcars"),
sidebarLayout(
sidebarPanel(
selectInput("vs",
label = "vs",
choices = c(0, 1),
selected = NULL,
multiple = TRUE),
selectInput("carb",
label = "carb",
choices = c(1, 2, 3, 4, 6, 8),
selected = NULL,
multiple = TRUE),
selectInput("gear",
label = "gear",
choices = c(3, 4, 5),
selected = NULL,
multiple = TRUE)
),
mainPanel(
tabsetPanel(
tabPanel("Expression values", tableOutput("mainTable")),
tabPanel("ID filtering", tableOutput("table"))
)
)
)
)
server <- function(input, output) {
samples.df <- data.frame(ID = paste0("ID", as.character(round(runif(nrow(mtcars),
min = 0,
max = 100 * nrow(mtcars))))),
gear = as.factor(mtcars$gear),
carb = as.factor(mtcars$carb),
vs = as.factor(mtcars$vs))
values.df <- cbind(paste0("Feature", 1:20),
as.data.frame(matrix(runif(20 * nrow(samples.df)), nrow = 20)))
colnames(values.df) <- c("Feature", as.character(samples.df$ID))
vs.values <- reactive({
if (is.null(input$vs)) {
return(c(0, 1))
} else {
return(input$vs)
}
})
carb.values <- reactive({
if (is.null(input$carb)) {
return(c(1, 2, 3, 4, 6, 8))
} else {
return(input$carb)
}
})
gear.values <- reactive({
if (is.null(input$gear)) {
return(c(3, 4, 5))
} else {
return(input$gear)
}
})
filtered.samples.df <- reactive({
return(samples.df %>% filter(gear %in% gear.values(),
vs %in% vs.values(),
carb %in% carb.values()))
})
filtered.values.df <- reactive({
selected.samples <- c("Feature", names(values.df)[names(values.df) %in% filtered.samples.df()$ID])
return(values.df %>% select(selected.samples))
})
output$mainTable <- renderTable({
filtered.values.df()
})
output$table <- renderTable({
filtered.samples.df()
})
}
shinyApp(ui = ui, server = server)

You can try something like this, where we loop over the inputs and subset on the according column if the input is not null.
Hope this helps!
library(shiny)
ui <- fluidPage(
selectizeInput('mpg','mpg:',unique(mtcars$mpg),multiple=T),
selectizeInput('cyl','cyl:',unique(mtcars$cyl),multiple=T),
selectizeInput('gear','gear:',unique(mtcars$gear),multiple=T),
selectizeInput('carb','carb:',unique(mtcars$carb),multiple=T),
tableOutput('mytable')
)
server <- function(input,output)
{
output$mytable <- renderTable({
df = mtcars
select_inputs = c('mpg','cyl','gear','carb')
for (inp in select_inputs)
{
if(!is.null(input[[inp]]))
{
df = df[df[[inp]] %in% input[[inp]],]
}
}
df
})
}
shinyApp(ui,server)

Related

Why is this Shiny app code not reactive when using purrr:map over input variables?

EDIT WITH MWE BELOW
I have below a snippet of my code which is part of a larger app. I'm trying to rewrite the app to work with R6 classes and gargoyle as per this article. However, I cannot figure out why the observe part of the data below does not trigger except when it's initialized. To my understanding should if observe all the filters that are in input based on the map function, am I wrong?
output$filters <- renderUI({
gargoyle::watch("first thing")
data <- Data$get_data(unfiltered = TRUE)
data_names <- names(data)
if(nrow(data) > 0){
map(data_names, ~ render_ui_filter(data[[.x]], .x))
}
}
)
observe({
data <- Data$get_data(unfiltered = TRUE)
data_names <- names(data)
if(ncol(data) > 0){
each_var <- map(data_names, ~ filter_var(data[[.x]], input[[paste0("filter",.x)]]))
Transactions <- Data$set_filters(reduce(each_var, `&`))
gargoyle::trigger("second thing")
}
})
I've had a working case of the second reactive element like this:
selectedData <- reactive({
if(nrow(data()) > 0){
each_var <- map(dataFilterNames(), ~ filter_var(data()[[.x]], input[[paste0("filter",.x)]]))
reduce(each_var, `&`)
}
})
where data and dataFilterNames are reactiveVal and dataFilterNames is the column names of data.
Here you can find render_ui_filter and filter_var:
render_ui_filter <- function(x, var) {
if(all(is.null(x) | is.na(x))){
#If all data is null, don't create a filter from it
return(NULL)
}
id <- paste0("filter",var)
var <- stringr::str_to_title(var)
if (is.numeric(x)) {
if(is.integer(x)){
step = 1
}
else{
step = NULL
}
rng <- range(x, na.rm = TRUE)
sliderInput(id,
var,
min = rng[1],
max = rng[2],
value = rng,
round = TRUE,
width = "90%",
sep = " ",
step = step
)
} else if (is.factor(x)) {
levs <- levels(x)
if(length(levs) < 5){
pickerInput(id, var, choices = levs, selected = levs, multiple = TRUE,
options = list(
title = sprintf("Filter on %s...", var),
#`live-search` = TRUE,
#`actions-box` = TRUE,
size = 10
))
}else {
pickerInput(id, var, choices = levs, selected = levs, multiple = TRUE,
options = list(
title = sprintf("Filter on %s...", var),
`live-search` = TRUE,
`actions-box` = TRUE,
size = 10,
`selected-text-format` = "count > 5"
))
}
} else if (is.Date(x)){
dateRangeInput(id,
var,
start = min(x),
end = max(x),
weekstart = 1,
autoclose = FALSE,
separator = "-")
} else if (is.logical(x)) {
pickerInput(id, var, choices = unique(x), selected = unique(x), multiple = TRUE,
options = list(
title = sprintf("Filter on %s...", var),
`live-search` = TRUE,
#`actions-box` = TRUE,
size = 10
))
} else {
# Not supported
NULL
}
}
filter_var <- function(x, val) {
if(all(is.null(x) | is.na(x))){
#If all data is null, don't create a filter from it
return(TRUE)
}
if (is.numeric(x)) {
!is.na(x) & x >= val[1] & x <= val[2]
} else if (is.factor(x)) {
x %in% val
} else if(is.Date(x)){
!is.na(x) & x >= val[1] & x <= val[2]
} else if (is.logical(x)) {
x %in% val
} else {
# No control, so don't filter
TRUE
}
}
Edit: Here is a MWE that can be run in a notebook for example. It does not currently work since the gargoyle trigger triggers the observe it is in and we end up in a infinity loop. If you remove that you can see that the normal reactive part works, but the R6 version does not create the table ever.
if (interactive()){
require("shiny")
require("R6")
require("gargoyle")
require("purrr")
require("stringr")
# R6 DataSet ----
DataSet <- R6Class(
"DataSet",
private = list(
.data = NA,
.data_loaded = FALSE,
.filters = logical(0)
),
public = list(
initialize = function() {
private$.data = data.frame()
},
get_data = function(unfiltered = FALSE) {
if (!unfiltered) {
return(private$.data[private$.filters, ])
}
else{
return(private$.data)
}
},
set_data = function(data) {
stopifnot(is.data.frame(data))
private$.data <- data
private$.data_loaded <- TRUE
private$.filters <- rep(T, nrow(private$.data))
return(invisible(self))
},
set_filters = function(filters) {
stopifnot(is.logical(filters))
private$.filters <- filters
}
)
)
# Filtering ----
render_ui_filter <- function(x, var) {
if(all(is.null(x) | is.na(x))){
#If all data is null, don't create a filter from it
return(NULL)
}
id <- paste0("filter",var)
var <- stringr::str_to_title(var)
if (is.numeric(x)) {
if(is.integer(x)){
step = 1
}
else{
step = NULL
}
rng <- range(x, na.rm = TRUE)
sliderInput(id,
var,
min = rng[1],
max = rng[2],
value = rng,
round = TRUE,
width = "90%",
sep = " ",
step = step
)
} else {
# Not supported
NULL
}
}
filter_var <- function(x, val) {
if(all(is.null(x) | is.na(x))){
#If all data is null, don't create a filter from it
return(TRUE)
}
if (is.numeric(x)) {
!is.na(x) & x >= val[1] & x <= val[2]
} else {
# No control, so don't filter
TRUE
}
}
# Options ----
options("gargoyle.talkative" = TRUE)
options(shiny.trace = TRUE)
options(shiny.fullstacktrace = TRUE)
ui <- function(request){
tagList(
h4('Filters'),
uiOutput("transactionFilters"),
h4('Reactive'),
tableOutput("table_reactive"),
h4('R6'),
tableOutput("table_r6")
)
}
server <- function(input, output, session){
gargoyle::init("df_r6_filtered")
Name <- c("Jon", "Bill", "Maria", "Ben", "Tina")
Age <- c(23, 41, 32, 58, 26)
df <- reactive(data.frame(Name, Age))
df_r6 <- DataSet$new()
df_r6$set_data(data.frame(Name, Age))
output$transactionFilters <- renderUI(
map(names(df()), ~ render_ui_filter(x = df()[[.x]], var = .x))
)
selected <- reactive({
if(nrow(df()) > 0){
each_var <- map(names(df()), ~ filter_var(df()[[.x]], input[[paste0("filter",.x)]]))
reduce(each_var, `&`)
}
})
observe({
data <- df_r6$get_data(unfiltered = TRUE)
data_names <- names(data)
if(ncol(data) > 0){
each_var <- map(data_names, ~ filter_var(data[[.x]], input[[paste0("filter",.x)]]))
filters_concatted <- reduce(each_var, `&`)
df_r6$set_filters(filters_concatted)
gargoyle::trigger("df_r6_filtered")
}
})
output$table_reactive <- renderTable(df()[selected(),])
gargoyle::on("df_r6_filtered",{
output$table_r6 <- renderTable(df_r6$get_data())
})
}
shinyApp(ui, server)
}
EDIT2: I noticed that the gargoyle::trigger("df_r6_filtered") creates a infinity loop of triggering the observe component. I'm not sure how to get out of it and that's what I am looking for help with.
The answer was simpler then expected of course. Just change the observe to a observeEvent on all of the input elements regarding the filter, i.e. like this:
observeEvent(
eventExpr = {
data <- df_r6$get_data(unfiltered = TRUE)
data_names <- names(data)
map(data_names, ~ input[[paste0("filter",.x)]])
},
{
...
}
})

Using rhandsontable in a shiny module

The application
On startup, a 3 x 3 table is generated with values from 1 to 9 in a random order. What the app user can see is a blank 3 x 3 rhandsontable that he/she will use to try to guess where the generated values are. When the user clicks on the "Submit" button, the cells that contain the correct values turn green and all other cells remain as they are.
My issue
The cells where the user guessed right do not turn green when the user clicks the button. In other words, the conditional formatting does not work even though I got it to work before (that was in the first version of the app when I did not make use of shiny modules).
What I have done
The full project is in the following Github repository that potential users may want to clone instead of copying and pasting the code below: https://github.com/gueyenono/number_game
My project folder has 4 files. The first two files are the usual ui.R and server.R, which essentially call shiny modules (i.e. hot_module_ui() and hot_module()) . The modules are contained within the global.R file. The last file, update_hot.R, contains a function used in the modules.
ui.R
This file loads the required packages, provides a title for the app and calls hot_module_ui(). The module just displays a blank 3 x 3 rhandsontable and an actionButton().
library(shiny)
library(rhandsontable)
source("R/update_hot.R")
ui <- fluidPage(
titlePanel("The number game"),
mainPanel(
hot_module_ui("table1")
)
)
server.R
This file calls the hot_module(), which contains the code for the conditional formatting.
server <- function(input, output, session) {
callModule(module = hot_module, id = "table1")
}
update_hot.R
This is the function which is called when the "Submit" button is called. The function has two arguments:
hot: the handsontable in the app
x: the values generated on startup
This is what the function does (full code for the file is at the end of this section):
Get the user inputs
user_input <- hot_to_r(hot)
Compare user inputs (user_input) to the true values (x) and store the row and column indices of the cells where the user guessed right
i <- which(user_input == x, arr.ind = TRUE)
row_correct <- i[, 1] - 1
col_correct <- i[, 2] - 1
Update the current handsontable object with the row and column indices and use the renderer argument of the hot_cols() function to make background of corresponding cells green. Note that I use the hot_table() function to update the existing rhandsontable object.
hot %>%
hot_table(contextMenu = FALSE, row_correct = row_correct, col_correct = col_correct) %>%
hot_cols(renderer = "function(instance, td, row, col, prop, value, cellProperties){
Handsontable.renderers.TextRenderer.apply(this, arguments);
if(instance.params){
// Correct cell values
row_correct = instance.params.row_correct
row_correct = row_correct instanceof Array ? row_correct : [row_correct]
col_correct = instance.params.col_correct
col_correct = col_correct instanceof Array ? col_correct : [col_correct]
for(i = 0; i < col_correct.length; i++){
if (col_correct[i] == col && row_correct[i] == row) {
td.style.background = 'green';
}
}
return td;
}")
Here is the full code for update_hot.R
update_hot <- function(hot, x){
# Get user inputs (when the submit button is clicked)
user_input <- hot_to_r(hot)
# Get indices of correct user inputs
i <- which(user_input == x, arr.ind = TRUE)
row_correct <- i[, 1] - 1
col_correct <- i[, 2] - 1
# Update the hot object with row_index and col_index for user in the renderer
hot %>%
hot_table(contextMenu = FALSE, row_correct = row_correct, col_correct = col_correct) %>%
hot_cols(renderer = "function(instance, td, row, col, prop, value, cellProperties){
Handsontable.renderers.TextRenderer.apply(this, arguments);
if(instance.params){
// Correct cell values
row_correct = instance.params.row_correct
row_correct = row_correct instanceof Array ? row_correct : [row_correct]
col_correct = instance.params.col_correct
col_correct = col_correct instanceof Array ? col_correct : [col_correct]
for(i = 0; i < col_correct.length; i++){
if (col_correct[i] == col && row_correct[i] == row) {
td.style.background = 'green';
}
}
return td;
}")
}
global.R
This is the file, which contains the shiny modules. The UI module (hot_module_ui()) has:
- an rHandsontableOutput
- an actionButton
- I added a tableOutput in order to see where the generated values are (useful for testing the code)
The server module (hot_module()) calls the update_hot() function and attempts to update the handsontable in the app whenever the user clicks on the "Submit" button. I attempted to achieve this by using an observeEvent and a reactive value react$hot_display. On startup, react$hot_display contains a 3 x 3 data frame of NAs. When the button is clicked, it is updated with the new version of the handsontable (containing user inputs and conditional formatting). Here is the full code for global.R:
hot_module_ui <- function(id){
ns <- NS(id)
tagList(
rHandsontableOutput(outputId = ns("grid")),
br(),
actionButton(inputId = ns("submit"), label = "Submit"),
br(),
tableOutput(outputId = ns("df"))
)
}
hot_module <- function(input, output, session){
values <- as.data.frame(matrix(sample(9), nrow = 3))
react <- reactiveValues()
observe({
na_df <- values
na_df[] <- as.integer(NA)
react$hot_display <- rhandsontable(na_df, rowHeaders = NULL, colHeaders = NULL)
})
observeEvent(input$submit, {
react$hot_display <- update_hot(hot = input$grid, x = values)
})
output$grid <- renderRHandsontable({
react$hot_display
})
output$df <- renderTable({
values
})
}
As mentioned at the beginning, the conditional formatting does not work when the "Submit" button is clicked and I am not sure why. Once again, you can access the full code on the following Github repository:
https://github.com/gueyenono/number_game
I finally found the solution to my issue. One of the biggest lessons I learned was that the hot_to_r() function does not work in custom functions. It must be used in the server function of a shiny app. This means that passing an rhandsontable object to a custom function and retrieving the data from within the function may not be a good idea (which was my story).
I am not sure it will be of interest to anyone, but here is my code, which works as intended:
ui.R
library(rhandsontable)
library(shiny)
source("R/update_hot.R")
shinyUI(fluidPage(
# Application title
titlePanel("The Number Game"),
module_ui(id = "tab")
))
server.R
library(shiny)
shinyServer(function(input, output, session) {
callModule(module = module_server, id = "tab")
})
global.R
module_ui <- function(id){
ns <- NS(id)
tagList(
rHandsontableOutput(outputId = ns("hot")),
actionButton(inputId = ns("submit"), label = "OK"),
actionButton(inputId = ns("reset"), label = "Reset")
)
}
module_server <- function(input, output, session){
clicked <- reactiveValues(submit = FALSE, reset = FALSE)
initial_hot <- rhandsontable(as.data.frame(matrix(NA_integer_, nrow = 3, ncol = 3)))
correct_values <- as.data.frame(matrix(1:9, nrow = 3, byrow = TRUE))
observeEvent(input$submit, {
clicked$submit <- TRUE
clicked$reset <- FALSE
})
updated_hot <- eventReactive(input$submit, {
input_values <- hot_to_r(input$hot)
update_hot(input_values = input_values, correct_values = correct_values)
})
observeEvent(input$reset, {
clicked$reset <- TRUE
clicked$submit <- FALSE
})
reset_hot <- eventReactive(input$reset, {
initial_hot
})
output$hot <- renderRHandsontable({
if(!clicked$submit & !clicked$reset){
out <- initial_hot
} else if(clicked$submit & !clicked$reset){
out <- updated_hot()
} else if(clicked$reset & !clicked$submit){
out <- reset_hot()
}
out
})
}
R/update_hot.R
update_hot <- function(input_values, correct_values){
equal_ids <- which(input_values == correct_values, arr.ind = TRUE)
unequal_ids <- which(input_values != correct_values, arr.ind = TRUE)
rhandsontable(input_values) %>%
hot_table(row_correct = as.vector(equal_ids[, 1]) - 1,
col_correct = as.vector(equal_ids[, 2]) - 1,
row_incorrect = as.vector(unequal_ids[, 1]) - 1,
col_incorrect = as.vector(unequal_ids[, 2]) - 1) %>%
hot_cols(renderer = "function(instance, td, row, col, prop, value, cellProperties){
Handsontable.renderers.TextRenderer.apply(this, arguments);
if(instance.params){
// Correct cell values
row_correct = instance.params.row_correct
row_correct = row_correct instanceof Array ? row_correct : [row_correct]
col_correct = instance.params.col_correct
col_correct = col_correct instanceof Array ? col_correct : [col_correct]
// Incorrect cell values
row_incorrect = instance.params.row_incorrect
row_incorrect = row_incorrect instanceof Array ? row_incorrect : [row_incorrect]
col_incorrect = instance.params.col_incorrect
col_incorrect = col_incorrect instanceof Array ? col_incorrect : [col_incorrect]
for(i = 0; i < col_correct.length; i++){
if (col_correct[i] == col && row_correct[i] == row) {
td.style.background = 'green';
}
}
for(i = 0; i < col_incorrect.length; i++){
if (col_incorrect[i] == col && row_incorrect[i] == row) {
td.style.background = 'red';
}
}
}
return td;
}")
}

An R shiny app that displays both ggplot plots and plotly plots

I'm trying to set up an R shiny app that will enable viewing three types of plots relating to gene expression data.
The data are comprised of:
A data.frame which has the output of the differential expression analysis (each row is a gene and the columns are the effect sizes and their p-values):
set.seed(1)
model.df <- data.frame(id = paste0("g",1:30),symbol = sample(LETTERS[1:5],30,replace=T),
group.effect.size = rnorm(30), group.p.value = runif(30,0,1),
sex.effect.size = rnorm(30), sex.p.value = runif(30,0,1),
stringsAsFactors = F)
A data.frame which has the design of the study (each row is a sample and the columns are the factors that the sample is associated with):
set.seed(1)
design.df <- data.frame(group = c(rep("A",6),rep("B",6)), sex = rep(c(rep("F",3),rep("M",3)),2), replicate = rep(1:6,2)) %>%
dplyr::mutate(sample = paste0(group,".",sex,"_",replicate))
design.df$group <- factor(design.df$group, levels = c("A","B"))
design.df$sex <- factor(design.df$sex, levels = c("F","M"))
A matrix which has the abundance (each row is a gene and each column is a sample):
set.seed(1)
abundance.mat <- matrix(rnorm(30*12), nrow=30, ncol=12, dimnames=list(model.df$id,design.df$sample))
A data.frame which has the results of a gene set enrichment analysis (each row is a set name and the columns are the enrichment test p-values for each factor in design.df):
set.seed(1)
gsea.df <- data.frame(set.name = paste0("S",1:4), group.p.value = format(round(runif(4,0,1),2),scientific = T), sex.p.value = format(round(runif(4,0,1),2),scientific = T), stringsAsFactors = F)
And finally, a data.frame which associates the genes with each set.name in gsea.df:
set.seed(1)
gene.sets.df <- do.call(rbind,lapply(1:4,function(s) data.frame(set.name = paste0("S",s), id = sample(model.df$id,10,replace = F),stringsAsFactors = F)))
I would like the shiny app to enable viewing these types of plots:
Feature Plot - plotting expression level of a single user-selected gene on the y-axis and sample on the x-axis, and that would be combined with an inset of a caterpillar plot showing the estimated effects:
Feature User-Defined Sets Plot - same as Feature Plot, however rather than showing a single -selected gene this will show a set of user-selected-genes and hence rather than points it will show violins of the distributions:
Feature Sets GSEA Plot - a combined list of volcano plots, where in each one the x-axis is the effect size of the factor, the y-axis is the -log10(p-value) of the effect, and the genes are colored red if they belong to the selected gene set:
Here are the three functions for generating these figures given the user selection:
featurePlot <- function(selected.id)
{
replicate.df <- reshape2::melt(abundance.mat[which(rownames(abundance.mat) == selected.id),,drop=F], varnames=c("id","sample")) %>%
dplyr::left_join(design.df)
effects.df <- data.frame(factor.name = c("group","sex"),
effect.size = c(dplyr::filter(model.df,id == selected.id)$group.effect.size,dplyr::filter(model.df,id == selected.id)$sex.effect.size),
p.value = c(dplyr::filter(model.df,id == selected.id)$group.p.value,dplyr::filter(model.df,id == selected.id)$sex.p.value),
stringsAsFactors = F)
effects.df$factor.name <- factor(effects.df$factor.name, levels = c("group","sex"))
main.plot <- ggplot(replicate.df,aes(x=replicate,y=value,color=group,shape=sex))+
geom_point(size=3)+facet_grid(~group,scales="free_x")+
labs(x="Replicate",y="TPM")+theme_minimal()
xlims <- c(-1*max(abs(effects.df$effect.size))-0.1*max(abs(effects.df$effect.size)),max(abs(effects.df$effect.size))+0.1*max(abs(effects.df$effect.size)))
effects.plot <- ggplot(effects.df,aes(x=effect.size,y=factor.name,color=factor.name))+
geom_point()+
geom_vline(xintercept=0,linetype="longdash",colour="black",size=0.25)+theme_minimal()+xlim(xlims)+
theme(legend.position="none")+ylab("")+xlab("Effect Size")
null.plot <- ggplot(data.frame())+geom_point()+geom_blank()+theme_minimal()
combined.plot <- gridExtra::arrangeGrob(main.plot,gridExtra::arrangeGrob(null.plot,effects.plot,ncol=1),nrow=1,ncol=2,widths=c(5,2.5))
return(combined.plot)
}
featureSetPlot <- function(selected.ids)
{
replicate.df <- reshape2::melt(abundance.mat[which(rownames(abundance.mat) %in% selected.ids),,drop=F], varnames=c("id","sample")) %>%
dplyr::left_join(design.df)
replicate.df$replicate <- as.factor(replicate.df$replicate)
effects.df <- data.frame(factor.name = c("group","sex"),
effect.size = c(dplyr::filter(model.df,id %in% selected.ids)$group.effect.size,dplyr::filter(model.df,id %in% selected.ids)$sex.effect.size),
p.value = c(dplyr::filter(model.df,id %in% selected.ids)$group.p.value,dplyr::filter(model.df,id %in% selected.ids)$sex.p.value),
stringsAsFactors = F)
effects.df$factor.name <- factor(effects.df$factor.name, levels = c("group","sex"))
main.plot <- ggplot(replicate.df,aes(x=replicate,y=value,color=group,fill=sex))+
geom_violin(trim=F,draw_quantiles=c(0.25,0.5,0.75),alpha=0.25)+facet_grid(~group,scales="free_x")+
labs(x="Replicate",y="TPM")+theme_minimal()
effects.plot <- ggplot(effects.df,aes(y=effect.size,x=factor.name,color=factor.name,fill=factor.name))+
geom_violin(trim=F,draw_quantiles=c(0.25,0.5,0.75),alpha=0.25)+coord_flip()+
geom_hline(yintercept=0,linetype="longdash",colour="black",size=0.25)+theme_minimal()+
theme(legend.position="none")+xlab("")+ylab("Effect Size Distribution")
null.plot <- ggplot(data.frame())+geom_point()+geom_blank()+theme_minimal()
combined.plot <- gridExtra::arrangeGrob(main.plot,gridExtra::arrangeGrob(null.plot,effects.plot,ncol=1),nrow=1,ncol=2,widths=c(5,2.5))
return(combined.plot)
}
gseaPlot <- function(selected.set)
{
plot.df <- model.df %>%
dplyr::left_join(gene.sets.df %>% dplyr::filter(set.name == selected.set))
plot.df$set.name[which(is.na(plot.df$set.name))] <- "non.selected"
plot.df$set.name <- factor(plot.df$set.name, levels = c("non.selected",selected.set))
factor.names <- c("group","sex")
gsea.volcano.plot <- lapply(factor.names,function(f)
plotly::plot_ly(type='scatter',mode="markers",marker=list(size=5),color=plot.df$set.name,colors=c("lightgray","darkred"),x=plot.df[,paste0(f,".effect.size")],y=-log10(plot.df[,paste0(f,".p.value")]),showlegend=F) %>%
plotly::layout(annotations=list(showarrow=F,x=0.5,y=0.95,align="center",xref="paper",xanchor="center",yref="paper",yanchor="bottom",font=list(size=12,color="darkred"),text=paste0(f," (",dplyr::filter(gsea.df,set.name == selected.set)[,paste0(f,".p.value")],")")),
xaxis=list(title=paste0(f," Effect"),zeroline=F),yaxis=list(title="-log10(p-value)",zeroline=F))
) %>% plotly::subplot(nrows=1,shareX=F,shareY=T,titleX=T,titleY=T) %>%
plotly::layout(title=selected.set)
return(gsea.volcano.plot)
}
Thus:
plot.type.choices <- c('Feature User-Defined Set Plot','Feature Sets GSEA Plot','Feature Plot')
So the first two use ggplot2 for generating each of the two figures they combine, which is then achieved using gridExtra::arrangeGrob. The last one uses plotly.
Here's the shiny code part I've been trying out, but with no luck:
server <- function(input, output)
{
out.plot <- reactive({
if(input$plotType == "Feature Plot"){
out.plot <- featurePlot(selected.id=dplyr::filter(model.df,symbol == input$symbol)$id[1])
} else if(input$plotType == "Feature User-Defined Set Plot"){
out.plot <- featureSetPlot(selected.ids=unique(dplyr::filter(model.df,symbol == input$set.symbols)$id))
} else if(input$plotType == "Feature Sets GSEA Plot"){
out.plot <- gseaVolcanoPlot(selected.set=input$set.name)
}
})
output$out.plot <- renderPlot({
if(input$plotType != "Feature Sets GSEA Plot"){
grid::grid.draw(out.plot())
} else{
out.plot()
}
})
output$save <- downloadHandler(
filename = function() {
paste0("./plot.pdf")
},
content = function(file) {
ggsave(out.plot(),filename=file,width=10,height=5)
}
)
}
ui <- fluidPage(
tags$style(type="text/css",".shiny-output-error { visibility: hidden; }",".shiny-output-error:before { visibility: hidden; }"),
titlePanel("Results Explorer"),
sidebarLayout(
sidebarPanel(
# select plot type
selectInput("plotType","Plot Type",choices=plot.type.choices),
#in case Feature User-Defined Set Plot was chosen select the genes
conditionalPanel(condition="input.plotType=='Feature User-Defined Set Plot'",
selectizeInput(inputId="set.symbols",label="Features Set Symbols",choices=unique(model.df$symbol),selected=model.df$symbol[1],multiple=T)),
#in case Feature Sets GSEA Plot was chosen select the databses
conditionalPanel(condition="input.plotType=='Feature Sets GSEA Plot'",
selectizeInput(inputId="set.name",label="Set Name",choices=unique(gene.sets.df$set.name),selected=gene.sets.df$set.name[1],multiple=F)),
#in case Feature Plot was chosen select the gene
conditionalPanel(condition="input.plotType=='Feature Plot'",
selectizeInput(inputId="symbol",label="Feature Symbol",choices=unique(model.df$symbol),selected=unique(model.df$symbol)[1],multiple=F)),
downloadButton('save', 'Save to File')
),
mainPanel(
plotOutput("output.plot")
)
)
)
shinyApp(ui = ui, server = server)
I'm suspecting that the renderPlot here may be the issue since I probably have to use plotly::renderPlotly for the Feature Sets GSEA Plot option but I'm not really sure how to tie it all up in the shiny server part.
Another complication that exists and it would be nice to have a solution for is the fact that the gene symbols are not unique WRT gene IDs (as shown in model.df). So it would be nice to have a list that's added if the user selected the Feature Plot option, and that list will show the subset of gene IDs which the selected symbol maps to (dplyr::filter(model.df == input$symbol)$id)
Thanks!
I also guess the problem is "renderPlot".
One, not so very elegant way that should solve this problem would be to instead of one output, split it in two, but only ever display one of both using "req()".
This piece of code would become:
output$out.plot <- renderPlot({
....
})
This:
output$out.plot1 <- renderPlot({
req(input$plotType != "Feature Sets GSEA Plot")
grid::grid.draw(out.plot())
})
output$out.plot2 <- renderPlotly({
req(input$plotType == "Feature Sets GSEA Plot")
out.plot()
})
You can now just add the the plots below each other in you UI.
"req()" makes sure absolultely nothing is plotted when the statement inside it is not "truthy" (see ?req), in this case "TRUE". The user would not see a difference between this and replacing one output like you tried.
Here's my solution from start to end:
Packages to load:
suppressPackageStartupMessages(library(dplyr))
suppressPackageStartupMessages(library(ggplot2))
suppressPackageStartupMessages(library(plotly))
suppressPackageStartupMessages(library(shiny))
Generate example data:
set.seed(1)
model.df <- data.frame(id = paste0("g",1:30),symbol = sample(LETTERS[1:5],30,replace=T),
group.effect.size = rnorm(30), group.p.value = runif(30,0,1),
sex.effect.size = rnorm(30), sex.p.value = runif(30,0,1),
stringsAsFactors = F)
set.seed(1)
design.df <- data.frame(group = c(rep("A",6),rep("B",6)), sex = rep(c(rep("F",3),rep("M",3)),2), replicate = rep(1:6,2)) %>%
dplyr::mutate(sample = paste0(group,".",sex,"_",replicate))
design.df$group <- factor(design.df$group, levels = c("A","B"))
design.df$sex <- factor(design.df$sex, levels = c("F","M"))
set.seed(1)
abundance.mat <- matrix(rnorm(30*12), nrow=30, ncol=12, dimnames=list(model.df$id,design.df$sample))
set.seed(1)
gsea.df <- data.frame(set.name = paste0("S",1:4), group.p.value = format(round(runif(4,0,1),2),scientific = T), sex.p.value = format(round(runif(4,0,1),2),scientific = T), stringsAsFactors = F)
set.seed(1)
gene.sets.df <- do.call(rbind,lapply(1:4,function(s) data.frame(set.name = paste0("S",s), id = sample(model.df$id,10,replace = F),stringsAsFactors = F)))
plot.type.choices <- c("Feature Plot","User-Defined Feature Set Plot","Feature Sets GSEA Plot")
Plotting functions:
featurePlot <- function(selected.id)
{
replicate.df <- reshape2::melt(abundance.mat[which(rownames(abundance.mat) == selected.id),,drop=F], varnames=c("id","sample")) %>%
dplyr::left_join(design.df)
effects.df <- data.frame(factor.name = c("group","sex"),
effect.size = c(dplyr::filter(model.df,id == selected.id)$group.effect.size,dplyr::filter(model.df,id == selected.id)$sex.effect.size),
p.value = c(dplyr::filter(model.df,id == selected.id)$group.p.value,dplyr::filter(model.df,id == selected.id)$sex.p.value),
stringsAsFactors = F)
effects.df$factor.name <- factor(effects.df$factor.name, levels = c("group","sex"))
main.plot <- ggplot(replicate.df,aes(x=replicate,y=value,color=group,shape=sex))+
geom_point(size=3)+facet_grid(~group,scales="free_x")+
labs(x="Replicate",y="TPM")+theme_minimal()
xlims <- c(-1*max(abs(effects.df$effect.size))-0.1*max(abs(effects.df$effect.size)),max(abs(effects.df$effect.size))+0.1*max(abs(effects.df$effect.size)))
effects.plot <- ggplot(effects.df,aes(x=effect.size,y=factor.name,color=factor.name))+
geom_point()+
geom_vline(xintercept=0,linetype="longdash",colour="black",size=0.25)+theme_minimal()+xlim(xlims)+
theme(legend.position="none")+ylab("")+xlab("Effect Size")
null.plot <- ggplot(data.frame())+geom_point()+geom_blank()+theme_minimal()
combined.plot <- gridExtra::arrangeGrob(main.plot,gridExtra::arrangeGrob(null.plot,effects.plot,ncol=1),nrow=1,ncol=2,widths=c(5,2.5))
return(combined.plot)
}
featureSetPlot <- function(selected.ids)
{
replicate.df <- reshape2::melt(abundance.mat[which(rownames(abundance.mat) %in% selected.ids),,drop=F], varnames=c("id","sample")) %>%
dplyr::left_join(design.df)
replicate.df$replicate <- as.factor(replicate.df$replicate)
effects.df <- data.frame(factor.name = c("group","sex"),
effect.size = c(dplyr::filter(model.df,id %in% selected.ids)$group.effect.size,dplyr::filter(model.df,id %in% selected.ids)$sex.effect.size),
p.value = c(dplyr::filter(model.df,id %in% selected.ids)$group.p.value,dplyr::filter(model.df,id %in% selected.ids)$sex.p.value),
stringsAsFactors = F)
effects.df$factor.name <- factor(effects.df$factor.name, levels = c("group","sex"))
main.plot <- ggplot(replicate.df,aes(x=replicate,y=value,color=group,fill=sex))+
geom_violin(trim=F,draw_quantiles=c(0.25,0.5,0.75),alpha=0.25)+facet_grid(~group,scales="free_x")+
labs(x="Replicate",y="TPM")+theme_minimal()
effects.plot <- ggplot(effects.df,aes(y=effect.size,x=factor.name,color=factor.name,fill=factor.name))+
geom_violin(trim=F,draw_quantiles=c(0.25,0.5,0.75),alpha=0.25)+coord_flip()+
geom_hline(yintercept=0,linetype="longdash",colour="black",size=0.25)+theme_minimal()+
theme(legend.position="none")+xlab("")+ylab("Effect Size Distribution")
null.plot <- ggplot(data.frame())+geom_point()+geom_blank()+theme_minimal()
combined.plot <- gridExtra::arrangeGrob(main.plot,gridExtra::arrangeGrob(null.plot,effects.plot,ncol=1),nrow=1,ncol=2,widths=c(5,2.5))
return(combined.plot)
}
gseaPlot <- function(selected.set)
{
plot.df <- model.df %>%
dplyr::left_join(gene.sets.df %>% dplyr::filter(set.name == selected.set))
plot.df$set.name[which(is.na(plot.df$set.name))] <- "non.selected"
plot.df$set.name <- factor(plot.df$set.name, levels = c("non.selected",selected.set))
factor.names <- c("group","sex")
gsea.plot <- lapply(factor.names,function(f)
plotly::plot_ly(type='scatter',mode="markers",marker=list(size=5),color=plot.df$set.name,colors=c("lightgray","darkred"),x=plot.df[,paste0(f,".effect.size")],y=-log10(plot.df[,paste0(f,".p.value")]),showlegend=F) %>%
plotly::layout(annotations=list(showarrow=F,x=0.5,y=0.95,align="center",xref="paper",xanchor="center",yref="paper",yanchor="bottom",font=list(size=12,color="darkred"),text=paste0(f," (",dplyr::filter(gsea.df,set.name == selected.set)[,paste0(f,".p.value")],")")),
xaxis=list(title=paste0(f," Effect"),zeroline=F),yaxis=list(title="-log10(p-value)",zeroline=F))
) %>% plotly::subplot(nrows=1,shareX=F,shareY=T,titleX=T,titleY=T) %>%
plotly::layout(title=selected.set)
return(gsea.plot)
}
Server:
server <- function(input, output)
{
out.plot <- reactive({
if(input$plotType == "Feature Plot"){
out.plot <- featurePlot(selected.id=dplyr::filter(model.df,symbol == input$symbol)$id[1])
} else if(input$plotType == "User-Defined Feature Set Plot"){
out.plot <- featureSetPlot(selected.ids=unique(dplyr::filter(model.df,symbol == input$set.symbols)$id))
} else if(input$plotType == "Feature Sets GSEA Plot"){
out.plot <- gseaPlot(selected.set=input$set.name)
}
})
output$feature.plot <- renderPlot({
req(input$plotType == "Feature Plot")
grid::grid.draw(out.plot())
})
output$user.defined.feature.set.plot <- renderPlot({
req(input$plotType == "User-Defined Feature Set Plot")
grid::grid.draw(out.plot())
})
output$feature.set.gsea.plot <- renderPlotly({
req(input$plotType == "Feature Sets GSEA Plot")
out.plot()
})
output$save <- downloadHandler(
filename = function() {
paste0("./plot.pdf")
},
content = function(file) {
if(input$plotType != "Feature Sets GSEA Plot"){
ggsave(out.plot(),filename=file,width=10,height=5)
} else{
plotly::export(out.plot(),file=file)
}
}
)
}
UI:
ui <- fluidPage(
tags$style(type="text/css",".shiny-output-error { visibility: hidden; }",".shiny-output-error:before { visibility: hidden; }"),
titlePanel("Results Explorer"),
sidebarLayout(
sidebarPanel(
# select plot type
selectInput("plotType","Plot Type",choices=plot.type.choices),
#in case User-Defined Feature Set Plot was chosen select the genes
conditionalPanel(condition="input.plotType == 'User-Defined Feature Set Plot'",
selectizeInput(inputId="set.symbols",label="Features Set Symbols",choices=unique(model.df$symbol),selected=model.df$symbol[1],multiple=T)),
#in case Feature Sets GSEA Plot was chosen select the databses
conditionalPanel(condition="input.plotType == 'Feature Sets GSEA Plot'",
selectizeInput(inputId="set.name",label="Set Name",choices=unique(gene.sets.df$set.name),selected=gene.sets.df$set.name[1],multiple=F)),
#in case Feature Plot was chosen select the gene
conditionalPanel(condition="input.plotType == 'Feature Plot'",
selectizeInput(inputId="symbol",label="Feature Symbol",choices=unique(model.df$symbol),selected=unique(model.df$symbol)[1],multiple=F)),
downloadButton('save', 'Save to File')
),
mainPanel(
conditionalPanel(
condition = "input.plotType == 'User-Defined Feature Set Plot'",
plotOutput("user.defined.feature.set.plot")
),
conditionalPanel(
condition = "input.plotType == 'Feature Sets GSEA Plot'",
plotly::plotlyOutput("feature.set.gsea.plot")
),
conditionalPanel(
condition = "input.plotType == 'Feature Plot'",
plotOutput("feature.plot")
)
)
)
)
Call:
shinyApp(ui = ui, server = server)

Nesting two observeEvents duplicates the reactive event

This question is related to another one I somewhat solved a few days ago.
My intention:
To upload a csv with several columns.
Plot each column in a line and points plot.
Allow the user to select two different points from the plot, called first/last. The program always get the last two points clicked, order them to find first/last (first<=last).
Since the columns may differ from one dataset to another I have to create dynamically the structure of the app, and the problem is that I nest a observeEvent for the click in each plot inside a observeEvent (when the user changes the input dataset). The problem is that the observeEvent for the click depends on the dataset loaded (different columns).
What I do in the app is to create a pool with all the clicks in all the plots and extract the lastest two ones from each plot when needed, and I use this information to modify the plot with colors green and red.
To create two sample datasets:
inputdata<-data.frame(weekno=1:20, weekna=letters[1:20])
inputdata$normal<-dnorm(inputdata$weekno,10)
inputdata$beta<-dbeta(inputdata$weekno, 1, 1)
inputdata$gamma<-dgamma(inputdata$weekno, 1, 1)
inputdata$logistic<-dlogis(inputdata$weekno,10)
inputdata$poisson<-dpois(inputdata$weekno, 2)
test1<-inputdata[c("normal","gamma")]
row.names(test1)<-inputdata$weekna
test2<-inputdata[c("normal","logistic")]
row.names(test2)<-inputdata$weekna
write.csv(test1, file="test1.csv")
write.csv(test2, file="test2.csv")
The app:
library(ggplot2)
library(shiny)
library(shinydashboard)
tail.order<-function(i.data, i.n, i.order){
res<-tail(i.data, n=i.n)
res<-res[order(res[i.order]),]
res$id.tail<-1:NROW(res)
res
}
extract.two<-function(i.data, i.order, i.column){
#data<-unique(i.data, fromLast=T)
data<-i.data
results <- do.call("rbind", by(data, data[i.column], tail.order, i.n=2, i.order=i.order))
return(results)
}
ui <- fluidPage(
fluidRow(
column(4,fileInput('file', "Load file")),
column(8,uiOutput("maintab"))
)
)
server <- function(input, output) {
values <- reactiveValues(origdata = NULL, plotdata = NULL, clickdata=NULL, dummy = TRUE)
read_data <- reactive({
infile <- input$file
inpath <- infile$datapath
inname <- infile$name
if(is.null(infile)) readdata<-NULL else readdata<-read.csv(inpath, row.names=1)
readdata
})
observeEvent(input$file, {
datfile <- read_data()
seasons<-names(datfile)
plotdata<-cbind(data.frame(weekno=1:NROW(datfile),weekna=rownames(datfile), stringsAsFactors = F), datfile)
origdata<-plotdata
for (s in seasons) eval(parse(text=paste0("plotdata$'",as.character(s),"_color'<-'1'")))
values$origdata <- origdata
values$plotdata <- plotdata
values$clickdata <- data.frame()
rm("origdata", "plotdata")
lapply(seasons, function(s){output[[paste0("plot_",as.character(s))]] <- renderPlot({
ggplot(values$plotdata, aes_(x=as.name("weekno"), y=as.name(s))) +
geom_point(aes_(as.name("weekno"), as.name(s), colour=as.name(paste0(s,"_color")), size=as.name(paste0(s,"_color")))) +
scale_color_manual(values = c("1" = "grey", "2" = "red", "3" = "green")) +
scale_size_manual(values = c("1" = 4, "2" = 6, "3" = 6)) +
geom_line(aes_(x=as.name("weekno"), y=as.name(s)), color="#000000") +
ggthemes::theme_few() +
guides(color=FALSE, size=FALSE)
})})
lapply(seasons,function(s){
observeEvent(input[[paste0("plot_",as.character(s),"_click")]], {
np <- nearPoints(values$origdata, input[[paste0("plot_",as.character(s),"_click")]], maxpoints=1 , threshold = 10000)
values$clickdata<-rbind(values$clickdata,cbind(data.frame(variable=as.character(s), stringsAsFactors = F), np))
if (NROW(values$clickdata)>0){
p0<-extract.two(values$clickdata,"weekno","variable")
p1<-subset(p0, variable==as.character(s) & id.tail==1)
p2<-subset(p0, variable==as.character(s) & id.tail==2)
if (NROW(p1)>0) {
values$plotdata[values$plotdata[,paste0(as.character(s),"_color")]=="2", paste0(as.character(s),"_color")]<-"1"
values$plotdata[values$origdata$weekno==p1$weekno,paste0(as.character(s),"_color")]<-"2"
}
if (NROW(p2)>0){
values$plotdata[values$plotdata[,paste0(as.character(s),"_color")]=="3",paste0(as.character(s),"_color")]<-"1"
values$plotdata[values$origdata$weekno==p2$weekno,paste0(as.character(s),"_color")]<-"3"
}
}
})
})
})
output$maintab <- renderUI({
datfile <- read_data()
seasons<-names(datfile)
do.call(tabsetPanel,
c(
lapply(seasons,function(s){
call("tabPanel",s,call("plotOutput", outputId=paste0("plot_",as.character(s)),
click = paste0("plot_",as.character(s),"_click")))
}),
list(
tabPanel("First & last",tableOutput("results")),
tabPanel("Clicks",tableOutput("resultsfull"))
)
)
)
})
output$results<-renderTable({
if (NROW(values$clickdata)>0) extract.two(values$clickdata,"weekno","variable")
})
output$resultsfull<-renderTable({
values$clickdata
})
}
shinyApp(ui, server)
To reproduce the bug:
Open test1.csv, a observeEvent for each column is created ("_click").
Open test2.csv, a observeEvent for each column is created ("_click").
Since test1.csv and test2.csv first column is called "normal" then the observeEvent$normal_click is created two times, so when I click the plot it writes two times the point clicked to the "clicks pool" (because there are two observeEvent related to that "normal_click".
When I extract the lastest two points from the "clicks pool", it retrieves the same point two times (the point I clicked and was stored two times because there was two observeEvents_click to the same plot).
I know to to circumvent the problem by uncommenting:
#data<-unique(i.data, fromLast=T)
This way it removes duplicates, but also denies the chance of telling the app to use the same point for first and last (first can be equal to last). And also this solution is not elegant since the structural problem is still there.
Any hints on how to fix this?
I found another post talking about another problem that did lead me to the solution.
I have created a list of observeEvent that have been created not to allow duplicate the same observeEvent (called idscreated).
library(ggplot2)
library(shiny)
library(shinydashboard)
tail.order<-function(i.data, i.n, i.order){
res<-tail(i.data, n=i.n)
res<-res[order(res[i.order]),]
res$id.tail<-1:NROW(res)
res
}
extract.two<-function(i.data, i.order, i.column){
data<-i.data
results <- do.call("rbind", by(data, data[i.column], tail.order, i.n=2, i.order=i.order))
return(results)
}
ui <- fluidPage(
fluidRow(
column(4,fileInput('file', "Load file")),
column(8,uiOutput("maintab"))
)
)
server <- function(input, output) {
values <- reactiveValues(origdata = NULL, plotdata = NULL, clickdata=NULL, idscreated = character())
read_data <- reactive({
infile <- input$file
inpath <- infile$datapath
inname <- infile$name
if(is.null(infile)) readdata<-NULL else readdata<-read.csv(inpath, row.names=1)
readdata
})
observeEvent(read_data(), {
datfile <- read_data()
seasons<-names(datfile)
plotdata<-cbind(data.frame(weekno=1:NROW(datfile),weekna=rownames(datfile), stringsAsFactors = F), datfile)
origdata<-plotdata
for (s in seasons) eval(parse(text=paste0("plotdata$'",as.character(s),"_color'<-'1'")))
values$origdata <- origdata
values$plotdata <- plotdata
values$clickdata <- data.frame()
rm("origdata", "plotdata")
lapply(seasons, function(s){output[[paste0("plot_",as.character(s))]] <- renderPlot({
ggplot(values$plotdata, aes_(x=as.name("weekno"), y=as.name(s))) +
geom_point(aes_(as.name("weekno"), as.name(s), colour=as.name(paste0(s,"_color")), size=as.name(paste0(s,"_color")))) +
scale_color_manual(values = c("1" = "grey", "2" = "red", "3" = "green", "4" = "purple")) +
scale_size_manual(values = c("1" = 4, "2" = 6, "3" = 6, "4" = 8)) +
geom_line(aes_(x=as.name("weekno"), y=as.name(s)), color="#000000") +
ggthemes::theme_few() +
guides(color=FALSE, size=FALSE)
})})
lapply(seasons,function(s){
nameid<-paste0("plot_",as.character(s),"_click")
if (!(nameid %in% values$idscreated)){
values$idscreated<-c(values$idscreated,nameid)
observeEvent(input[[nameid]], {
np <- nearPoints(values$origdata, input[[nameid]], maxpoints=1 , threshold = 10000)
values$clickdata<-rbind(values$clickdata,cbind(data.frame(variable=as.character(s), stringsAsFactors = F), np))
if (NROW(values$clickdata)>0){
p0<-extract.two(values$clickdata,"weekno","variable")
p1<-subset(p0, variable==as.character(s) & id.tail==1)
p2<-subset(p0, variable==as.character(s) & id.tail==2)
if (NROW(p1)>0) {
values$plotdata[values$plotdata[,paste0(as.character(s),"_color")]!="3", paste0(as.character(s),"_color")]<-"1"
values$plotdata[values$origdata$weekno==p1$weekno,paste0(as.character(s),"_color")]<-"2"
}
if (NROW(p2)>0){
values$plotdata[values$plotdata[,paste0(as.character(s),"_color")]!="2", paste0(as.character(s),"_color")]<-"1"
values$plotdata[values$origdata$weekno==p2$weekno,paste0(as.character(s),"_color")]<-"3"
}
if (NROW(p1)>0 & NROW(p2)>0){
if (p1$weekno==p2$weekno){
values$plotdata[, paste0(as.character(s),"_color")]<-"1"
values$plotdata[values$origdata$weekno==p1$weekno,paste0(as.character(s),"_color")]<-"4"
}
}
}
})
}
})
})
output$maintab <- renderUI({
datfile <- read_data()
seasons<-names(datfile)
do.call(tabsetPanel,
c(
lapply(seasons,function(s){
call("tabPanel",s,call("plotOutput", outputId=paste0("plot_",as.character(s)),
click = paste0("plot_",as.character(s),"_click")))
}),
list(
tabPanel("First & last",tableOutput("results")),
tabPanel("Clicks",tableOutput("resultsfull"))
)
)
)
})
output$results<-renderTable({
if (NROW(values$clickdata)>0) extract.two(values$clickdata,"weekno","variable")
})
output$resultsfull<-renderTable({
values$clickdata
})
}
shinyApp(ui, server)

Shiny - Web Framework for R › how to use an input switch to conditionally group

asked this on the shiny google group, w no help yet: I'm struggling with how to pass an input switch to dplyr's group_by_ in the code below.
I bolded the two parts of relevant code in the not-so-MRE below (ie, lines 9:11, and 24).
effectively, if the user selects "daily" in the UI, the resultant grouping should be group_by(year = year(my_date), month = month(my_date), day = day(my_date) in line 24, or remove ANY grouping as the data is already daily.
selecting "monthly", should yield group_by(year = year(my_date), month = month(my_date))
"yearly", should yield group_by(year = year(my_date))
I welcome meta-suggestions/ criticism about how my code/ structures are organized.
Thank you
library(shiny)
library(dplyr)
library(lubridate)
ui <- fluidPage(
dateInput("start", label = "start date", value = "2010-01-01"),
dateInput("end", label = "end date", value = "2020-01-01"),
selectInput("grouping_freq", label = "Granularity",
choices = list("daily" = 1,"monthly" = 2, "Yearly" = 3),
selected = 2),
tableOutput("my_table")
)
server <- function(input, output) {
df <- reactive({ data_frame(my_date = seq(input$start, input$end, by = 'day')) }) ## 10 years of daily data
df2 <- reactive({ df() %>% mutate(dummy_data = cumsum(rnorm( nrow( df() ) ))) })
output$my_table <- renderTable({
df2() %>% group_by(year = year(my_date), month = month(my_date)) %>%
summarise(dummy_data = sum(dummy_data), my_date = as.Date(min(my_date)))
})
}
shinyApp(ui = ui, server = server)
You can use the value chosen in selectInput to create a list of formulas that are passed into group_by_, the version of dplyr::group_by that uses standard evaluation.
group_list <- switch(input$grouping_freq,
list(yr=~year(my_date), mn=~month(my_date), dy=~day(my_date)),
list(yr=~year(my_date), mn=~month(my_date))
list(yr=~year(my_date)))
or if you prefer if statements,
group_list <- if (input$grouping_freq == 1) {
list(yr=~year(my_date), mn=~month(my_date), dy=~day(my_date))
} else if (input$grouping_freq == 2) {
list(yr=~year(my_date), mn=~month(my_date))
} else if (input$grouping_freq == 3) {
list(yr=~year(my_date))
} else {
list()
}
and then you can pass group_list into the renderTable expression
output$my_table <- renderTable({
df2() %>%
group_by_(.dots=group_list) %>%
summarise(dummy_data = sum(dummy_data), my_date = as.Date(min(my_date)))
})
I am not sure what you meant by "remove ANY grouping as the data is already daily." but if the data might already be grouped you can use the ungroup function to remove any groups before applying the groupings in group_list.
Edit: Forgot to include ~ in the list elements so that they evaluate correctly.

Resources