Nesting two observeEvents duplicates the reactive event - r

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)

Related

Use the data rendered in output through DT::renderDataTable for further plotting

I have developed a shiny app, in which I am uploading a number of CSV files in each tab. After performing some mathematical operations on the uploaded data, I am getting N number of data tables as an output. I am rendering those data tables using DT::renderDataTable.
Now, let say I have 3 different datatables rendered using DT::renderDataTable I want to use the output rendered in those datatables to plot a combined graph. (3 geom_line() on top of each other)
This is how I am rendering the data in the datatable:
output$Data_FSC <- DT::renderDataTable({
x1 <- data2()[, c(input$xcol2, input$ycol2)]
M <- x1
#calculate rotation angle
alpha <- -atan((M[1,2]-tail(M,1)[,2])/(M[1,1]-tail(M,1)[,1]))
#rotation matrix
rotm <- matrix(c(cos(alpha),sin(alpha),-sin(alpha),cos(alpha)),ncol=2)
#shift, rotate, shift back
M2 <- t(rotm %*% (t(M)-c(M[1,1],M[1,2]))+c(M[1,1],M[1,2]))
M2[nrow(M2),2] <- M2[1,2]
M2
d_f3 <- data.frame(x = M2[,1], y = (M2[,2]-min(M2[1,2])))
v_f1 <- subset(d_f3, y > ((input$below2)/1000) & y < ((input$above2)/1000), select = c(x,y))
fla_upper2 <- lm(formula = y+((input$Upper_Poly_Limit2)/1000000) ~ poly(x,input$degree2, raw = TRUE), v_f1)
fla_lower2 <- lm(formula = y-((input$Lower_Poly_Limit2)/1000000) ~ poly(x,input$degree2, raw = TRUE), v_f1)
v_f1$upper2 <- predict(fla_upper2, newdata=v_f1)
v_f1$lower2 <- predict(fla_lower2, newdata=v_f1)
v_f1$region2 <- ifelse(v_f1[,2] <= v_f1$upper2 & v_f1[,2] >= v_f1$lower2, 'inside', 'outside')
kl <- subset(v_f1, region2 =='inside')
g <- ggplot() + theme_bw() +
geom_smooth(data = kl, aes_string(kl[,1], kl[,2]), formula = y ~ poly(x,input$degree_2, raw = TRUE), method = "lm", color = "green3", level = 1, size = 0.5)
r <- ggplot_build(g)$data[[1]]
q <- data.frame(x = r[,1], y = r[,2])
#calculate rotation angle
beta <- -atan((q[1,2]-tail(q,1)[,2])/(q[1,1]-tail(q,1)[,1]))
#rotation matrix
rot_m <- matrix(c(cos(beta),sin(beta),-sin(beta),cos(beta)),ncol=2)
#shift, rotate, shift back
M_2 <- t(rot_m %*% (t(q)-c(q[1,1],q[1,2]))+c(q[1,1],q[1,2]))
M_2[nrow(M_2),2] <- M_2[1,2]
M_2
M_3 <- data.frame(x= (M_2[,1]-median(M_2[,1])), y= (M_2[,2]-min(M_2[,2])))
the_data <- reactive(M_3)
the_data()
})
I tried feeding the output of the DT::renderDataTable as input for ggplot but my shiny app is showing me an error saying that
Reading from shinyoutput object is not allowed.
I already knew that 'Reading from shinyoutput object is not allowed'.
I just want to know whether there is any way I can use the output rendered in datatable for further plotting in a shiny app.
Here's a MWE demonstrating what I think you want to do.
Notice the separation of data from presentation: t1, t2 and t3 are reactives representing your CSV files. Each is rendered in a different data table. allData is a reactive containing union of the CSV data. This is used as the source data for the plot.
library(shiny)
library(DT)
library(tidyverse)
ui <- fluidPage(
numericInput("n", "Number of points:", min=2, max=20, value=10),
plotOutput("plot"),
dataTableOutput("table1"),
dataTableOutput("table2"),
dataTableOutput("table3")
)
server <- function(input, output) {
t1 <- reactive({ tibble(x=1:input$n, y=rnorm(input$n), key="Table 1") })
t2 <- reactive({ tibble(x=1:input$n, y=rnorm(input$n), key="Table 2") })
t3 <- reactive({ tibble(x=1:input$n, y=rnorm(input$n), key="Table 3") })
allData <- reactive({ bind_rows(t1(), t2(), t3()) })
output$table1 <- renderDT({ t1() })
output$table2 <- renderDT({ t2() })
output$table3 <- renderDT({ t3() })
output$plot <-renderPlot({ allData() %>% ggplot() + geom_line(aes(x=x, y=y, colour=key)) })
}
shinyApp(ui = ui, server = server)
It might be worth looking at using modules to manage and present the CSV files.

