Related
My app is supposed to load certain data as input file (in this post i will give a part of it written in form of data frame so you can use to run my example). and then plot three plots . i want that when the user click oh the plot at the top of page , a first new plot will be displayed based on the click info and when the new plot will be displayed then i want to plot a second new plot based on the click info of the first new plot.
library(dplyr)
library(shiny)
library(shinydashboard)
library(shinyWidgets)
library(ggplot2)
library(gridExtra)
library(scales)
library(grid)
library(RColorBrewer)
library(officer)
library(svglite)
library(rvg)
library(readxl)
library(tools)
library(rsvg)
body <- dashboardBody(
fluidRow(
tabBox(
# The id lets us use input$tabset1 on the server to find the current tab
id = "tabset1",height = 750,width=20,
tabPanel("Summary",dataTableOutput(outputId = "table")),
tabPanel("Visualization",sliderInput("scalegvt","Scale Data by:", min = 0, max = 100, value = c(70,100)),plotOutput("p1", height = 1000,click = "plot_click")
)
)
)
)
side<- dashboardSidebar(
width = 290,
sidebarMenu(
menuItem("Summary",tabName = "Summary") ,
uiOutput('choose_Da'),
selectizeGroupUI(
id = "m",
inline = FALSE,
params = list(
Lot = list(inputId = "Lot", title = "Lot"),
wafer = list(inputId = "wafer", title = "wafer"),
M_datum = list(inputId = "M_Datum", title = "M_Datum"),
Yield = list(inputId = "Yield", title = "Yield")
)
),inline=FALSE,
menuItem("Visualization",tabName = "Visualization")
))
ui <- function(request) {
dashboardPage(
dashboardHeader(title = "Yield Report",titleWidth = 290),
side,
body
)
}
server = function(input, output,session) {
newscale <- reactive({
req(input$scalegvt)
})
mydt<-data.frame(Lot=c(rep("A",4),rep("b",5),rep("n",3),rep("x",2)),M_Datum=as.Date(c("2012-06-05","2012-06-15","2012-06-10","2014-11-17","2014-03-18","2014-06-15","2014-06-10","2014-06-17","2015-11-27","2016-08-15","2016-09-10","2016-10-27","2017-09-10","2017-10-12")),wafer=(c(rep(5,14)+1:14)),Yield=c(rep(10,14)+57))
dz<-reactive({
req(res_mod())
dat<-res_mod()
dt<-dat[dat$M_Datum >=input$dateRange[1] & dat$M_Datum <= input$dateRange[2],]
dt[,2]<-as.Date(format(as.Date(dt[,2]), "%Y-%m-01"))
req(dt$M_Datum,dt$Yield)
dr<-data.frame("M_Datum"=dt$M_Datum,"Yield"=dt$Yield)
req(dr$M_Datum,dr$Yield)
dx<-aggregate(Yield~M_Datum,dr,mean)
req(dx$M_Datum,dx$Yield)
dx$M_Datum<-format(dx$M_Datum, "%b %Y")
return(data.frame("M_Datum"=dx$M_Datum,"Yield"=dx$Yield))
})
#observeEvent(input$plot_click,
#{ a<- reactive(nearPoints(dz(), input$plot_click, threshold = 10, maxpoints = 1,
# addDist = F))
# b<-reactive(match(substr(a()$M_Datum,1,3),month.abb))
# req(res_mod())
#dat<-res_mod()
#dt<-dat[dat$M_Datum >=input$dateRange[1] & dat$M_Datum <= input$dateRange[2],]
#dt<-dt[substr(dt$M_Datum,6,7)==as.character(b()),]
#req(dt$Lot,dt$Yield)
#dr<-data.frame("Lot"=dt$Lot,"Yield"=dt$Yield)
# req(dr$Lot,dr$Yield)
# dx<-aggregate(Yield~Lot,dr,mean)
# req(dx$Lot,dx$Yield)
# dza<-data.frame("Lot"=dx$Lot,"Yield"=dx$Yield)
# output$p2 <- renderPlot({ ggplot(dza, aes(x = Lot,y = Yield,group = 1)) +
# geom_point()})
#})
output$choose_Da <- renderUI({
dateRangeInput('dateRange',
label = 'Filter by date',
start = min(mydt$M_Datum) , end = max(mydt$M_Datum),min=min(mydt$M_Datum),max=max(mydt$M_Datum)
)
})
res_mod <- callModule(
module = selectizeGroupServer,
id = "m",
data = mydt,
vars = c("Lot","M_Datum","Yield","wafer"),
inline=FALSE
)
output$table <- renderDataTable({
dato<-res_mod()
return(dato[dato$M_Datum >= input$dateRange[1] & dato$M_Datum <= input$dateRange[2],]) },
options = list(scrollX = TRUE))
filtredplot<-reactive({
req(res_mod())
dat<-res_mod()
dt<-dat[dat$M_Datum >=input$dateRange[1] & dat$M_Datum <= input$dateRange[2],]
dt[,2]<-as.Date(format(as.Date(dt[,2]), "%Y-%m-01"))
req(dt$M_Datum,dt$Yield)
dr<-data.frame("M_Datum"=dt$M_Datum,"Yield"=dt$Yield)
req(dr$M_Datum,dr$Yield)
dx<-aggregate(Yield~M_Datum,dr,mean)
req(dx$M_Datum,dx$Yield)
dz<-data.frame("M_Datum"=dx$M_Datum,"Yield"=dx$Yield)
dz$M_Datum<-factor(format(dz$M_Datum, "%b %Y"), levels=format(sort(unique(dz$M_Datum)),"%b %Y"))
hline_data <- data.frame(y = c(mean(dz$Yield)-sd(dz$Yield),mean(dz$Yield), mean(dz$Yield)+sd(dz$Yield)), type = factor(c(2, 1, 2)),
stringsAsFactors = FALSE)
ggplot(dz, aes(x=M_Datum, y=Yield,group = 1)) +
geom_point(size=7,colour="#007A9D",shape=4) +
theme(axis.text.x = element_text(angle = 0, vjust = 0.5, hjust=1))+
theme(legend.direction = "horizontal", legend.position = "top", legend.key = element_blank(),
legend.background = element_rect(fill = "white", colour = "white"),
axis.text.y.left = element_text(color = "#007A9D"),
axis.title.y.left = element_text(color = "#007A9D"),
plot.title = element_text(color="#007A9D")
)+
ylab("Mean Yield")+
xlab("")+
ggtitle(paste0("FCM-Yield Trend :"," ",paste0(c(input[["m-Customer_Name"]],input[["m-Local_Process_Id"]],input[["m-Process_Family"]],input[["m-MEMS_flag"]],input[["m-Device"]]),collapse = ",")))+
ylim(newscale())+
geom_hline(data = hline_data,
aes(yintercept = y, linetype = type, colour = type)) +
scale_colour_manual(values = c("#007A9D", "#EF783D"),
labels = c("Mean", "Mean+-sd"),
name = "Key:") +
scale_linetype_manual(values = 1:2,
labels = c("Mean", "Mean+-sd"),
name = "Key:")
})
output$p1<-renderPlot({
filtredplot() })
}
shinyApp(ui,server)
in that part of code turned to comment i have tried using the clik info to transform that month name to number to use it in order to filter data that means i want to plot the lot (x axis ) vs Yield ( as y axis in form of mean(avarage) ) so i can get average of yield pro lot in that month and then when i click again i want to get a second plot showing yield ( y axis not aggregated as mean this time) vs wafer (x axis) and of course only for that lot chosen by clickíng the first new plot.
The code posted is not a minimal reproducible example MRE. I did not go through it. But here is an MRE to achieve the task you have described: to output a second plot (p2) based on the plot_click of a first plot (p1) using nearPoints() shiny function.
library(shiny)
library(ggplot2)
data <- mpg
ui <- basicPage(
plotOutput("p1", click = "plot_click"),
plotOutput("p2")
)
server <- function(input, output) {
output$p1 <- renderPlot({
ggplot(data, aes(x = displ, y = cty)) +
geom_point()
})
observeEvent(input$plot_click,{
a <- nearPoints(data,
input$plot_click,
threshold = 10,
maxpoints = 1,
addDist = F)$model
if (length(a) > 0) {
df <- data[data$model == a, ]
output$p2 <- renderPlot({
ggplot(df, aes(x = model, y = displ, group = 1)) +
geom_point()
})
}
})
}
shinyApp(ui, server)
EDITED here is the above solution using your code. A click on p1 outputs a second plot p2, and a click on p2 outputs a third plot p3. I made the plots smaller because I'm working on a laptop. Note that because your sample data is small, not all datapoints result in a valid click. But there are enough "good" points to test out the solution.
library(dplyr)
library(shiny)
library(shinydashboard)
library(shinyWidgets)
library(ggplot2)
body <- dashboardBody(
fluidRow(
tabBox(
# The id lets us use input$tabset1 on the server to find the current tab
id = "tabset1",height = 750,width=20,
tabPanel("Summary",dataTableOutput(outputId = "table")),
tabPanel("Visualization",
sliderInput("scalegvt","Scale Data by:", min = 0, max = 100, value = c(70,100)),
plotOutput("p1", height = 300, width = 300, click = "plot_click_p1"),
plotOutput("p2", height = 300, width = 300, click = "plot_click_p2"),
plotOutput("p3", height = 300, width = 300,)
)
)
)
)
side <- dashboardSidebar(
width = 290,
sidebarMenu(
menuItem("Summary",tabName = "Summary") ,
uiOutput('choose_Da'),
selectizeGroupUI(
id = "m",
inline = FALSE,
params = list(
Lot = list(inputId = "Lot", title = "Lot"),
wafer = list(inputId = "wafer", title = "wafer"),
M_datum = list(inputId = "M_Datum", title = "M_Datum"),
Yield = list(inputId = "Yield", title = "Yield")
)
),inline=FALSE,
menuItem("Visualization",tabName = "Visualization")
))
ui <- function(request) {
dashboardPage(
dashboardHeader(title = "Yield Report",titleWidth = 290),
side,
body
)
}
server = function(input, output,session) {
newscale <- reactive({
req(input$scalegvt)
})
mydt<-data.frame(Lot=c(rep("A",4),rep("b",5),rep("n",3),rep("x",2)),M_Datum=as.Date(c("2012-06-05","2012-06-15","2012-06-10","2014-11-17","2014-03-18","2014-06-15","2014-06-10","2014-06-17","2015-11-27","2016-08-15","2016-09-10","2016-10-27","2017-09-10","2017-10-12")),wafer=(c(rep(5,14)+1:14)),Yield=c(rep(10,14)+57))
dz<-reactive({
req(res_mod())
dat<-res_mod()
dt<-dat[dat$M_Datum >=input$dateRange[1] & dat$M_Datum <= input$dateRange[2],]
dt[,2]<-as.Date(format(as.Date(dt[,2]), "%Y-%m-01"))
req(dt$M_Datum,dt$Yield)
dr<-data.frame("M_Datum"=dt$M_Datum,"Yield"=dt$Yield)
req(dr$M_Datum,dr$Yield)
dx<-aggregate(Yield~M_Datum,dr,mean)
req(dx$M_Datum,dx$Yield)
dx$M_Datum<-format(dx$M_Datum, "%b %Y")
return(data.frame("M_Datum"=dx$M_Datum,"Yield"=dx$Yield))
})
observeEvent(input$plot_click_p1, {
a <- nearPoints(dz(),
input$plot_click_p1,
threshold = 10,
maxpoints = 1,
addDist = F)
b <- match(substr(a$M_Datum,1,3),month.abb)
req(res_mod())
dat <- res_mod()
dt <- dat[dat$M_Datum >=input$dateRange[1] & dat$M_Datum <= input$dateRange[2],]
dt <- dt[substr(dt$M_Datum,6,7)==as.character(b),]
req(dt$Lot, dt$Yield)
dr <- data.frame("Lot"=dt$Lot,"Yield"=dt$Yield)
req(dr$Lot, dr$Yield)
dx <- aggregate(Yield~Lot,dr,mean)
req(dx$Lot,dx$Yield)
dza <- data.frame("Lot"=dx$Lot,"Yield"=dx$Yield)
output$p2 <- renderPlot({
ggplot(dza, aes(x = Lot,y = Yield,group = 1)) +
geom_point()
})
})
observeEvent(input$plot_click_p2, {
output$p3 <- renderPlot({
test <- nearPoints(mydt,
input$plot_click_p2,
threshold = 10,
maxpoints = 1,
addDist = F)
str(test)
ggplot(test, aes(x = Lot, y = Yield)) +
geom_point()
})
})
output$choose_Da <- renderUI({
dateRangeInput('dateRange',
label = 'Filter by date',
start = min(mydt$M_Datum) , end = max(mydt$M_Datum),min=min(mydt$M_Datum),max=max(mydt$M_Datum)
)
})
res_mod <- callModule(
module = selectizeGroupServer,
id = "m",
data = mydt,
vars = c("Lot","M_Datum","Yield","wafer"),
inline=FALSE
)
output$table <- renderDataTable({
dato <- res_mod()
return(dato[dato$M_Datum >= input$dateRange[1] & dato$M_Datum <= input$dateRange[2],])
},options = list(scrollX = TRUE))
filtredplot <- reactive({
req(res_mod())
dat <- res_mod()
dt <- dat[dat$M_Datum >=input$dateRange[1] & dat$M_Datum <= input$dateRange[2],]
dt[,2] <- as.Date(format(as.Date(dt[,2]), "%Y-%m-01"))
req(dt$M_Datum,dt$Yield)
dr<-data.frame("M_Datum"=dt$M_Datum,"Yield"=dt$Yield)
req(dr$M_Datum,dr$Yield)
dx<-aggregate(Yield~M_Datum,dr,mean)
req(dx$M_Datum,dx$Yield)
dz<-data.frame("M_Datum"=dx$M_Datum,"Yield"=dx$Yield)
dz$M_Datum<-factor(format(dz$M_Datum, "%b %Y"), levels=format(sort(unique(dz$M_Datum)),"%b %Y"))
hline_data <- data.frame(y = c(mean(dz$Yield)-sd(dz$Yield),mean(dz$Yield), mean(dz$Yield)+sd(dz$Yield)), type = factor(c(2, 1, 2)),
stringsAsFactors = FALSE)
ggplot(dz, aes(x=M_Datum, y=Yield,group = 1)) +
geom_point(size=7,colour="#007A9D",shape=4) +
theme(axis.text.x = element_text(angle = 0, vjust = 0.5, hjust=1))+
theme(legend.direction = "horizontal", legend.position = "top", legend.key = element_blank(),
legend.background = element_rect(fill = "white", colour = "white"),
axis.text.y.left = element_text(color = "#007A9D"),
axis.title.y.left = element_text(color = "#007A9D"),
plot.title = element_text(color="#007A9D")
) +
ylab("Mean Yield")+
xlab("")+
ggtitle(paste0("FCM-Yield Trend :"," ",paste0(c(input[["m-Customer_Name"]],input[["m-Local_Process_Id"]],input[["m-Process_Family"]],input[["m-MEMS_flag"]],input[["m-Device"]]),collapse = ",")))+
ylim(newscale())+
geom_hline(data = hline_data,
aes(yintercept = y, linetype = type, colour = type)) +
scale_colour_manual(values = c("#007A9D", "#EF783D"),
labels = c("Mean", "Mean+-sd"),
name = "Key:") +
scale_linetype_manual(values = 1:2,
labels = c("Mean", "Mean+-sd"),
name = "Key:")
})
output$p1 <- renderPlot({
filtredplot()
})
}
shinyApp(ui,server)
I'm trying to make a Shiny app which will take an uploaded CSV file and convert it into a tibble and then make a series of plots with the same X but using different columns for Y data, one per plot. I want the user to be able to use check boxes to select which plots they want to display and plot the result using plot_grid.
So far I managed to get the script to render the plots the way I want them and to draw them all on the fly from plot_grid if I name them manually. I'm having trouble including checkboxGroupInput output as an input for plot_grid, the characted vector returned cannot be used as a grob object. Here's the relevant code:
ui <- fluidPage(
titlePanel("Title"),
sidebarLayout(
sidebarPanel(
#Select which plots will be displayed
checkboxGroupInput(inputId = "whichPlot",
label = "Select data to plot",
choices = c("Temperature" = "tempChart()",
"Pressure" = "pressureChart()",
"Dissolved Oxygen" = "airsat()",
"pH" = "phChart()",
"Air flow" = "airChart()",
"Oxygen flow" = "O2Chart()"),
selected = "Temperature"),
#Select time scale
selectInput("timeScale",
"Choose time scale to plot",
choices = c("Minutes",
"Hours",
"Days"),
selected = "Minutes"),
#Apply button to make graphs
actionButton("DoIt", "Plot data"),
br(),
),
mainPanel(
plotOutput("plot"),
#the outputs below are not necessary, I just use them to see if I'm going in the right direction
textOutput("tableTitle"),
tableOutput("table"),
textOutput("selection"),
tableOutput("dataSummary")
)
)
)
server <- function(input, output) {
#A dummy tibble that I use for testing. will be replaced by Load button
dataDF <- tibble(date = c("01/01/2021","01/01/2021","01/01/2021","01/01/2021"), time = c("10:51:02","10:52:02","10:53:02","10:54:02"),
temp = c(20.000,22.000,23.000,24.000), pressure = c(50.000,50.000,50.000,50.000),
pH = c(7.000, 7.230, 7.100, 7.040), pO2 = c(100.000, 90.000, 80.000, 70.000),
airflow = c(1.000,1.000,1.000,1.000), O2flow = c(1.000,1.000,1.000,1.000), user = c("user","user","user","user"),
level = c(3,3,3,3), acid = c("00:00:00","00:00:00","00:00:00","00:00:00"), base =c("00:00:00","00:00:00","00:00:00","00:00:00"),
mins = c(0,2,3,4), hrs = c(0,60,180,360), dys = c(0,15,25,35))
output$table <- renderTable(head(dataDF))
#This changes the X axis scale and works well
colsel <- reactive({
switch(input$timeScale,
"Minutes" = 13,
"Hours" = 14,
"Days" = 15)
})
dataT <- reactive({
df <-dataDF[, 3:8]
df$runTime = pull(dataDF, colsel())
df
})
#A control table output to make sure tibble transformation worked (it works!)
output$dataSummary <- renderTable({
head(dataT())})
#Create a list of plots to be drawn from the checkboxes
plots <- reactive({
paste(input$whichPlot, sep = ",")
})
#save all the plots to individual objects to be chosen from later
airChart <- reactive({
ggplot(dataT(), aes(x = runTime, y = airflow))+
geom_line(size = 1, color = "#00B388")+
labs(x = paste("Runtime in",input$timeScale), y = "Air flow [L/min]")+
scale_x_continuous(breaks = breaks_extended(n = 10))+
ylim(0, 1)
})
tempChart <- reactive({
ggplot (dataT(), aes(runTime, temp))+
geom_line(size = 1, color = "#00B388")+
labs(x = paste("Runtime in",input$timeScale), y = expression(paste("Temperature [", degree, "C]")))+
scale_x_continuous(breaks = breaks_extended(n = 10))+
ylim(15, 45)
})
airsat <- reactive({
ggplot(dataT(), aes(runTime, pO2))+
geom_line(size = 1, color = "#00B388")+
labs(x = paste("Runtime in",input$timeScale), y = "%O2 saturation")+
scale_x_continuous(breaks = breaks_extended(n = 10))+
ylim(80, 100)
})
phChart <- reactive({
ggplot(dataT(), aes(runTime, pH))+
geom_line(size = 1, color = "#00B388")+
labs(x = paste("Runtime in",input$timeScale), y = "pH")+
scale_x_continuous(breaks = breaks_extended(n = 10))+
ylim(1,15)
})
O2Chart <- reactive({
ggplot(dataT(), aes(runTime, O2flow))+
geom_line(size = 1, color = "#00B388")+
labs(x = paste("Runtime in",input$timeScale), y = "O2 flow [L/min]")+
scale_x_continuous(breaks = breaks_extended(n = 10))+
ylim(0,10)
})
pressureChart <- reactive({
ggplot(dataT(), aes(runTime, pressure))+
geom_line(size = 1, color = "#00B388")+
labs(x = paste("Runtime in",input$timeScale), y = "Pressure [mbar]")+
scale_x_continuous(breaks = breaks_extended(n = 10))+
ylim(0,220)
})
#Plot my charts
observeEvent(input$DoIt,{
output$plot <- renderPlot({
(plot_grid(plots(), ncol = 2, labels = "auto"))
})
})
}
shinyApp(ui = ui, server = server)
When I try to use it, I get an error
Warning in as_grob.default(plot) :
Cannot convert object of class character into a grob.
Warning in grid.echo.recordedplot(dl, newpage, prefix) :
No graphics to replay
If I replace the last line with
output$plot <- renderPlot({
(plot_grid(tempChart(), airsat(), O2Chart(), pressureChart(), ncol = 2, labels = "auto"))
it works just fine. I'm not sure if there's a way to bypass the character to grob issue or if I'm making it unnecessarily too difficult. I looked at other solutions with if (which I don't fully understand) but I don't think they'll help here. It's my first contact with Shiny, so don't be too harsh please.
I'd use a different strategy here. Instead of storing every plot separately in a reactive, you can store them all in one list. Here I used a reactiveValues object that gets updated via an observeEvent. (In principal, you could even use a simple list to store the plots, because in your case the reactivity comes from the observeEvent. Using reactiveValues allows you to use single plots outside the cowplot with reactivity.)
Then you can use input$whichPlot just to index the list of plots. Also, putting an output$plot <- renderPlot inside an observeEvent isn't usually considered good practice, because renderPlot itself already has reactivity.
In order to only update the plot when input$DoIt is pressed, I use the bindEvent from the brand new shiny 1.6.0.
library(shiny)
library(cowplot)
library(ggplot2)
library(scales)
library(dplyr)
ui <- fluidPage(
titlePanel("Title"),
sidebarLayout(
sidebarPanel(
#Select which plots will be displayed
checkboxGroupInput(inputId = "whichPlot",
label = "Select data to plot",
choices = c("Temperature" = "temperature",
"Pressure" = "pressure",
"Dissolved Oxygen" = "dissolved_oxygen",
"pH" = "ph",
"Air flow" = "air_flow",
"Oxygen flow" = "oxygen_flow"),
selected = "Temperature"),
#Select time scale
selectInput("timeScale",
"Choose time scale to plot",
choices = c("Minutes",
"Hours",
"Days"),
selected = "Minutes"),
#Apply button to make graphs
actionButton("DoIt", "Plot data"),
br(),
),
mainPanel(
plotOutput("plot"),
#the outputs below are not necessary, I just use them to see if I'm going in the right direction
textOutput("tableTitle"),
tableOutput("table"),
textOutput("selection"),
tableOutput("dataSummary")
)
)
)
server <- function(input, output) {
#A dummy tibble that I use for testing. will be replaced by Load button
dataDF <- tibble(date = c("01/01/2021","01/01/2021","01/01/2021","01/01/2021"), time = c("10:51:02","10:52:02","10:53:02","10:54:02"),
temp = c(20.000,22.000,23.000,24.000), pressure = c(50.000,50.000,50.000,50.000),
pH = c(7.000, 7.230, 7.100, 7.040), pO2 = c(100.000, 90.000, 80.000, 70.000),
airflow = c(1.000,1.000,1.000,1.000), O2flow = c(1.000,1.000,1.000,1.000), user = c("user","user","user","user"),
level = c(3,3,3,3), acid = c("00:00:00","00:00:00","00:00:00","00:00:00"), base =c("00:00:00","00:00:00","00:00:00","00:00:00"),
mins = c(0,2,3,4), hrs = c(0,60,180,360), dys = c(0,15,25,35))
output$table <- renderTable(head(dataDF))
#This changes the X axis scale and works well
colsel <- reactive({
switch(input$timeScale,
"Minutes" = 13,
"Hours" = 14,
"Days" = 15)
})
dataT <- reactive({
df <-dataDF[, 3:8]
df$runTime = pull(dataDF, colsel())
df
})
#A control table output to make sure tibble transformation worked (it works!)
output$dataSummary <- renderTable({
head(dataT())})
# initialise reactiveValues object
plots <- reactiveValues(
temperature = NULL,
pressure = NULL,
dissolved_oxygen = NULL,
ph = NULL,
air_flow = NULL,
oxygen_flow = NULL
)
# the plots only change when dataT or input$timeScale changes
observeEvent(c(dataT(), input$timeScale), {
plots$temperature <- ggplot (dataT(), aes(runTime, temp))+
geom_line(size = 1, color = "#00B388")+
labs(x = paste("Runtime in",input$timeScale), y = expression(paste("Temperature [", degree, "C]")))+
scale_x_continuous(breaks = breaks_extended(n = 10))+
ylim(15, 45)
plots$pressure <- ggplot(dataT(), aes(runTime, pressure))+
geom_line(size = 1, color = "#00B388")+
labs(x = paste("Runtime in",input$timeScale), y = "Pressure [mbar]")+
scale_x_continuous(breaks = breaks_extended(n = 10))+
ylim(0,220)
plots$dissolved_oxygen <- ggplot(dataT(), aes(runTime, pO2))+
geom_line(size = 1, color = "#00B388")+
labs(x = paste("Runtime in",input$timeScale), y = "%O2 saturation")+
scale_x_continuous(breaks = breaks_extended(n = 10))+
ylim(80, 100)
plots$ph <- ggplot(dataT(), aes(runTime, pH))+
geom_line(size = 1, color = "#00B388")+
labs(x = paste("Runtime in",input$timeScale), y = "pH")+
scale_x_continuous(breaks = breaks_extended(n = 10))+
ylim(1,15)
plots$air_flow <- ggplot(dataT(), aes(x = runTime, y = airflow))+
geom_line(size = 1, color = "#00B388")+
labs(x = paste("Runtime in",input$timeScale), y = "Air flow [L/min]")+
scale_x_continuous(breaks = breaks_extended(n = 10))+
ylim(0, 1)
plots$oxygen_flow <- ggplot(dataT(), aes(runTime, O2flow))+
geom_line(size = 1, color = "#00B388")+
labs(x = paste("Runtime in",input$timeScale), y = "O2 flow [L/min]")+
scale_x_continuous(breaks = breaks_extended(n = 10))+
ylim(0,10)
})
output$plot <- renderPlot({
premade_plots <- reactiveValuesToList(plots)
do.call("plot_grid", c(premade_plots[input$whichPlot],
ncol = 2, labels = "auto"))
}) %>%
bindEvent(input$DoIt)
}
shinyApp(ui = ui, server = server)
Check if this helps
library(shiny)
library(tidyverse)
ui <- fluidPage(
checkboxGroupInput("grp", "Select", choices = NULL),
plotOutput("plot")
)
server <- function(input, output, session) {
tibble(x = 1:10,
y1 = sample(1:10),
y2 = sample(1:10),
y3 = sample(1:10),
y4 = sample(1:10)) %>%
pivot_longer(-x) -> df
observe({
updateCheckboxGroupInput(session, "grp", "Select",
choices = unique(df$name),
selected = unique(df$name)[1])
})
output$plot <- renderPlot({
df %>%
filter(name == req(input$grp)) %>%
ggplot(aes(x, value)) +
geom_col() +
facet_wrap(~name, ncol = 1)
})
}
shinyApp(ui, server)
I am trying to create interactive plots with Shiny where the user can select faceting variables. I also want to plot temperature data underneath the point/line data. This all works fine until I try to incorporate a reactive faceting function AND add a geom_rect call, when I get the error:
Warning: Error in : Assigned data `layout$PANEL[match(keys$x, keys$y)]` must be compatible with existing data.
x Existing data has 1094 rows.
x Assigned data has 32 rows.
i Only vectors of size 1 are recycled.
I'm assuming that I've done something wrong with my faceting function, but I'm on week 2 of being unable to solve this issue, so it's time to ask for help!
Here is a simplified mock-up of the app. I can add two facets, OR I can add the temperature underlay, but trying both results in the error above.
library(shiny)
library(shinydashboard)
library(lubridate)
library(tidyr)
library(readr)
{ # Setup ----
# Create a dummy data frame
sitename <- rep(c("A", "B", "C", "D", "E", "F", "G", "H"), times = 4)
region <- rep(c("North", "South", "East", "West"), times = 8)
elevation <- rep(c("High", "Low"), each = 4, length.out = 32)
date <- as.Date(rep(c("2015-01-01", "2016-01-01", "2017-01-01", "2018-01-01"), each = 8))
affected <- runif(32, min = 0, max = 1)
sitedata <- data.frame(date, sitename, region, elevation, affected)
# Load and process external temperature data
noaacrw <- read_table2("http://coralreefwatch.noaa.gov/product/vs/data/guam.txt", skip = 21)
noaacrw <- noaacrw %>%
mutate(DateStart = as.Date(ISOdate(noaacrw$YYYY, noaacrw$MM, noaacrw$DD))) %>%
mutate(DateEnd = as.Date(DateStart + (as.Date(DateStart) - lag(as.Date(DateStart), default = first(DateStart))))) %>%
mutate(SST_AVG = `SST#90th_HS`) %>%
select(DateStart, DateEnd, SST_AVG) %>%
filter(DateStart > as.Date("2015-01-01")) %>%
filter(DateEnd < as.Date("2018-01-01"))
}
# UI ----
ui <- fluidPage(
fluidRow(
box(
title = "Choose your data", width = 3, solidHeader = TRUE,
selectInput("facet_select", "Select faceting variable:",
choices = list("None" = "none",
"Region" = "region",
"Elevation" = "elevation"),
selected = c("None")),
selectInput("facet2_select", "Select second faceting variable",
choices = list("None" = "none",
"Region" = "region",
"Elevation" = "elevation")),
checkboxInput("show_temp", "Show temperature data", FALSE)
),
box(
title = "See your data output", width = 9, solidHeader = TRUE,
plotOutput("siteplot", height = 500)
)
)
)
And the server side:
server <- function(input, output) {
facet1 <- reactive({
if(input$facet_select == "region"){return(region)}
if(input$facet_select == "elevation"){return(elevation)}
})
facet2 <- reactive({
if(input$facet_select == "region"){return(region)}
if(input$facet_select == "elevation"){return(elevation)}
})
faceter <- reactive({
if(input$facet_select == "none"){return(NULL)}
else if(input$facet_select != "none" & input$facet2_select == "none")
{return(list(facet_grid(facet1() ~ .)))}
else if(input$facet_select != "none" & input$facet2_select != "none")
{return(list(facet_grid(facet1() ~ facet2())))}
})
temperature <- reactive({
if(input$show_temp == FALSE){return(NULL)}
else if(input$show_temp == TRUE){return(list(
geom_rect(data = noaacrw,
aes(xmin = DateStart, xmax = DateEnd, ymin = 0, ymax = Inf, fill = SST_AVG),
position = "identity", show.legend = TRUE, alpha = 0.5),
scale_fill_gradient2(high = "red3", mid = "white", low = "blue3", midpoint = 28)))}
})
output$siteplot <- renderPlot({
ggplot()+
temperature()+
geom_point(data = sitedata, aes(x = date, y = affected, group = sitename, color = sitename), size = 3)+
geom_line(data = sitedata, aes(x = date, y = affected, group = sitename, color = sitename), size = 3)+
#facet_grid(elevation ~ region) <-- this works!
faceter() # <- but this does not!
})
}
# Run the application
shinyApp(ui = ui, server = server)
Here is my take (I used syms(...)). It works under R4.0, at least:
library(shiny)
library(shinydashboard)
library(lubridate)
library(tidyr)
library(readr)
library(ggplot2)
library(dplyr)
{ # Setup ----
# Create a dummy data frame
sitename <- rep(c("A", "B", "C", "D", "E", "F", "G", "H"), times = 4)
region <- rep(c("North", "South", "East", "West"), times = 8)
elevation <- rep(c("High", "Low"), each = 4, length.out = 32)
date <- as.Date(rep(c("2015-01-01", "2016-01-01", "2017-01-01", "2018-01-01"), each = 8))
affected <- runif(32, min = 0, max = 1)
sitedata <- data.frame(date, sitename, region, elevation, affected)
# Load and process external temperature data
noaacrw <- read_table2("http://coralreefwatch.noaa.gov/product/vs/data/guam.txt", skip = 21)
noaacrw <- noaacrw %>%
mutate(DateStart = as.Date(ISOdate(noaacrw$YYYY, noaacrw$MM, noaacrw$DD))) %>%
mutate(DateEnd = as.Date(DateStart + (as.Date(DateStart) - lag(as.Date(DateStart), default = first(DateStart))))) %>%
mutate(SST_AVG = `SST#90th_HS`) %>%
select(DateStart, DateEnd, SST_AVG) %>%
filter(DateStart > as.Date("2015-01-01")) %>%
filter(DateEnd < as.Date("2018-01-01"))
}
# UI ----
ui <- fluidPage(
fluidRow(
box(
title = "Choose your data", width = 3, solidHeader = TRUE,
selectInput("facet_select", "Select faceting variable:",
choices = list("None" = NULL,
"Region" = "region",
"Elevation" = "elevation"),
selected = c("None"),
multiple = TRUE),
checkboxInput("show_temp", "Show temperature data", FALSE)
),
box(
title = "See your data output", width = 9, solidHeader = TRUE,
plotOutput("siteplot", height = 500)
)
)
)
server <- function(input, output) {
temperature <- reactive({
if(!input$show_temp){return(NULL)}
else if(input$show_temp){return(list(
geom_rect(data = noaacrw,
aes(xmin = DateStart, xmax = DateEnd, ymin = 0, ymax = Inf, fill = SST_AVG),
position = "identity", show.legend = TRUE, alpha = 0.5),
scale_fill_gradient2(high = "red3", mid = "white", low = "blue3", midpoint = 28)))}
})
makePlot <- function(...){
p <- ggplot()+
temperature()+
geom_point(data = sitedata, aes(x = date, y = affected, group = sitename, color = sitename), size = 3)+
geom_line(data = sitedata, aes(x = date, y = affected, group = sitename, color = sitename), size = 3)
if(length(eval(substitute(alist(...)))) > 0){
p <- p + facet_grid(syms(...))
}
return(p)
}
output$siteplot <- renderPlot({
makePlot(input$facet_select)
})
}
# Run the application
shinyApp(ui = ui, server = server)
I am developing a Shiny app to interactively display a bubbleplot using ggplot2, and I would like to add plotly functionality to it. The following creates data for a reproducible example:
# Load packages
library(shiny)
library(shinythemes)
library(tidyverse)
# create data
Name <- c(rep(c("Red Pine", "Sugar Maple"), each = 125))
mean.SDI <- c(rnorm(250, 150, 150))
mean.SDI <- mean.SDI + abs(min(mean.SDI))
DI <- c(rep(c(rep(c(1:5), 25)), 2))
PI <- c(rep(c(rep(c(1:5), each = 25)), 2))
GrowthRate <- c(rnorm(250, 2.5, 1))
GrowthRate[GrowthRate < 0] <- 0
n <- as.integer(runif(250, min = 1, max = 50))
trend_data <- tibble(Name, mean.SDI, DI, PI, GrowthRate, n)
The following script that DOES NOT use plotly produces the desired result:
# Define UI
ui <- fluidPage(theme = shinytheme("lumen"),
titlePanel("Growth rates"),
sidebarLayout(
sidebarPanel(
selectInput(inputId = "Species", label = strong("Species"),
choices = unique(trend_data$Name)[order(unique(trend_data$Name))],
selected = "Red Pine"),
sliderInput(inputId = "SDI", label = strong("Stand density index"),
min = 0, max = 1100, value = c(0, 800), dragRange = TRUE)
),
mainPanel(
fluidRow(column(6, plotOutput(outputId = "bubbleplot", height = "400px", width = "600px"))
)
)
)
)
# Define server function
server <- function(input, output) {
# Subset data
DI_PI <- reactive({
trend_data %>%
filter(
Name == input$Species,
mean.SDI >= input$SDI[1] & mean.SDI <= input$SDI[2]
) %>%
group_by(DI, PI) %>%
summarize(GrowthRate = mean(GrowthRate),
n = as.numeric(sum(n))) %>%
mutate(nAlpha = n > 50)
})
# Create scatterplot object the plotOutput function is expecting
output$bubbleplot <- renderPlot({
p <- ggplot(DI_PI(), aes(x = DI, y = PI, size = GrowthRate, alpha = nAlpha)) +
geom_point(col = '#236AB9') +
xlab("DI Class") +
ylab("PI Class") +
coord_cartesian(xlim = c(1, 5), ylim = c(1,5)) +
scale_size_continuous(name = "Subplot-level Growth Rate \n (ft2 per acre per year)",
range = c(0.1, 15)) +
scale_alpha_discrete(labels = c("Less than 50 subplots", "At least 50 subplots"),
name = "")
print(p)
})
}
# Create Shiny object
shinyApp(ui = ui, server = server)
However, when I add plotly to this (because I want the plots to be interactive), I lose the size legend:
# Define UI
ui <- fluidPage(theme = shinytheme("lumen"),
titlePanel("Growth rates"),
sidebarLayout(
sidebarPanel(
selectInput(inputId = "Species", label = strong("Species"),
choices = unique(trend_data$Name)[order(unique(trend_data$Name))],
selected = "Red Pine"),
sliderInput(inputId = "SDI", label = strong("Stand density index"),
min = 0, max = 1100, value = c(0, 800), dragRange = TRUE)
),
mainPanel(
fluidRow(column(6, plotlyOutput(outputId = "bubbleplot", height = "400px", width = "600px"))
)
)
)
)
# Define server function
server <- function(input, output) {
# Subset data
DI_PI <- reactive({
trend_data %>%
filter(
Name == input$Species,
mean.SDI >= input$SDI[1] & mean.SDI <= input$SDI[2]
) %>%
group_by(DI, PI) %>%
summarize(GrowthRate = mean(GrowthRate),
n = as.numeric(sum(n))) %>%
mutate(nAlpha = n > 50)
})
# Create scatterplot object the plotOutput function is expecting
output$bubbleplot <- renderPlotly({
p <- ggplot(DI_PI(), aes(x = DI, y = PI, size = GrowthRate, alpha = nAlpha)) +
geom_point(col = '#236AB9') +
xlab("DI Class") +
ylab("PI Class") +
coord_cartesian(xlim = c(1, 7), ylim = c(1,5)) +
scale_size_continuous(name = "Subplot-level Growth Rate \n (ft2 per acre per year)",
range = c(0.1, 15)) +
scale_alpha_discrete(labels = c("Less than 5 subplots", "At least 5 subplots"),
name = "")
ggplotly(p)
})
}
# Create Shiny object
shinyApp(ui = ui, server = server)
It seems that ggplotly has had issues with displaying legends. Is anyone aware of a good solution to this for the "scale_size" type of legends?
Using RStudio version 1.1.453 and plotly v 4.8.0
R info:
platform x86_64-w64-mingw32
arch x86_64
os mingw32
system x86_64, mingw32
status
major 3
minor 5.0
year 2018
month 04
day 23
svn rev 74626
language R
version.string R version 3.5.0 (2018-04-23)
nickname Joy in Playing
********EDIT: tried removing "alpha" aesthetic to restrict to only one legend (for "size"), but now there is no legend plotted at all:
# EDIT server function
server <- function(input, output) {
# Subset data
DI_PI <- reactive({
trend_data %>%
filter(
Name == input$Species,
mean.SDI >= input$SDI[1] & mean.SDI <= input$SDI[2]
) %>%
group_by(DI, PI) %>%
summarize(GrowthRate = mean(GrowthRate),
n = as.numeric(sum(n))) %>%
mutate(nAlpha = n > 50)
})
# Create scatterplot object the plotOutput function is expecting
output$bubbleplot <- renderPlotly({
p <- ggplot(DI_PI(), aes(x = DI, y = PI,
#alpha = nAlpha,
size = GrowthRate)) +
geom_point(col = '#236AB9') +
xlab("DI Class") +
ylab("PI Class") +
coord_cartesian(xlim = c(1, 7), ylim = c(1,5)) +
scale_size_continuous(name = "Subplot-level Growth Rate \n (ft2 per acre per year)",
range = c(0.1, 15)) #+
#scale_alpha_discrete(labels = c("Less than 5 subplots", "At least 5 subplots"),
#name = "")
ggplotly(p)
})
}
# Create Shiny object
shinyApp(ui = ui, server = server)
I'm trying to understand how ggvis works in the context of shiny and it's been a real headache. At this point I'm just trying to make something, anything interactive. Ideally I would like to be able to filter data points with sliders and be able to click on sectors and links to zoom and highlight respectively.
Ignoring the entire right bar, how would I be able to implement ggvis?
server.r
options(shiny.maxRequestSize=60*1024^2)
# Option to use scientific notation
options(scipen=999)
library(ggplot2)
library(ggvis)
shinyServer(function(input, output) {
inputData <- try(reactive({
inFile <- input$file1
if(is.null(inFile$datapath)){
return(iris)
}
newData <- read.csv(inFile$datapath, fill=TRUE)
newData
}))
output$choose_histVar <- renderUI({
newData <- inputData()
nameDataNew1<-c("ALL" ,"Earmarks", "Free-Cash")
if(class(nameDataNew1)!="try-error"){
selectInput("histVar", "1. Select Funding", as.list(nameDataNew1),
multiple = FALSE)
}
else{
selectInput("histVar", "1.Select Funding", NULL, multiple = FALSE)
}
})
# Use renderTable() function to render a table
output$summaryTable <- renderTable({ summary( try(inputData()) ) })
output$plot.hist <- renderPlot({
plotHistograms(data=try(inputData()), getCol=input$histVar,
getBin=input$bins)
})
output$plot.bar <- renderPlot({ plotcir(data)})
})
plotcir <- function(data) {
set.seed(999)
n = 1000
df = data.frame(factors = sample(letters[1:8], n, replace = TRUE),
x = rnorm(n), y = runif(n))
data.temp <- as.data.frame(df)
circos.par("track.height" = 0.1)
circos.initialize(factors = df$factors, x = df$x)
circos.track(factors = df$factors, y = df$y,
panel.fun = function(x, y) {
circos.text(CELL_META$xcenter, CELL_META$cell.ylim[2] + uy(5,
"mm"),
CELL_META$sector.index)
circos.axis(labels.cex = 0.6)
})
col = rep(c("#FF0000", "#00FF00"), 4)
circos.trackPoints(df$factors, df$x, df$y, col = col, pch = 16, cex = 0.5)
circos.text(-1, 0.5, "text", sector.index = "a", track.index = 1)
bgcol = rep(c("#EFEFEF", "#CCCCCC"), 4)
circos.trackHist(df$factors, df$x, bin.size = 0.2, bg.col = bgcol, col = NA)
circos.track(factors = df$factors, x = df$x, y = df$y,
panel.fun = function(x, y) {
ind = sample(length(x), 10)
x2 = x[ind]
y2 = y[ind]
od = order(x2)
circos.lines(x2[od], y2[od])
})
##vis <- reactive({})
circos.link("a", 0, "b", 0, h = 0.4)
circos.link("c", c(-0.5, 0.5), "d", c(-0.5,0.5), col = "red",
border = "blue", h = 0.2)
circos.link("e", 0, "g", c(-1,1), col = "green", border = "black", lwd = 2,
lty = 2)
}
ui.r
# Load libraries used in this Shiny App
library(shiny)
library(ggplot2)
library(circlize)
library(ggvis)
library(shinythemes)
shinyUI(fluidPage(
titlePanel(title = h2("The Wall", align="center")),
theme = shinytheme("cyborg"),
sidebarPanel(
fileInput('file1', 'The default dataset is df data. You may choose your own
CSV file'),
sliderInput('file1', 'Mission 1', value = 10, min = 0, max = 100, step = 1,
post = "%"),
sliderInput('file1', 'Mission 2', value = 0, min = 0, max = 100, step = 1,
post = "%"),
sliderInput('file1', 'Mission 3', value = 0, min = 0, max = 100, step = 1,
post = "%"),
sliderInput('file1', 'Mission 4', value = 0, min = 0, max = 100, step = 1,
post = "%"),
sliderInput('file1', 'Mission 5', value = 0, min = 0, max = 100, step = 1,
post = "%"),
uiOutput("choose_histVar"),
uiOutput("choose_xVar"),
uiOutput("choose_yVar"),
uiOutput("choose_cateVar"),
uiOutput("choose_barVar"),
p()
),
mainPanel(
h3('DOS - Augmented decisions'),
tabsetPanel(type="tab",
tabPanel( "Optimal",
plotOutput('plot.bar')
),
tabPanel("Histogram",
h4(checkboxInput("showHideHistograms", "Show/hide histograms",
value=FALSE)),
# Add a conditional panel to plot the histogram only when "Show
histogram" is checked
conditionalPanel(
condition = "input.showHideHistograms",
# Use plotOutput function to plot the output visualization
plotOutput('plot.hist')
)
)
),
p('')
)
))