Shiny: Dynamic colour (fill) input for ggplot - r

i do need some help as the post: Dynamic color input in shiny server does not give full answer to my problem.
I would like to have dynamic colour (fill) selection in my shiny app. I have prepared a sample code:
library(shiny)
library(shinyjs)
library(reshape2)
library(ggplot2)
dat <- data.frame(matrix(rnorm(60, 2, 3), ncol=3))
dat <- melt(dat)
runApp(shinyApp(
ui = fluidPage(
selectizeInput("select","Select:", choices=as.list(levels(dat$variable)), selected="X1",multiple =TRUE),
uiOutput('myPanel'),
plotOutput("plot"),
downloadButton('downloadplot',label='Download Plot')
),
server = function(input, output, session) {
cols <- reactive({
lapply(seq_along(unique(input$select)), function(i) {
colourInput(paste("col", i, sep="_"), "Choose colour:", "black")
})
})
output$myPanel <- renderUI({cols()})
cols2 <- reactive({
if (is.null(input$col_1)) {
cols <- rep("#000000", length(input$select))
} else {
cols <- unlist(colors())
}
cols})
testplot <- function(){
dat <- dat[dat$variable %in% input$select, ]
ggplot(dat, aes(x=variable,y=value, fill=cols2()[1])) + geom_boxplot()}
output$plot <- renderPlot({testplot()})
output$downloadplot <- downloadHandler(
filename ="plot.pdf",
content = function(file) {
pdf(file, width=12, height=6.3)
print(testplot())
dev.off()
})
}
))
I would like the user to choose fill colour of the boxplot. The number of colour widgets will appear according to number of selected variables in selectizeInput("select".... Till this point everything is working perfectly, however going further i am not able to figure out how to apply this colour to the ggplot, etc...
Here are my questions:
How i can connect the fill colour to ggplot correctly
Can i make the default colour of colourInput() correspond to the default colour palette (not to one colour --> in my case is black)
Instead of Choose colour text in colourInput(paste("col", i, sep="_"), "Choose colour:", i would love to have the corresponding name (choosen variable from selectizeInput) of the variable (in this case X1, X2 and X3)
I would like as well to have a button which could reset all the choosen colours
Thank You all in advance and i hope this can be solved
Cheers

These are very nice and concrete questions and I'm glad to, hopefully, answer them :)
How i can connect the fill colour to ggplot correctly
In this case the best way, I think, is to fill boxes according to the variable (which is reactive) and to add a new layer scale_fill_manual in which you specify custom colours for different boxes. The number of colours has to be obviously equal to the number of levels of variable. This is probably the best way because you will always have a correct legend.
ggplot(dat, aes(x = variable, y = value, fill = variable)) +
geom_boxplot() +
scale_fill_manual(values = cols)
Can i make the default colour of colourInput() correspond to the default colour palette (not to one colour --> in my case is black)
Of course, you can do it.
First, you need to know the default colours for discrete variables that ggplot uses. To generate these colours we will use a function gg_color_hue found in this nice discussion. I've changed its name to gg_fill_hue to follow a ggplot convention.
We can code everything within renderUI where we first specify the selected levels/variables. To get rid of unambiguity which would be caused due to dynamically (and possibly in a different order) generated widgets, we sort the names of levels/variables.
Then we generate appropriate number of default colours with gg_fil_hue and assign them to the appropriate widget.
To make things easier, we change the IDs of these widgets to col + "varname" which is given by input$select
output$myPanel <- renderUI({
lev <- sort(unique(input$select)) # sorting so that "things" are unambigious
cols <- gg_fill_hue(length(lev))
# New IDs "colX1" so that it partly coincide with input$select...
lapply(seq_along(lev), function(i) {
colourInput(inputId = paste0("col", lev[i]),
label = paste0("Choose colour for ", lev[i]),
value = cols[i]
)
})
})
3.Instead of Choose colour text in colourInput(paste("col", i, sep="_"), "Choose colour:", i would love to have the corresponding name (choosen variable from selectizeInput) of the variable (in this case X1, X2 and X3)
It is done in the code above as well - simple pasting.
Now, let's take a look at a very important issue that arises due to dynamical number of generated widgets. We have to set the colours of boxes according to a unique colorInput and there may by 1,2 or even 10 those inputs.
A very nice way of approaching this problem, I believe, is to create a character vector with elements specifying how we would normally access these widgets. In the example below this vector looks as follows: c("input$X1", "input$X2", ...).
Then using non-standard evaluation (eval, parse) we can evaluate these inputs to get a vector with selected colours which we then pass to scale_fill_manual layer.
To prevent errors that may arise between selections, we will use the function `req´ to make sure that the length of the vector with colours is the same as the length of the selected levels/variables.
output$plot <- renderPlot({
cols <- paste0("c(", paste0("input$col", sort(input$select), collapse = ", "), ")")
# print(cols)
cols <- eval(parse(text = cols))
# print(cols)
# To prevent errors
req(length(cols) == length(input$select))
dat <- dat[dat$variable %in% input$select, ]
ggplot(dat, aes(x = variable, y = value, fill = variable)) +
geom_boxplot() +
scale_fill_manual(values = cols)
})
I would like as well to have a button which could reset all the choosen colours
After defining the actionButton on the client side with an ID="reset" we create an observer that's going to update colorInputs.
Our goal is to return a list with updateColourInput with an appropriate parametrisation for each available colourInput widget.
We define a variable with all chosen levels/variables and generate an appropriate number of default colours. We again sort the vector to avoid ambiguity.
Then we use lapply and do.call to call a updateColourInput function with specified parameters that are given as a list.
observeEvent(input$reset, {
# Problem: dynamic number of widgets
# - lapply, do.call
lev <- sort(unique(input$select))
cols <- gg_fill_hue(length(lev))
lapply(seq_along(lev), function(i) {
do.call(what = "updateColourInput",
args = list(
session = session,
inputId = paste0("col", lev[i]),
value = cols[i]
)
)
})
})
Full Example:
library(shiny)
library(shinyjs)
library(reshape2)
library(ggplot2)
dat <- data.frame(matrix(rnorm(60, 2, 3), ncol=3))
dat <- melt(dat)
# Function that produces default gg-colours is taken from this discussion:
# https://stackoverflow.com/questions/8197559/emulate-ggplot2-default-color-palette
gg_fill_hue <- function(n) {
hues = seq(15, 375, length = n + 1)
hcl(h = hues, l = 65, c = 100)[1:n]
}
runApp(shinyApp(
ui = fluidPage(
selectizeInput("select", "Select:",
choices = as.list(levels(dat$variable)),
selected = "X1",
multiple = TRUE),
uiOutput('myPanel'),
plotOutput("plot"),
downloadButton('downloadplot', label = 'Download Plot'),
actionButton("reset", "Default colours", icon = icon("undo"))
),
server = function(input, output, session) {
output$myPanel <- renderUI({
lev <- sort(unique(input$select)) # sorting so that "things" are unambigious
cols <- gg_fill_hue(length(lev))
# New IDs "colX1" so that it partly coincide with input$select...
lapply(seq_along(lev), function(i) {
colourInput(inputId = paste0("col", lev[i]),
label = paste0("Choose colour for ", lev[i]),
value = cols[i]
)
})
})
output$plot <- renderPlot({
cols <- paste0("c(", paste0("input$col", sort(input$select), collapse = ", "), ")")
# print(cols)
cols <- eval(parse(text = cols))
# print(cols)
# To prevent errors
req(length(cols) == length(input$select))
dat <- dat[dat$variable %in% input$select, ]
ggplot(dat, aes(x = variable, y = value, fill = variable)) +
geom_boxplot() +
scale_fill_manual(values = cols)
})
observeEvent(input$reset, {
# Problem: dynamic number of widgets
# - lapply, do.call
lev <- sort(unique(input$select))
cols <- gg_fill_hue(length(lev))
lapply(seq_along(lev), function(i) {
do.call(what = "updateColourInput",
args = list(
session = session,
inputId = paste0("col", lev[i]),
value = cols[i]
)
)
})
})
output$downloadplot <- downloadHandler(
filename = "plot.pdf",
content = function(file) {
pdf(file, width = 12, height = 6.3)
print(testplot())
dev.off()
})
}
))

Related

How can I summarize reactive data from outside a render function in a Shiny app?

For this particular shiny example I am trying to apply a circular model and display and summarize it within the ggplot and a summary table. This is straightforward up until trying to add in reactive 'brushplot' capabilities. Each of the data points represent a date and the point of the selective graph is to be able to discard undesirable dates. As far as I've figured out, this requires the filtering and model fitting to be within a renderPlot which then leads to complications (unable to find the data/model) trying to call the filtered data and the circular model's statistical outputs outside the function and/or within another reactive function. This yields the Error: object 'k_circ.lm' not found So my questions are:
How can I read the filtered data from the renderPlot function
to the summarytable matrix?
How could I similarly add the fitted model values and residuals from k_circ.lm?
Is there a better or simpler way to arrange app to avoid this?
Alternatative code lines are commented out for a working (if poorly formatted) summary table.
library(dplyr) # For data manipulation
library(ggplot2) # For drawing plots
library(shiny) # For running the app
library(plotly) # For data manipulation
library(circular) # For Circular regressions
library(gridExtra)
# Define UI ----
ui <- fluidPage(
# App title ----
titlePanel("Circular Brushplot Demo"),
# Sidebar layout with input and output definitions ----
sidebarLayout(
sidebarPanel(
actionButton("exclude_toggle", "Toggle points"),
actionButton("exclude_reset", "Reset")
),
# Main panel for displaying outputs ----
mainPanel(
#reactive plot output with point and 'brush' selection
fluidRow(plotOutput("k", height = 400,
click = "k_click",
brush = brushOpts(
id = "k_brush" ))),
plotOutput("s", height = 400)
)
)
)
# Define server logic
server <- function(input, output) {
psideg <- c(356,97,211,232,343,292,157,302,335,302,324,85,324,340,157,238,254,146,232,122,329)
thetadeg <- c(119,162,221,259,270,29,97,292,40,313,94,45,47,108,221,270,119,248,270,45,23)
## Data in radians then to "circular format"
psirad <- psideg*2*pi/360
thetarad <- thetadeg*2*pi/360
cpsirad <- circular(psirad)
cthetarad <- circular(thetarad)
cdat <- data.frame(cpsirad, cthetarad)
###### reactive brush plot ########
# For storing which rows have been excluded
vals <- reactiveValues(
keeprows = rep(TRUE, nrow(cdat)))
output$k <- renderPlot({
# Plot the kept and excluded points as two separate data sets
keep <- cdat[ vals$keeprows, , drop = FALSE]
exclude <- cdat[!vals$keeprows, , drop = FALSE]
## Fits circular model specifically for 'keeprows' of selected data
k_circlm <- lm.circular(type = "c-c", y = keep$cthetarad, x = keep$cpsirad, order = 1)
k_circlm
ggplot(keep, aes(cthetarad, cpsirad)) +
geom_point(aes(cthetarad, cpsirad, colour = keep$Vmag, size = 5))+
scale_colour_gradient(low ="blue", high = "red")+
geom_smooth(method = lm, fullrange = TRUE, color = "black") +
geom_point(data = exclude, shape = 13, size = 5, fill = NA, color = "black", alpha = 0.25) +
annotate("text", x = min(keep$cthetarad), y = Inf, hjust = .1, vjust = 1,
label = paste0("p value 1 = ", round(k_circlm$p.values[1], 2)), size = 7)+
annotate("text", x = min(keep$cthetarad), y = Inf, hjust = .1, vjust = 2.5,
label = paste0("p value 2 = ", round(k_circlm$p.values[2], 2)), size = 7)+
annotate("text", x = min(keep$cthetarad), y = Inf, hjust = .1, vjust = 4,
label = paste0("rho = ", round(k_circlm$rho, 2)), size = 7)+
xlab("Lighthouse Direction (radians)")+ ylab("ADCP site direction (radians)")+
theme(axis.title.x = element_text(size = 20), axis.title.y = element_text(size = 20))
})
# Toggle points that are clicked
observeEvent(input$k_click, {
res <- nearPoints(cdat, input$k_click, allRows = TRUE)
vals$keeprows <- xor(vals$keeprows, res$selected_)})
# Toggle points that are brushed, when button is clicked
observeEvent(input$exclude_toggle, {
res <- brushedPoints(cdat, input$k_brush, allRows = TRUE)
vals$keeprows <- xor(vals$keeprows, res$selected_)})
# Reset all points
observeEvent(input$exclude_reset, {
vals$keeprows <- rep(TRUE, nrow(cdat))})
output$s <- renderPlot({
# Create Summary table
summarytable <- data.frame(matrix(ncol = 4, nrow = nrow(keep)))
colnames(summarytable) <- c( "Psi_dir", "Theta_dir", "Fitted_values", "Residuals")
# Un-comment lines below to read from non-reactive data for working summary table
#summarytable$Psi_dir <- round(cdat$cpsirad, 2)
#summarytable$Theta_dir <- round(cdat$cthetarad, 2)
# attempting to pull from circlm within render plot
# comment out for summarytable to work
summarytable$Psi_dir <- round(keep$cpsirad, 2)
summarytable$Theta_dir <- round(keep$cthetarad, 2)
summarytable$Fitted_values <- round(k_circ.lm$fitted)
summarytable$Residuals <- round(k_circ.lm$residuals)
# outputing table with minimal formatting
summarytable <-na.omit(summarytable)
t <- tableGrob(summarytable)
Q <- grid.arrange(t, nrow = 1)
Q
}
)
}
shinyApp(ui = ui, server = server)
Here's a few ideas - but there are multiple approaches to handling this, and you probably want to restructure your server function a bit more after working with this further.
First, you probably want a reactive expression that will update your model based on vals$keeprows as this changes with your clicks. Then, you can access the model results from this expression from both your plot and data table.
Here is an example:
fit_model <- reactive({
## Keep and exclude based on reactive value keeprows
keep = cdat[ vals$keeprows, , drop = FALSE]
exclude = cdat[!vals$keeprows, , drop = FALSE]
## Fits circular model specifically for 'keeprows' of selected data
k_circlm <- lm.circular(type = "c-c", y = keep$cthetarad, x = keep$cpsirad, order = 1)
## Returns list of items including what to keep, exclude, and model
list(k_circlm = k_circlm, keep = keep, exclude = exclude)
})
It will return a list that you can access from the plot:
output$k <- renderPlot({
exclude <- fit_model()[["exclude"]]
keep <- fit_model()[["keep"]]
k_circlm <- fit_model()[["k_circlm"]]
ggplot(keep, aes(cthetarad, cpsirad)) +
...
And can access the same from your table (though you have as renderPlot?):
output$s <- renderPlot({
keep = fit_model()[["keep"]]
k_circ.lm <- fit_model()[["k_circlm"]]
# Create Summary table
summarytable <- data.frame(matrix(ncol = 4, nrow = nrow(keep)))
...
Note that because the table length changes with rows kept, you might want to use nrow(keep) as I have above, rather than nrow(cdat), unless I am mistaken.
I also loaded gridExtra library for testing this.
I suspect there are a number of other improvements you could consider, but thought this might help you get to a functional state first.

ggplot won't use levels for x-axis order when a reactive input is empty

I am trying to create a shiny app with multiple sections, the section I am having trouble with right now displays calculated values on a ggplot graph. The user selects one Target gene from a dropdown list, and the graph displays calculated analysis values against a selection of other, Control genes. So far so simple.
I have a few default Control genesets, which I have preselected and that are always displayed, and then I have an option for the user to specify their own Control genes to perform analysis against. There is a checkbox that can be ticked if the user wants to select their own Controls. The user can also select different numbers of custom Controls, whereas the default controls each have sets of 3 Control genes.
Code for the default genesets as so:
ABC_control <- reactive(
Analysis_function(c("ACTB", "GAPDH", "TUBB")))
And code for the custom genesets is as so:
CUSTOM_control1 <- reactive( if (input$custom_checkbox1) {
Analysis_function(input$custom_controls1)
} else { NA } )
I have an if command in the Custom genesets so that they are not calculated and displayed if the tickbox is not checked.
First problem: The plot still displays an x axis label for the Custom control even if none is selected and the checkbox is not ticked. This is not a major problem, just an annoying one.
The second problem:
When displaying just the default genesets everything runs perfectly. And when the user selects their own Control genes, everything runs fine.
The problem is when the user ticks the CheckboxInput(), and the selectizeInput() for the custom control genes is still empty, the graph goes and re-orders its x-axis into alphabetical order, rather than the levels order that I have specified earlier. As soon as a Control gene is selected, it re-orders back into the levels order. The problem only occurs when the selectizeInput box is empty, or a new gene is being selected.
How can I force the plot to always display in the correct levels order, even when the reactive custom input is empty?
Also, preferably, how can I prevent the Custom input from being displayed on the graph at all unless the checkbox is ticked.
A full Shiny app data is below:
#### Load packages ####
library(shiny)
library(ggplot2)
library(dplyr)
#### Load data files ####
load("GeneNames.Rda")
load("Dataset.Rda")
#### Define UI ####
ui <- fluidPage(
#### Sidebar inputs ####
sidebarLayout(
sidebarPanel(width = 3,
#first wellpanel for selecting Target gene
h4("Target gene selection"),
wellPanel(
selectInput(
inputId = "gene_select",
label = NULL,
choices = GeneNames,
selected = "ESAM")),
#Second wellpanel for selecting custom Control genes
h4("Custom control genes"),
wellPanel(
checkboxInput(inputId = "custom_checkbox1",
label = "Custom 1:"),
conditionalPanel(condition = "input.custom_checkbox1 == true",
selectizeInput(inputId = "custom_controls1",
label = NULL,
choices = GeneNames,
multiple = TRUE,
options = list(openOnFocus = FALSE, closeAfterSelect = TRUE, maxOptions = 50, maxItems = 6))))
),
#### Mainpanel results Normal ####
mainPanel(width = 9,
#HTML code to have the last entry in any tables bolded (last entry is Mean in all tables)
#Results title and main bar plot graph
fluidRow(plotOutput(outputId = "celltype_bar_plot"),width = 9)
)))
#### Define server ####
server <- function(input, output) {
target_gene <- reactive({
input$gene_select
})
#### calculations ####
Analysis_function <- function(controls){
cor(Dataset[, target_gene()], Dataset[, controls])
}
ABC_control <- reactive(
Analysis_function(c("ACTB", "GAPDH", "TUBB")))
GHI_control <- reactive(
Analysis_function(c("ACTB", "GAPDH", "TUBB")))
DEF_control <- reactive(
Analysis_function(c("ACTB", "GAPDH", "TUBB")))
CUSTOM_control1 <- reactive( if (input$custom_checkbox1) {
Analysis_function(input$custom_controls1)
} else { NA } )
#### Analysis datatables Normal ####
control_list <- c("ABC_control", "GHI_control", "DEF_control", "CUSTOM_control1")
analysis_list <- reactive({ list(ABC_control(), GHI_control(), DEF_control(), CUSTOM_control1()) })
#generating melted data table of the induvidual analysed gene values, transposed to get in right format, and times = c(length()) to replicate titles the correct no of times
values_list <- reactive({
data.frame(Control_types2 = factor(rep(control_list, times = c(unlist(lapply(analysis_list(), length)))), levels =control_list),
values = c(unlist(lapply(analysis_list(), t))))
})
#Generating data table of the means of analysed values above
Mean_list <- reactive({
data.frame(Control_types = factor(control_list, levels =control_list),
Mean_correlation = c(unlist(lapply(analysis_list(), mean))))
})
#### Main Bar Plot Normal ####
output$celltype_bar_plot <- renderPlot({
ggplot() +
geom_point(data = values_list(),aes(x=Control_types2, y=values,size = 7, color = Control_types2), show.legend = FALSE, position=position_jitter(h=0, w=0.1), alpha = 0.7) +
geom_boxplot(data = Mean_list(), aes(Control_types, Mean_correlation), size = 0.5, colour = "black")
})
}
#### Run application ####
shinyApp(ui = ui, server = server)
I can't fully test this solution since the data you provided isn't available (so I can't run the app), but I suspect that the following should help.
First, by using ordered or factor(..., ordered = TRUE) you can tell the graph what order to put label in.
Second, in order to prevent the column from showing up on the graph you must remove all datapoints for that column INCLUDING NA.
control_list <- c("ABC_control", "GHI_control", "DEF_control", "CUSTOM_control1")
# Some data to try out
values_list <- data.frame(
Control_types2 = ordered(rep(control_list, times = 4), levels =control_list),
values = c(0.25,0.50,0.75,NA)
)
Mean_list <- data.frame(
Control_types = ordered(control_list, levels =control_list),
Mean_correlation = c(0.25,0.50,0.75,NA)
)
# Original plot code
ggplot() +
geom_point(data = values_list,aes(x=Control_types2, y=values,size = 7, color = Control_types2), show.legend = FALSE, position=position_jitter(h=0, w=0.1), alpha = 0.7) +
geom_boxplot(data = Mean_list, aes(Control_types, Mean_correlation), size = 0.5, colour = "black")
# New plot with NA values removed
ggplot() +
geom_point(data = values_list %>% filter(!is.na(values)),
aes(x=Control_types2, y=values,size = 7, color = Control_types2),
show.legend = FALSE,
position=position_jitter(h=0, w=0.1),
alpha = 0.7) +
geom_boxplot(data = Mean_list %>% filter(!is.na(Mean_correlation)),
aes(Control_types, Mean_correlation),
size = 0.5,
colour = "black")

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)

Erasing all selectizeInput() values without Shiny app closing after onRender() has been called

I am trying to create a Shiny app to explore a data frame with 4 variables/columns (A, B, C, D) and 10,000 rows. There is an input field where users must select 2 of the 4 variables/columns. Once they have done so, then a scatterplot is shown on the right. The scatterplot is a Plotly object with hexagon binning summarizing the values of the 10,000 rows between the two user-selected variables/columns.
At this point, the user can select a "Go!" button, which causes an orange dot corresponding to the first row of those 2 variables/columns to be superimposed onto the Plotly object. The user can sequentially select "Go!" and then the orange dot corresponding to the second, third, fourth, etc. row will be superimposed onto the Plotly object. The name of the row ID is output above the scatterplot matrix.
For the most part, the app is working. There are only 2 things I am trying to improve upon:
1) I would like the user to be able to select new pairs in the input field. This works for the most part. However, there is one specific situation where this will cause the app to close suddenly. It happens after an orange point has been overlaid onto the scatterplot. If the user then erases the two input pairs, the app suddenly closes. I would like the user to be able to erase both input pair values and input two new pair values without the app closing even after orange points have been plotted to the scatterplot.
2) I notice that the output of the row ID lags somewhat after the orange dot is plotted. I wonder why this happens since I output the row ID before plotting the orange dot in the script. I would prefer for there to be less of a lag, but am uncertain how to approach that.
Any suggestions on how to solve either of these two issues would be greatly appreciated! My MWE showing this issue is below.
library(plotly)
library(GGally)
library(hexbin)
library(htmlwidgets)
library(tidyr)
library(shiny)
library(dplyr)
library(data.table)
library(ggplot2)
library(tibble)
myPairs <- c("A", "B", "C", "D")
ui <- shinyUI(fluidPage(
titlePanel("title panel"),
sidebarLayout(position = "left",
sidebarPanel(
selectizeInput("selPair", "Pairs:", choices = myPairs, multiple = TRUE, options = list(maxItems = 2)),
actionButton("goButton", "Go!"),
width = 3
),
mainPanel(
verbatimTextOutput("info"),
plotlyOutput("scatMatPlot")
)
)
))
server <- shinyServer(function(input, output, session) {
# Create data and subsets of data based on user selection of pairs
dat <- data.frame(ID = paste0("ID", 1:10000), A = rnorm(10000), B = rnorm(10000), C = rnorm(10000), D = rnorm(10000))
pairNum <- reactive(input$selPair)
group1 <- reactive(pairNum()[1])
group2 <- reactive(pairNum()[2])
sampleIndex <- reactive(which(colnames(dat) %in% c(group1(), group2())))
# Create data subset based on two letters user chooses
datSel <- eventReactive(sampleIndex(), {
datSel <- dat[, c(1, sampleIndex())]
datSel$ID <- as.character(datSel$ID)
datSel <- as.data.frame(datSel)
datSel
})
sampleIndex1 <- reactive(which(colnames(datSel()) %in% c(group1())))
sampleIndex2 <- reactive(which(colnames(datSel()) %in% c(group2())))
# Create background Plotly graph with hex binning all 100 rows of the two user-selected columns
ggPS <- eventReactive(datSel(), {
minVal = min(datSel()[,-1])
maxVal = max(datSel()[,-1])
maxRange = c(minVal, maxVal)
xbins=7
buffer = (maxRange[2]-maxRange[1])/xbins/2
x = unlist(datSel()[,(sampleIndex1())])
y = unlist(datSel()[,(sampleIndex2())])
h <- hexbin(x=x, y=y, xbins=xbins, shape=1, IDs=TRUE, xbnds=maxRange, ybnds=maxRange)
hexdf <- data.frame (hcell2xy (h), hexID = h#cell, counts = h#count)
attr(hexdf, "cID") <- h#cID
p <- ggplot(hexdf, aes(x=x, y=y, fill = counts, hexID=hexID)) + geom_hex(stat="identity") + geom_abline(intercept = 0, color = "red", size = 0.25) + coord_cartesian(xlim = c(maxRange[1]-1*buffer, maxRange[2]+buffer), ylim = c(maxRange[1]-1*buffer, maxRange[2]+buffer)) + coord_equal(ratio=1) + labs(x = colnames(datSel()[sampleIndex1()]), y = colnames(datSel()[sampleIndex2()]))
ggPS <- ggplotly(p)
ggPS})
# Output hex bin plot created just above
output$scatMatPlot <- renderPlotly({
# Each time user pushes Go! button, the next row of the data frame is selected
datInput <- eventReactive(input$goButton, {
g <- datSel()$ID[input$goButton]
# Output ID of selected row
output$info <- renderPrint({
g
})
# Get x and y values of seleced row
currGene <- datSel()[which(datSel()$ID==g),]
currGene1 <- unname(unlist(currGene[,sampleIndex1()]))
currGene2 <- unname(unlist(currGene[,sampleIndex2()]))
c(currGene1, currGene2)
})
# Send x and y values of selected row into onRender() function
observe({
session$sendCustomMessage(type = "points", datInput())
})
# Use onRender() function to draw x and y values of seleced row as orange point
ggPS() %>% onRender("
function(el, x, data) {
noPoint = x.data.length;
Shiny.addCustomMessageHandler('points', function(drawPoints) {
if (x.data.length > noPoint){
Plotly.deleteTraces(el.id, x.data.length-1);
}
var Traces = [];
var trace = {
x: drawPoints.slice(0, drawPoints.length/2),
y: drawPoints.slice(drawPoints.length/2, drawPoints.length),
mode: 'markers',
marker: {
color: 'orange',
size: 7
},
hoverinfo: 'none'
};
Traces.push(trace);
Plotly.addTraces(el.id, Traces);
});}")
})
})
shinyApp(ui, server)
As #HubertL mentioned, it's better to avoid nesting reactive functions. Your app will probably run more smoothely if you change that.
About your first problem, req and validate are probably the best way to go. These functions check if the user inputs are valid and deal with the invalid ones.
I've adjusted your code a bit following these sugetions, but you still can change it more. If you take a closer look to ggPS you may notice that it only uses datSel() so you could turn it into a function.
library(plotly)
library(GGally)
library(hexbin)
library(htmlwidgets)
library(tidyr)
library(shiny)
library(dplyr)
library(data.table)
library(ggplot2)
library(tibble)
myPairs <- c("A", "B", "C", "D")
ui <- shinyUI(fluidPage(
titlePanel("title panel"),
sidebarLayout(
position = "left",
sidebarPanel(
selectizeInput("selPair", "Pairs:", choices = myPairs, multiple = TRUE,
options = list(maxItems = 2)),
actionButton("goButton", "Go!"),
width = 3
),
mainPanel(
verbatimTextOutput("info"),
plotlyOutput("scatMatPlot")
)
)
))
server <- shinyServer(function(input, output, session) {
# Create data and subsets of data based on user selection of pairs
dat <- data.frame(
ID = paste0("ID", 1:10000), A = rnorm(10000),
B = rnorm(10000), C = rnorm(10000), D = rnorm(10000),
stringsAsFactors = FALSE
)
# Create data subset based on two letters user chooses
datSel <- eventReactive(input$selPair, {
validate(need(length(input$selPair) == 2, "Select a pair."))
dat[c("ID", input$selPair)]
}, ignoreNULL = FALSE)
# Create background Plotly graph with hex binning all 100 rows of the two user-selected columns
ggPS <- eventReactive(datSel(), {
minVal = min(datSel()[,-1])
maxVal = max(datSel()[,-1])
maxRange = c(minVal, maxVal)
xbins=7
buffer = (maxRange[2]-maxRange[1])/xbins/2
x = unlist(datSel()[input$selPair[1]])
y = unlist(datSel()[input$selPair[2]])
h <- hexbin(x=x, y=y, xbins=xbins, shape=1, IDs=TRUE,
xbnds=maxRange, ybnds=maxRange)
hexdf <- data.frame (hcell2xy (h), hexID = h#cell, counts = h#count)
attr(hexdf, "cID") <- h#cID
p <- ggplot(hexdf, aes(x=x, y=y, fill = counts, hexID=hexID)) +
geom_hex(stat="identity") + geom_abline(intercept = 0, color = "red", size = 0.25) +
coord_cartesian(xlim = c(maxRange[1]-1*buffer, maxRange[2]+buffer),
ylim = c(maxRange[1]-1*buffer, maxRange[2]+buffer)) +
coord_equal(ratio = 1) +
labs(x = input$selPair[1], y = input$selPair[2])
ggPS <- ggplotly(p)
ggPS
})
# Output ID of selected row
output$info <- renderPrint({ datSel()$ID[req(input$goButton)] })
# Output hex bin plot created just above
output$scatMatPlot <- renderPlotly({
# Use onRender() function to draw x and y values of seleced row as orange point
ggPS() %>% onRender("
function(el, x, data) {
noPoint = x.data.length;
Shiny.addCustomMessageHandler('points', function(drawPoints) {
if (x.data.length > noPoint){
Plotly.deleteTraces(el.id, x.data.length-1);
}
var Traces = [];
var trace = {
x: drawPoints.slice(0, drawPoints.length/2),
y: drawPoints.slice(drawPoints.length/2, drawPoints.length),
mode: 'markers',
marker: {
color: 'orange',
size: 7
},
hoverinfo: 'none'
};
Traces.push(trace);
Plotly.addTraces(el.id, Traces);
});}")
})
observe({
# Get x and y values of seleced row
currGene <- datSel()[input$goButton, -1]
# Send x and y values of selected row into onRender() function
session$sendCustomMessage(type = "points", unname(unlist(currGene)))
})
})
shinyApp(ui, server)

Shiny: Conditional Panel and Conditional List of checkboxGroupInput

I want to create a shiny app for plotting the most recent pollstR charts of US presidential primaries. Users should be able to select a Party (Dem or Rep), the Candidates and the states, where the primaries (or Caucusus) took place.
I have three problems:
Based on the selected party (Dem or Rep), users should get the next checkboxGroupInput, where only the Democratic or Republican candidates appear. I try to solved that with a conditionalPanel. However, I cannot use "Candidate" twice as a name for the Widget (later in the server.R I need input$Candidate). How can I solve that?
Based on the selected party (again Dem or Rep), users should get a list of all states, where primaries and caucusus took place up to now. At the moment, I am listing all US states, which I defined before (and hence I get errors, if I want to plot the results of states, where no polls are available). Is there a way to get the list of states from the dataset, which is generated in the server.R part (it is called polls$state there, but I cannot use it, because the ui.R does not now "polls").
I plot the results as bar-charts with ggplot and the facet_wrap function (with two columns). The more states I choose, the smaller the plots get. Is there a way to set the height of the plots and insert a vertical scrollbar in the main panel?
Here is the code for the UI:
shinyUI(fluidPage(
titlePanel("2016 Presidential primaries"),
sidebarLayout(position = "right",
sidebarPanel(
helpText("Choose between Democratic (Dem) and Republican (Rep)
Primaries and Caucuses:"),
selectInput("party",
label = "Dem or Rep?",
choices = c("Dem", "Rep",
selected = "Dem")),
conditionalPanel(
condition = "input.party == 'Dem'",
checkboxGroupInput("Candidate", label = h4("Democratic Candidates"),
choices = list("Clinton" = "Clinton", "Sanders" = "Sanders"),
selected = NULL)),
conditionalPanel(
condition = "input.party == 'Rep'",
checkboxGroupInput("Candidate", label = h4("Republican Candidates"),
choices = list("Bush" = "Bush", "Carson" = "Carson", "Christie" = "Christie",
"Cruz" = "Cruz", "Kasich" = "Kasich", "Rubio" = "Rubio",
"Trump" = "Trump"),
selected = NULL)),
checkboxGroupInput("state",
label = "Select State",
choices = states,
inline = TRUE,
selected = NULL)
),
mainPanel(
tabsetPanel(
tabPanel("Plot", plotOutput("plot")),
tabPanel("Table", tableOutput("table"))
)
)
)
))
And here the code for the server.R:
### getting and cleaning the data for the shiny app-----------------------------
# load pollstR-package to get Huffpost opinion polls
require(pollstR)
# load dplyr and tidyr for data wrangling
require(dplyr)
require(tidyr)
# load ggplot2 for plotting
require(ggplot2)
# download 2016 GOP presidential primaries
repPoll <- pollstr_charts(topic='2016-president-gop-primary', showall = TRUE)
# extract and combine columns needed
choice <- repPoll$estimates$choice
value <- repPoll$estimates$value
election <- repPoll$estimates$slug
party <- repPoll$estimates$party
rep.df <- data_frame(election, choice, value, party)
# extract and combine slug and state info to add list of US state abbreviations
election <- repPoll$charts$slug
state <- repPoll$charts$state
r.stateAbb <- data_frame(election, state)
# join both data frames based on slug
rep.df <- left_join(rep.df, r.stateAbb, by = "election")
## download 2016 DEM presidential primaries
demPoll <- pollstr_charts(topic='2016-president-dem-primary', showall = TRUE)
# extract and combine columns needed
choice <- demPoll$estimates$choice
value <- demPoll$estimates$value
election <- demPoll$estimates$slug
party <- demPoll$estimates$party
dem.df <- data_frame(election, choice, value, party)
# extract and combine slug and state info to add list of US state abbreviations
election <- demPoll$charts$slug
state <- demPoll$charts$state
d.stateAbb <- data_frame(election, state)
# join both data frames based on slug
dem.df <- left_join(dem.df, d.stateAbb, by = "election")
# combine dem and rep datasets
polls <- bind_rows(dem.df, rep.df)
polls$party <- as.factor(polls$party)
polls$state <- as.factor(polls$state)
polls$choice <- as.factor(polls$choice)
shinyServer(function(input, output) {
df <- reactive({
polls %>% filter(party %in% input$party) %>% filter(choice %in% input$Candidate) %>%
filter(state %in% input$state)
})
# generate figures
output$plot <- renderPlot({
validate(
need(input$party, "Please select a party"),
need(input$Candidate, "Please choose at least one candidate"),
need(input$state, "Please select at least one state")
)
p <- ggplot(df())
p <- p + geom_bar(aes(x = choice, weight = value, fill = choice),
position = "dodge", width=.5)
# colorize bars based on parties
if (input$party == "Dem")
p <- p + scale_fill_brewer(palette = "Blues", direction = -1)
if (input$party == "Rep")
p <- p + scale_fill_brewer(palette = "Reds", direction = -1)
# add hlines for waffle-design
p <- p + geom_hline(yintercept=seq(0, 100, by = 10), col = 'white') +
geom_text(aes(label = value, x = choice, y = value + 1), position = position_dodge(width=0.9), vjust=-0.25) +
# facet display
facet_wrap( ~ state, ncol = 2) +
# scale of y-axis
ylim(0, 100) +
# delete labels of x- and y-axis
xlab("") + ylab("") +
# blank background and now grids and legend
theme(panel.grid.major.x = element_blank(), panel.grid.major.y = element_blank(),
panel.grid.minor.y = element_blank(),
panel.background = element_blank(), legend.position = "none")
print(p)
}
)
# Generate a table view of the data
output$table <- renderTable({
polls %>% filter(party %in% input$party) %>% filter(choice %in% input$Candidate) %>%
filter(state %in% input$state)
})
}
)
Here is the solution for problem 1 and 2:
In ui.R, replace conditionalPanel and checkboxGroupInput with
uiOutput('candidates'),
uiOutput('states')
In server.R, add the following code before df <- reactive({..... Note that you need to change some of your input$Candidate code to lower case.
observeEvent(input$party, {
output$candidates <- renderUI({
checkboxGroupInput(
"candidate",
ifelse(input$party == 'Dem', "Democratic Candidates", "Republican Candidates"),
as.vector(unique(filter(polls,party==input$party)$choice))
)
})
})
observeEvent(input$candidate, {
output$states <- renderUI({
states_list <- as.vector(unique(filter(polls, party==input$party & choice==input$candidate)$state))
checkboxGroupInput(
"state",
"Select state",
# Excluding national surveys
states_list[states_list!="US"]
)
})
})
For problem 3, change the df reactive to observe, and then set plot height depending on how many states selected. Also change this line p <- ggplot(df)
observe({
df <- polls %>% filter(party %in% input$party) %>% filter(choice %in% input$candidate) %>% filter(state %in% input$state)
height <- ceiling(length(input$state) / 2) * 200
output$plot <- renderPlot({
#Your plot code
}, height=height)
})

Resources