Invoke function within RShiny server call and render result as print output

I have written a script which makes use of 2 functions in order to calculate the duration required for a test to run, eg power analysis.
Inputs and code as follows;
## RUN POWER CALCULATION
average_daily_traffic <- 3515/30
control <- 0.47
uplift <- 0.02
num_vars <- 2
sample_size_calculator <- function(control, uplift){
variant <- (uplift + 1) * control
baseline <- ES.h(control, variant)
sample_size_output <- pwr.p.test(h = baseline,
n = ,
sig.level = 0.05,
power = 0.8)
if(variant >= 0)
{return(sample_size_output)}
else
{paste("N/A")}
}
## RUN DAYS CALCULATOR FUNCTION
days_calculator <- function(sample_size_output, average_daily_traffic){
days_required <- c((sample_size_output)*num_vars)/(average_daily_traffic)
if(days_required >= 0)
{paste0("It will take ", round(days_required, digits = 0)*num_vars, " days for this test to reach significance, with a daily average of " , round(average_daily_traffic, digits = 0), " visitors to this page over a 30 day period.")}
else
{paste("N/A")}
}
## RUN FUNCTIONS AND OUTPUT ANSWER
sample_size_calculator <- sample_size_calculator(control, uplift)
sample_size_output <- sample_size_calculator$n
answer <- days_calculator(sample_size_output, average_daily_traffic)
answer
This code is performant and is fit for my purpose in a standalone R script.
However, I need to make these functions executable from within a Shiny app. My attempt is as follows;
library(shiny)
ui <- fluidPage(
actionButton("exe", "Run",
style="color: #fff; background-color: #337ab7; border-color: #2e6da4"),
mainPanel(
textOutput("answer")
))
server <- function(input, output, session) {
sample_size_calculator <- eventReactive(input$exe,{
average_daily_traffic <- 3515/30
control <- 0.47
uplift <- 0.02
num_vars <- 2
variant <- (uplift + 1) * control
baseline <- ES.h(control, variant)
sample_size_output <- pwr.p.test(h = baseline,
n = ,
sig.level = 0.05,
power = 0.8)
if(variant >= 0)
{return(sample_size_output)}
else
{paste("N/A")}
})
days_calculator <- eventReactive (input$exe,{
days_required <- c((sample_size_output)*num_vars)/(average_daily_traffic)
if(days_required >= 0)
{paste0("It will take approximately ", round(days_required, digits = 0)*num_vars, " days or ", round((round(days_required, digits = 0)*num_vars)/365, digits = 1) ," years for this test to reach significance, based on a daily average of " , round(average_daily_traffic, digits = 0), " users to this page in the last 30 days.")}
else
{paste("N/A")}
})
outputs_ <- eventReactive( input$exe, {
req(sample_size_calculator())
req(days_calculator())
sample_size_calculator <- sample_size_calculator(control, uplift)
sample_size_output <- sample_size_calculator$n
answer <- days_calculator(sample_size_output, average_daily_traffic)
output$answer <- renderText(outputs_$answer)
})
}
shinyApp(ui = ui, server = server)
When I run this code, I see the execute button but no output is displayed.
This is very likely due to a limitation in my understanding of how Shiny invokes functions so if there is a better way I would be very grateful to hear it.
Thanks in advance.
* EDITING TO INCLUDE FULL FUNCTIONALITY CODE *
The objective of the code is to use Mark Edmonson's googleAnalyticsR and googleAuthR to enable retrieval of web visit data to a particular URL/page from the Google Analytics account for last 30days and show a trend of this data. This works fine, once the user enters the URL and hits 'Run'.
There is an additional GA call which retrieves additional data for a particular conversion action (see other_data). This is required in order to derive the conversion rate that is used later in the power calculation.
The calculation is cvr <- aeng$users/totalusers
#options(shiny.port = 1221)
## REQUIRED LIBS
library(shiny)
library(googleAnalyticsR)
library(plotly)
library(googleAuthR)
library(markdown)
library(pwr)
gar_set_client(scopes = c("https://www.googleapis.com/auth/analytics.readonly"))
daterange <- function(x) {
as.Date(format(x, "%Y-%m-01"))
}
## DATE PARAMETERS
date_start <- as.Date(Sys.Date(),format='%d-%B-%Y')-31
date_end <- as.Date(Sys.Date(),format='%d-%B-%Y')-1
date_range <- c(date_start, date_end)
## UI SECTION
ui <- fluidPage(
googleAuth_jsUI("auth"),
tags$head(
tags$link(rel = "stylesheet", type = "text/css", href = "dur_calc.css")
),
tags$br(),
sidebarLayout(
sidebarPanel(
code("To begin, select from 'Accounts' and enter URL of page to be tested:"),
tags$p(),
column(width = 12, authDropdownUI("auth_dropdown",
inColumns = FALSE)),
textInput("url", label = h5(strong("Page to be tested")), value = "Enter full page URL..."),
hr(),
fluidRow(column(3, verbatimTextOutput("value")
)
),
actionButton("exe", "Run Calculator",
style="color: #fff; background-color: #337ab7; border-color: #2e6da4"),
),
mainPanel(
plotlyOutput("trend_plot"),
textOutput("page"),
textOutput("answer")
)
)
)
## SERVER SECTION
server <- function(input, output, session) {
auth <- callModule(googleAuth_js, "auth")
## GET GA ACCOUNTS
ga_accounts <- reactive({
req(auth()
)
with_shiny(
ga_account_list,
shiny_access_token = auth()
)
})
view_id <- callModule(authDropdown, "auth_dropdown",
ga.table = ga_accounts)
ga_data <- eventReactive( input$exe, {
x <- input$url
#reactive expression
output$page <- renderText({
paste("You have selected the page:", input$url) })
filterPageurl <- dim_filter("dimension97" , "REGEX", x ,not = FALSE)
filts <- filter_clause_ga4(list( filterPageurl))
req(view_id())
req(date_range)
with_shiny(
google_analytics,
view_id(),
date_range = date_range,
dimensions = "date",
metrics = "users",
dim_filters = filts,
max = -1,
shiny_access_token = auth()
)
})
other_data <- eventReactive( input$exe, {
x <- input$url
filterPageurl <- dim_filter("dimension97" , "REGEX", x ,not = FALSE)
filts <- filter_clause_ga4(list( filterPageurl))
seg_id <- "gaid::uzKGvjpFS_Oa2IRh6m3ACg" #AEUs
seg_obj <- segment_ga4("AEUs", segment_id = seg_id)
req(view_id())
req(date_range)
#req(filts)
with_shiny(
google_analytics,
view_id(),
date_range = date_range,
dimensions = "date",
metrics = "users",
dim_filters = filts,
segments = seg_obj,
max = -1,
shiny_access_token = auth()
)
})
outputly <- eventReactive( input$exe, {
req(other_data())
req(ga_data())
aeng <- other_data()
ga_data <- ga_data()
totalusers <<- sum(ga_data$users)
cvr <- aeng$users/totalusers
average_daily_traffic <- totalusers/30
control <- cvr
uplift <- 0.02
num_vars <- 2
})
sample_size_calculator <- eventReactive(input$exe,{
variant <- (uplift + 1) * control
baseline <- ES.h(control, variant)
sample_size_output <- pwr.p.test(h = baseline,
n = ,
sig.level = 0.05,
power = 0.8)
if(variant >= 0)
{return(sample_size_output)}
else
{paste("N/A")}
})
days_calculator <- eventReactive (input$exe,{
days_required <- c((sample_size_output)*num_vars)/(average_daily_traffic)
if(days_required >= 0)
{paste0("It will take approximately ", round(days_required, digits = 0)*num_vars, " days or ", round((round(days_required, digits = 0)*num_vars)/365, digits = 1) ," years for this test to reach significance, based on a daily average of " , round(average_daily_traffic, digits = 0), " users to this page in the last 30 days.")}
else
{paste("N/A")}
})
output$trend_plot <- renderPlotly({
req(ga_data())
ga_data <- ga_data()
plot_ly(
x = ga_data$date,
y = ga_data$users,
type = 'scatter',
mode = 'lines') %>%
layout(title = "Page Visitors by Day (last 30 days)",
xaxis=list(title="Date", tickformat='%Y-%m-%d', showgrid=FALSE, showline=TRUE),
yaxis=list(title = "Users", showgrid=FALSE, showline=TRUE)
)
})
calc_answer <- eventReactive(input$exe, {
req(outputly)
outputly <- outputly()
sample_size_calculator <- sample_size_calculator()
sample_size_output <- sample_size_calculator$n
days_calculator(sample_size_output, average_daily_traffic)
})
output$answer <- renderText(calc_answer())
}
shinyApp(ui = ui, server = server)
A few suggestions that may help.
Would start with a simplified shiny app before adding all of the calculations, may be easier to work with for now
Would avoid putting output statements inside of eventReactive. See below for example.
Consider having only one observeEvent or eventReactive for the button press instead of multiple, especially since some function results depend on others.
Right now there are no inputs, so don't need additional reactive expressions. When you add inputs, though, you probably will.
If you haven't already, review the R Studio Shiny tutorial on Action Buttons and Reactivity.
Hope this is helpful in moving forward.
library(shiny)
library(pwr)
ui <- fluidPage(
actionButton("exe", "Run", style="color: #fff; background-color: #337ab7; border-color: #2e6da4"),
mainPanel(
textOutput("answer")
)
)
server <- function(input, output, session) {
average_daily_traffic <- 3515/30
control <- 0.47
uplift <- 0.02
num_vars <- 2
sample_size_calculator <- function() {
variant <- (uplift + 1) * control
baseline <- ES.h(control, variant)
sample_size_output <- pwr.p.test(h = baseline,
n = ,
sig.level = 0.05,
power = 0.8)
if(variant >= 0)
{return(sample_size_output)}
else
{return(NA)}
}
days_calculator <- function (sample_size_output, average_daily_traffic) {
days_required <- c((sample_size_output)*num_vars)/(average_daily_traffic)
if(days_required >= 0)
{paste0("It will take approximately ", round(days_required, digits = 0)*num_vars, " days or ", round((round(days_required, digits = 0)*num_vars)/365, digits = 1) ," years for this test to reach significance, based on a daily average of " , round(average_daily_traffic, digits = 0), " users to this page in the last 30 days.")}
else
{paste("N/A")}
}
calc_answer <- eventReactive(input$exe, {
sample_size_calculator <- sample_size_calculator()
sample_size_output <- sample_size_calculator$n
days_calculator(sample_size_output, average_daily_traffic)
})
output$answer <- renderText(calc_answer())
}
shinyApp(ui = ui, server = server)

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)

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: Dynamic colour (fill) input for ggplot

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()
})
}
))

Resources