shiny checkboxGroupInput ggplots as list - r

Could anyone suggest me the way to extract shiny checkboxgroupoinput options of different ggplots such as geom_bar(), geom_line() as a list. I tried the following simplified code, it prints only the last plot: Thanks for your help.
library(shiny)
library(ggplot2)
library(easyGgplot2)
patient <- cbind.data.frame(seq(1:14),matrix(sample(1:100, 84), ncol=6))
colnames(patient) <- c('DAYS', 'PHYSICAL_ACTIVITY', 'SMOKING','ALCOHOL_INTAKE', 'HYDRATION', 'SLEEP', 'Total_score')
ui <- fluidPage(
titlePanel("Data Plot"),
sidebarLayout(
sidebarPanel(
fluidRow(column(6,
checkboxGroupInput("checkGroup",
("Parameters"),
list("PHYSICAL ACTIVITY" = 1,
"SLEEP" = 2,
"ALCOHOL INTAKE" = 3,
"SELECT ALL" = 4
)))
),
fluidRow(column(10, actionButton("goButton", label = "Analysis Report"))
)
), #Sidebarpanel
mainPanel(
plotOutput("plot1", height='800px')
)#Mainpanel
) #Sidebar layout
)#fluidpage
server <- function(input, output) {
output$plot1 <- renderPlot({
input$goButton
p1 <- reactive({
if(!(1 %in% input$checkGroup)) return(NULL)
ggplot(data=patient, aes(x=DAYS, y=PHYSICAL_ACTIVITY))+geom_bar(stat="identity", aes(fill=PHYSICAL_ACTIVITY<=median(PHYSICAL_ACTIVITY)), show.legend=F)+scale_fill_manual(values = c('steelblue', 'red') )+labs(title = 'PHYSICAL ACTIVITY (STEPS)', x = NULL, y = NULL)+theme_minimal()
})
# Second plot
p2 <- reactive ({
if(!(2 %in% input$checkGroup )) return(NULL)
p2 <- ggplot(data=patient, aes(x=DAYS,y=SLEEP))+geom_line(colour='black', size=1)+geom_point(size=3, aes(colour=cut(SLEEP,c(-Inf,summary(SLEEP)[[2]],summary(SLEEP)[[5]],Inf))), show.legend=F)+scale_color_manual(values = c("red", "orange","green"))+labs(title = 'SLEEP (hrs)', x = NULL, y = NULL) +theme_minimal()
})
ptlist <- list(p1(),p2())
ggplot2.multiplot(ptlist, cols=1)
})
}
shinyApp(ui, server)

Example with reading csv.
library(shiny)
library(ggplot2)
library(easyGgplot2)
patient <- cbind.data.frame(
seq(1:14),
matrix(
sample(1:100, 84),
ncol = 6
)
)
colnames(patient) <- c(
'DAYS',
'PHYSICAL_ACTIVITY',
'SMOKING',
'ALCOHOL_INTAKE',
'HYDRATION',
'SLEEP',
'Total_score'
)
write.csv(patient, file="patient.csv")
ui <- fluidPage(
titlePanel("Data Plot"),
sidebarLayout(
sidebarPanel(
fluidRow(
column(6,
checkboxGroupInput(
"checkGroup",
"Parameters",
list(
"PHYSICAL ACTIVITY",
"SLEEP"),
selected = "PHYSICAL ACTIVITY")
)
),
fluidRow(
fileInput("file1", "Choose Data sheet",
multiple = TRUE,
accept = c("text/csv",
"text/comma-separated-values,text/plain",
".csv"))
)
),
mainPanel(
plotOutput("plots")
)
)
)
server <- function(input, output) {
patient <- reactive({
req(input$file1)
read.csv(input$file1$datapath,
header = T
)
})
plot_one <- function(patient.data) {
ggplot(patient.data, aes(x = DAYS, y = PHYSICAL_ACTIVITY)) +
geom_bar(
stat = "identity",
aes(fill = PHYSICAL_ACTIVITY <= median(PHYSICAL_ACTIVITY)),
show.legend = F) +
scale_fill_manual(
values = c('steelblue', 'red')) +
labs(title = 'PHYSICAL ACTIVITY (STEPS)',
x = NULL,
y = NULL) +
theme_minimal()
}
plot_two <- function(patient.data){
ggplot(patient.data, aes(x = DAYS, y = SLEEP)) +
geom_line(colour = 'black', size = 1) +
geom_point(size = 3,
aes(colour = cut(SLEEP,
c(-Inf,
summary(SLEEP)[[2]],
summary(SLEEP)[[5]],
Inf)
)
),
show.legend = F) +
scale_color_manual(values = c("red", "orange", "green")) +
labs(title = 'SLEEP (hrs)',
x = NULL,
y = NULL) +
theme_minimal()
}
output$plots <- renderPlot({
list.of.plots <- list(
`PHYSICAL ACTIVITY` = plot_one(patient()),
`SLEEP` = plot_two(patient())
)
do.call(ggplot2.multiplot, c(list.of.plots[input$checkGroup], cols=1))
})
}
shinyApp(ui, server)

It will work if replace ggplot2.multiplot(ptlist, cols=1) by do.call(ggplot2.multiplot, c(ptlist, cols=1))
But may be to do this with ggplot function in reactive is not a good way to achieve your goal.
You could to try something like this
library(shiny)
library(ggplot2)
library(easyGgplot2)
patient <- cbind.data.frame(
seq(1:14),
matrix(
sample(1:100, 84),
ncol = 6
)
)
colnames(patient) <- c(
'DAYS',
'PHYSICAL_ACTIVITY',
'SMOKING',
'ALCOHOL_INTAKE',
'HYDRATION',
'SLEEP',
'Total_score'
)
ui <- fluidPage(
titlePanel("Data Plot"),
sidebarLayout(
sidebarPanel(
fluidRow(
column(6,
checkboxGroupInput(
"checkGroup",
"Parameters",
list(
"PHYSICAL ACTIVITY",
"SLEEP"),
selected = "PHYSICAL ACTIVITY")
)
)
),
mainPanel(
plotOutput("plots")
)
)
)
server <- function(input, output) {
plot_one <- ggplot(data = patient, aes(x = DAYS, y = PHYSICAL_ACTIVITY)) +
geom_bar(
stat = "identity",
aes(fill = PHYSICAL_ACTIVITY <= median(PHYSICAL_ACTIVITY)),
show.legend = F) +
scale_fill_manual(
values = c('steelblue', 'red')) +
labs(title = 'PHYSICAL ACTIVITY (STEPS)',
x = NULL,
y = NULL) +
theme_minimal()
plot_two <- ggplot(data = patient, aes(x = DAYS, y = SLEEP)) +
geom_line(colour = 'black', size = 1) +
geom_point(size = 3,
aes(colour = cut(SLEEP,
c(-Inf,
summary(SLEEP)[[2]],
summary(SLEEP)[[5]],
Inf)
)
),
show.legend = F) +
scale_color_manual(values = c("red", "orange", "green")) +
labs(title = 'SLEEP (hrs)',
x = NULL,
y = NULL) +
theme_minimal()
list.of.plots <- list(
`PHYSICAL ACTIVITY` = plot_one,
`SLEEP` = plot_two
)
output$plots <- renderPlot(
do.call(ggplot2.multiplot, c(list.of.plots[input$checkGroup], cols=1))
)
}
shinyApp(ui, server)

library(shiny)
library(ggplot2)
library(easyGgplot2)
patient <- cbind.data.frame(
seq(1:14),
matrix(
sample(1:100, 84),
ncol = 6
)
)
colnames(patient) <- c(
'DAYS',
'PHYSICAL_ACTIVITY',
'SMOKING',
'ALCOHOL_INTAKE',
'HYDRATION',
'SLEEP',
'Total_score'
)
write.csv(patient, file="patient.csv")
ui <- fluidPage(
titlePanel("Data Plot"),
sidebarLayout(
sidebarPanel(
fluidRow(
column(6,
checkboxGroupInput(
"checkGroup",
"Parameters",
list(
"PHYSICAL ACTIVITY",
"SLEEP"),
selected = "PHYSICAL ACTIVITY")
)
),
fluidRow(
fileInput("file1", "Choose Data sheet",
multiple = TRUE,
accept = c("text/csv",
"text/comma-separated-values,text/plain",
".csv"))
)
),
mainPanel(
plotOutput("plots")
)
)
)
server <- function(input, output) {
patient <- reactive({
req(input$file1)
read.csv(input$file1$datapath,
header = T
)
})
plot_one <- ggplot(data = patient(), aes(x = DAYS, y = PHYSICAL_ACTIVITY)) +
geom_bar(
stat = "identity",
aes(fill = PHYSICAL_ACTIVITY <= median(PHYSICAL_ACTIVITY)),
show.legend = F) +
scale_fill_manual(
values = c('steelblue', 'red')) +
labs(title = 'PHYSICAL ACTIVITY (STEPS)',
x = NULL,
y = NULL) +
theme_minimal()
plot_two <- ggplot(data = patient(), aes(x = DAYS, y = SLEEP)) +
geom_line(colour = 'black', size = 1) +
geom_point(size = 3,
aes(colour = cut(SLEEP,
c(-Inf,
summary(SLEEP)[[2]],
summary(SLEEP)[[5]],
Inf)
)
),
show.legend = F) +
scale_color_manual(values = c("red", "orange", "green")) +
labs(title = 'SLEEP (hrs)',
x = NULL,
y = NULL) +
theme_minimal()
list.of.plots <- list(
`PHYSICAL ACTIVITY` = plot_one,
`SLEEP` = plot_two
)
output$plots <- renderPlot(
do.call(ggplot2.multiplot, c(list.of.plots[input$checkGroup], cols=1))
)
}
shinyApp(ui, server)

Related

Select current plot and download to file

How can I save the current plot that is displayed on the mainPanel? I am having trouble pointing the correct graphic to the download Handler. This is what I have:
library(shiny)
library(ggplot2)
library(tidyverse)
library(shinythemes)
library(plotly)
library(scales)
library(shinyWidgets)
library(shinydashboard)
library(shinyjs)
# Define input choices
type <- c("first", "second")
#Data for lambda
table <- structure(list(year = 1991:2010, lambda = c(0.68854, 0.75545,
1.63359, 1.22282, 1.70744, 1.09692, 0.51159, 1.3904, 1.09132,
0.59846, 0.43055, 0.80135, 0.69027, 0.65646, 0.95485, 1.04818,
0.67859, 1.00461, 1.16665, 1.28203)), row.names = c(NA, -20L), class = "data.frame")
ui <- fluidPage(
useShinyjs(), # to initialise shinyjs
navbarPage("Test",
windowTitle = "A Test",
sidebarPanel(
h3(""),
#Dropdown to select the desired kind of graphic
selectInput(inputId = "graphtype",
label = "Graphic",
choices = type,
selected = "first"),
disabled( #start as disabled
checkboxInput("Fixed","Fixed Y axes", FALSE))),
downloadButton('downloadPlot', 'Download Plot'),
#Graphic Area mainPanel. Graphic on top and table right below it
mainPanel(plotOutput("plot"),
dataTableOutput("mytable"))
))
###################################################################################################
server<- function (input, output, session) {
session$onSessionEnded(function() {
stopApp()
})
#Plot data
output$plot <- renderPlot({
xlabels <- 1991:2011
switch(input$graphtype,
"first" = {
disable("Fixed")
print(ggplot(table,aes(year,lambda)) + geom_line(size=1.5,colour="blue") + geom_point(colour="orange",size=4) +
scale_x_continuous("",breaks = xlabels) +
theme(axis.text.x = element_text(angle = 45, vjust = 0.5)) +
labs(x="",y="test",title= paste0("Population growth rate of Fish ")))
},
{
enable("Fixed")
if(input$Fixed == FALSE){
"second" <- print(ggplot(table,aes(year,lambda)) + geom_line(size=1.5,colour="red") + geom_point(colour="green",size=4) +
scale_x_continuous("",breaks = xlabels) +
theme(axis.text.x = element_text(angle = 45, vjust = 0.5)) +
labs(x="",y="fish test",title= paste0("Population growth")))
}
else{
"second" <- print(ggplot(table,aes(year,lambda)) + geom_line(size=1.5,colour="yellow") + geom_point(colour="green",size=4) +
scale_x_continuous("",breaks = xlabels) +
theme(axis.text.x = element_text(angle = 45, vjust = 0.5)) +
labs(x="",y="fish test",title= paste0("Population growth")))
}
}
)
output$downloadPlot <- downloadHandler(
filename = "plot.png" ,
content = function(file) {
ggsave(plot(), filename = file)
})
})
}
shinyApp(ui = ui, server = server)
One option would be to move your plotting code to a reactive. This way you could print your plot inside renderPlot but also pass the plot to the ggsave inside the downloadHandler. Additionally I cleaned up the code to switch between the plots a little bit.
Note: I moved the download button to the sidebar because otherwise it would not work. Also, I made the code more minimal by removing all the unnecessary packages and code.
library(shiny)
library(ggplot2)
# Define input choices
type <- c("first", "second")
# Data for lambda
table <- structure(list(year = 1991:2010, lambda = c(
0.68854, 0.75545,
1.63359, 1.22282, 1.70744, 1.09692, 0.51159, 1.3904, 1.09132,
0.59846, 0.43055, 0.80135, 0.69027, 0.65646, 0.95485, 1.04818,
0.67859, 1.00461, 1.16665, 1.28203
)), row.names = c(NA, -20L), class = "data.frame")
ui <- fluidPage(
sidebarPanel(
h3(""),
# Dropdown to select the desired kind of graphic
selectInput(
inputId = "graphtype",
label = "Graphic",
choices = type,
selected = "first"
),
checkboxInput("Fixed", "Fixed Y axes", FALSE),
downloadButton("downloadPlot", "Download Plot")
),
# Graphic Area mainPanel. Graphic on top and table right below it
mainPanel(
plotOutput("plot"),
dataTableOutput("mytable")
)
)
###################################################################################################
server <- function(input, output, session) {
session$onSessionEnded(function() {
stopApp()
})
# Plot data
create_plot <- reactive({
xlabels <- 1991:2011
if (input$graphtype == "first") {
ggplot(table, aes(year, lambda)) +
geom_line(size = 1.5, colour = "blue") +
geom_point(colour = "orange", size = 4) +
scale_x_continuous("", breaks = xlabels) +
theme(axis.text.x = element_text(angle = 45, vjust = 0.5)) +
labs(x = "", y = "test", title = paste0("Population growth rate of Fish "))
} else {
if (!input$Fixed) {
ggplot(table, aes(year, lambda)) +
geom_line(size = 1.5, colour = "red") +
geom_point(colour = "green", size = 4) +
scale_x_continuous("", breaks = xlabels) +
theme(axis.text.x = element_text(angle = 45, vjust = 0.5)) +
labs(x = "", y = "fish test", title = paste0("Population growth"))
} else {
ggplot(table, aes(year, lambda)) +
geom_line(size = 1.5, colour = "yellow") +
geom_point(colour = "green", size = 4) +
scale_x_continuous("", breaks = xlabels) +
theme(axis.text.x = element_text(angle = 45, vjust = 0.5)) +
labs(x = "", y = "fish test", title = paste0("Population growth"))
}
}
})
output$plot <- renderPlot({
create_plot()
})
output$downloadPlot <- downloadHandler(
filename = function() "plot.png",
content = function(file) {
ggsave(create_plot(), filename = file)
}
)
}
shinyApp(ui = ui, server = server)

Shiny App in R: How to connect input and output

I do not know how to connect input (n) in the slider and output (plot). When I move the bottom on the slider in the shinny app, the plot did not change. I am wondering if the output and input did not link together approporatedly.
library(ggplot2)
library(shiny)
plot<-function(x,y,xlim=c(-3,3)){
x <- seq(-4, 4, by=0.01)
norm_dens <- dnorm(x)
t_dens <- dt(x, df = n-1)
df = data.frame(x = x, z = norm_dens, t = t_dens)
ggplot(data = df, aes(x)) +
geom_line(aes(y = z, colour = "z"))+
geom_line(aes(y = t,color = "t"))+
labs(x="x", y = "")+
scale_color_manual(name = "l", values = c("z" = "blue", "t" = "red"))+
coord_cartesian(xlim = xlim)
}
plot(x,y)
## UI function
ui <- fluidPage(
mainPanel(
plotOutput(outputId="plot")),
fluidRow(
column(2,
"Sample Size",
sliderInput("n", label = "n", value = 5, min = 2, max = 100),step=1)
)
)
# Server logic
server <- function(input, output) {
reactive({
df %>%
filter(n %in% input$n)
})
output$plot<-renderPlot({
plot(x,y)
})
}
## Run shiny app
shinyApp(ui, server)
You don't need the reactive here. Try this:
library(ggplot2)
library(shiny)
plot<-function(x,y,xlim=c(-3,3),n){
x <- seq(-4, 4, by=0.01)
norm_dens <- dnorm(x)
t_dens <- dt(x, df = n-1)
df = data.frame(x = x, z = norm_dens, t = t_dens)
ggplot(data = df, aes(x)) +
geom_line(aes(y = z, colour = "z"))+
geom_line(aes(y = t,color = "t"))+
labs(x="x", y = "")+
scale_color_manual(name = "l", values = c("z" = "blue", "t" = "red"))+
coord_cartesian(xlim = xlim)
}
## UI function
ui <- fluidPage(
mainPanel(
plotOutput(outputId="plot")),
fluidRow(
column(2,
"Sample Size",
sliderInput("n", label = "n", value = 5, min = 2, max = 100),step=1)
)
)
# Server logic
server <- function(input, output) {
output$plot<-renderPlot({
req(input$n)
plot(x,y,n=input$n)
})
}
## Run shiny app
shinyApp(ui, server)`enter code here`

Shiny app very slow and RegData error, what in code might be causing this?

I'm trying to run a dashboard on shiny and the end result is incredibly slow, I'm also getting an error when running so i suspect the app might have crashed? any idea what in the code might be causing this?
I just start to code the linear regression I'm not sure about the efficiently of the code.
The plots not appears on the dashboard.
Thank youu
# Define UI ----
ui <- fluidPage(
titlePanel("AirBnb NYC"),
sidebarLayout(
sidebarPanel(
fluidRow(
column(3,
selectInput("select", h3("Which Neighbourhood group ?"), choices =
c("Brooklyn","Manhattan","Queens","Staten Island", "Bronx"))),
column(3,
selectInput("select2", h3("which Neighbourhood ?"), choices = "")),
column(3,
selectInput("select1", h3("Room Type"), choices = ""))),
p("Select the inputs for the Dependent Variable"),
selectInput(inputId = "DepVar", label = "Dependent Variables", multiple = FALSE, choices =
colnames(AB_NYC_2019)),
p("Select the inputs for the Independent Variable"),
selectInput(inputId = "IndVar", label = "Independent Variables", multiple = FALSE,
choices = list( "price"))
),
mainPanel( leafletOutput("map",width = "100%",height = "800"),
fluidRow(column(width = 6, plotOutput("data")),
column(width = 6, plotOutput("plot"))),
verbatimTextOutput(outputId = "RegSum"),
verbatimTextOutput(outputId = "IndPrint"),
verbatimTextOutput(outputId = "DepPrint"))
))
Define server logic ----
server <- function(input, output, session) {
#Define parameters of search
observe({
print(input$select)
x <- AB_NYC_2019 %>% filter(neighbourhood_group == input$select) %>% select(neighbourhood)
updateSelectInput(session, "select2", "select your neighbourhood", choice = unique(x))
})
observe({
productdata <- AB_NYC_2019$room_type[AB_NYC_2019$neighbourhood == input$select2]
updateSelectInput(session, "select1", "Which room type?", choices = unique(productdata))
})
#Create map
color <- colorFactor(palette = c("red", "green", "blue", "purple", "yellow"),
AB_NYC_2019$neighbourhood_group)
filteredData <- reactive({filter(AB_NYC_2019, neighbourhood_group == input$select)})
output$map <- renderLeaflet({
map <- leaflet(filteredData()) %>% addProviderTiles(providers$Esri.WorldTopoMap) %>%
# setView(lng = -73.98928, lat = 40.75042, zoom = 10) %>%
addCircleMarkers(
lng=~longitude, # Longitude coordinates
lat=~latitude, # Latitude coordinates
stroke=TRUE, # Circle stroke
weight = 0.1,
radius = 0.5,
fillOpacity=0.5,
color=~color(neighbourhood_group),
label = paste("Name:", AB_NYC_2019$name, "<br>",
"Price:", AB_NYC_2019$price, "<br>",
"Reviews:", AB_NYC_2019$number_of_reviews, "<br>")) %>%
addLegend("bottomright", pal = color, values = ~neighbourhood_group,
title = "Neighbourhood groups",
opacity = 1
)
})
#filter map
observe({
leafletProxy("map", data = filteredData()) %>%
clearShapes() %>%
addMarkers(~longitude, ~latitude,
label = ~neighbourhood_group,
labelOptions = labelOptions(textsize = "12px"))
})
lm1 <- reactive({lm(reformulate(input$IndVar, input$DepVar), data = RegData)})
output$DepPrint <- renderPrint({input$DepVar})
output$IndPrint <- renderPrint({input$IndVar})
output$RegSum <- renderPrint({summary(lm1())})
#Get many plots
output$data <- renderPlot({
ggplot(AB_NYC_2019, aes(price)) +
geom_histogram(bins = 30, aes(y = ..density..), fill = "purple") +
geom_density(alpha = 0.2, fill = "purple") +
th +
ggtitle("Distribution of price",
subtitle = "The distribution is very skewed") +
theme(axis.title = element_text(), axis.title.x = element_text()) +
geom_vline(xintercept = round(mean(AB_NYC_2019$price), 2), size = 2, linetype = 3)
})
output$plot <- renderPlot({
AB_NYC_2019 %>% filter(price >= mean(price)) %>% group_by(neighbourhood_group, room_type) %>%
tally %>%
ggplot(aes(reorder(neighbourhood_group,desc(n)), n, fill = room_type)) +
th +
xlab(NULL) +
ylab("Number of objects") +
ggtitle("Number of above average price objects",
subtitle = "Most of them are entire homes or apartments") +
geom_bar(stat = "identity")
})
}
Run the app ----
shinyApp(ui = ui, server = server)
Try this
AB_NYC_2019 <- AB_NYC_2019[1:50,]
# Define UI ----
ui <- fluidPage(
titlePanel("AirBnb NYC"),
sidebarLayout(
sidebarPanel(
selectInput("select", h3("Which Neighbourhood group ?"), choices =
c("Brooklyn","Manhattan","Queens","Staten Island", "Bronx")),
selectInput("select2", h3("which Neighbourhood ?"), choices = ""),
selectInput("select1", h3("Room Type"), choices = ""),
p("Select the inputs for the Dependent Variable"),
selectInput(inputId = "DepVar", label = "Dependent Variables", multiple = FALSE, choices =
colnames(AB_NYC_2019)),
p("Select the inputs for the Independent Variable"),
selectInput(inputId = "IndVar", label = "Independent Variables", multiple = FALSE,
choices = list( "price"))
),
mainPanel( leafletOutput("map",width = "100%",height = "800"),
fluidRow(column(width = 6, plotOutput("data")),
column(width = 6, plotOutput("plot"))),
verbatimTextOutput(outputId = "RegSum"),
verbatimTextOutput(outputId = "IndPrint"),
verbatimTextOutput(outputId = "DepPrint"))
)
)
server <- function(input, output, session) {
#Define parameters of search
observe({
req(input$select)
x <- AB_NYC_2019 %>% dplyr::filter(neighbourhood_group == input$select) %>% select(neighbourhood)
updateSelectInput(session, "select2", "select your neighbourhood", choice = unique(x))
})
observe({
req(input$select2)
productdata <- AB_NYC_2019$room_type[AB_NYC_2019$neighbourhood == input$select2]
updateSelectInput(session, "select1", "Which room type?", choices = unique(productdata))
})
#Create map
color <- colorFactor(palette = c("red", "green", "blue", "purple", "yellow"),
unique(AB_NYC_2019$neighbourhood_group))
filteredData <- reactive({
req(input$select)
filter(AB_NYC_2019, neighbourhood_group == input$select)})
output$map <- renderLeaflet({
req(filteredData())
map <- leaflet(filteredData()) %>% addProviderTiles(providers$Esri.WorldTopoMap) %>%
setView(lng = -73.98928, lat = 40.75042, zoom = 10) %>%
addCircleMarkers(
lng=~longitude, # Longitude coordinates
lat=~latitude, # Latitude coordinates
stroke=TRUE, # Circle stroke
weight = 0.1,
radius = 0.5,
fillOpacity=0.5,
color=~color(neighbourhood_group),
label = paste("Name:", filteredData()$name,
"\nPrice:", filteredData()$price,
"\nReviews:", filteredData()$number_of_reviews)
) %>%
addLegend("bottomright", pal = color, values = ~neighbourhood_group,
title = "Neighbourhood groups",
opacity = 1
)
})
#filter map
observe({
req(filteredData())
labs <- lapply(seq(nrow(filteredData())), function(i) {
paste0( '<p> Name: ', filteredData()[i, "name"], '<p></p>', 'Price: ',
filteredData()[i, "price"],'</p><p>', 'Reviews: ',
filteredData()[i, "number_of_reviews"], '</p>' )
})
leafletProxy("map", data = filteredData()) %>%
clearShapes() %>%
addMarkers(~longitude, ~latitude,
label = lapply(labs, htmltools::HTML),
labelOptions = labelOptions(textsize = "12px"))
})
lm1 <- reactive({
req(filteredData())
lm(reformulate(input$IndVar, input$DepVar), data = filteredData())})
output$DepPrint <- renderPrint({input$DepVar})
output$IndPrint <- renderPrint({input$IndVar})
output$RegSum <- renderPrint({
req(lm1())
summary(lm1())})
#Get many plots
output$data <- renderPlot({
ggplot(AB_NYC_2019, aes(price)) +
geom_histogram(bins = 30, aes(y = ..density..), fill = "purple") +
geom_density(alpha = 0.2, fill = "purple") +
theme_bw() +
ggtitle("Distribution of price",
subtitle = "The distribution is very skewed") +
theme(axis.title = element_text(), axis.title.x = element_text()) +
geom_vline(xintercept = round(mean(AB_NYC_2019$price), 2), size = 2, linetype = 3)
})
output$plot <- renderPlot({
AB_NYC_2019 %>% filter(price >= mean(price)) %>% group_by(neighbourhood_group, room_type) %>%
tally %>%
ggplot(aes(reorder(neighbourhood_group,desc(n)), n, fill = room_type)) +
theme_bw() +
xlab(NULL) +
ylab("Number of objects") +
ggtitle("Number of above average price objects",
subtitle = "Most of them are entire homes or apartments") +
geom_bar(stat = "identity")
})
}
shinyApp(ui, server)

Shiny button doesn't work when I click it. Can sb help me?

I want to add 3 different buttons to show different plot but use the same input information.
But now I was trapped in the first step.
when I click the first button which is linked to the first plot but it didn't work.
Can somebody help me to deal with it. Thanks a lot.
Here is my sample code below:
library(shiny)
library(ggplot2)
library(ggpubr)
library(dplyr)
library(tidyr)
#####
mean_data <- data.frame(
Name = c(paste0("Group_", LETTERS[1:20])),
matx <- matrix(sample(1:1000, 1000, replace = T), nrow = 20)
)
names(mean_data)[-1] <- c(paste0("Gene_", 1:50))
sd_data <- data.frame(
Name = c(paste0("Group_", LETTERS[1:20])),
matx <- matrix(runif(1000, 5, 10), nrow = 20)
)
names(sd_data)[-1] <- c(paste0("Gene_", 1:50))
# Prepare dataset.
# 1. Bind mean and sd data
# 2. Reshape
data <- bind_rows(list(
mean = mean_data,
sd = sd_data
), .id = "stat")
data_mean_sd <- data %>%
pivot_longer(-c(Name, stat), names_to = "Gene", values_to = "value") %>%
pivot_wider(names_from = "stat", values_from = "value")
###
ui <- fluidPage(
fluidRow(
column(8,offset = 3,
h2("Gene_FPKM Value Barplot")
)
),
fluidRow(
column(8,offset = 3,
selectInput(
"selectGeneSymbol",
"Select Gene Symbol:",
choices = unique(data_mean_sd$Gene),
multiple =F,
width = 800,
selected = "Igfbp7"
))
),
fluidRow(
column(8,offset = 3,
actionButton(inputId = "FPKM", label = "FPKM"),
actionButton(inputId = "logFC", label = "logFC"),
actionButton(inputId = "logFC&FPKM",label = "logFC&FPKM")
)
),
fluidRow(
column(3)
),
fluidRow(
column(3)
),
fluidRow(
column(12,align="center",
plotOutput(outputId = "barplot1",height = 700, width = 1300)
)
),
fluidRow(
column(12,align="center",
plotOutput(outputId = "barplot2",height = 700, width = 1300)
)
)
)
server <- function(input, output) {
data_FPKM <- eventReactive(input$FPKM, {
plot_data <- reactive({
subset(data_mean_sd, Gene %in% input$selectGeneSymbol)
})
ggplot(data = plot_data(), aes(x = Name, y = mean,fill=Name)) +
geom_bar(stat = "identity", position = position_dodge(0.9), width = 0.9) +
geom_errorbar(aes(ymin = mean - sd, ymax = mean + sd), width = .2, position = position_dodge(0.9)) +
theme_classic2() +
rotate_x_text(angle = 45) +
theme(legend.position = "none") +
labs(title = input$GeneSymbol, x = NULL, y = "FPKM_value") +
theme(plot.title = element_text(hjust = 0.5)) +
theme(plot.margin = unit(c(20, 5, 1, 5), "mm"))+
theme(axis.text.x=element_text(vjust=1,size=12))
}) ## 建立 按钮与 数据的关系
output$barplot <- renderPlot(
{
barplot(data_FPKM())
})
}
# Create Shiny app ----
shinyApp(ui = ui, server = server)
Who can help me to find where the wrong with my code. Many thanks
Here is a way to get output for the 1st plot on click of 1st button. You can use the same process for other plots.
library(shiny)
library(ggplot2)
mean_data <- data.frame(
Name = c(paste0("Group_", LETTERS[1:20])),
matx <- matrix(sample(1:1000, 1000, replace = T), nrow = 20)
)
names(mean_data)[-1] <- c(paste0("Gene_", 1:50))
sd_data <- data.frame(
Name = c(paste0("Group_", LETTERS[1:20])),
matx <- matrix(runif(1000, 5, 10), nrow = 20)
)
names(sd_data)[-1] <- c(paste0("Gene_", 1:50))
# Prepare dataset.
# 1. Bind mean and sd data
# 2. Reshape
data <- bind_rows(list(
mean = mean_data,
sd = sd_data
), .id = "stat")
data_mean_sd <- data %>%
pivot_longer(-c(Name, stat), names_to = "Gene", values_to = "value") %>%
pivot_wider(names_from = "stat", values_from = "value")
###
ui <- fluidPage(
fluidRow(
column(8,offset = 3,
h2("Gene_FPKM Value Barplot")
)
),
fluidRow(
column(8,offset = 3,
selectInput(
"selectGeneSymbol",
"Select Gene Symbol:",
choices = unique(data_mean_sd$Gene),
multiple =F,
width = 800,
selected = "Igfbp7"
))
),
fluidRow(
column(8,offset = 3,
actionButton(inputId = "FPKM", label = "FPKM"),
actionButton(inputId = "logFC", label = "logFC"),
actionButton(inputId = "logFC&FPKM",label = "logFC&FPKM")
)
),
fluidRow(
column(3)
),
fluidRow(
column(3)
),
fluidRow(
column(12,align="center",
plotOutput(outputId = "barplot1",height = 700, width = 1300)
)
),
fluidRow(
column(12,align="center",
plotOutput(outputId = "barplot2",height = 700, width = 1300)
)
)
)
server <- function(input, output) {
plot_data <- reactive({
subset(data_mean_sd, Gene %in% input$selectGeneSymbol)
})
v <- reactiveValues(barplot1 = NULL,barplot2 = NULL)
observeEvent(input$FPKM, {
ggplot(data = plot_data(), aes(x = Name, y = mean,fill=Name)) +
geom_bar(stat = "identity", position = position_dodge(0.9), width = 0.9) +
geom_errorbar(aes(ymin = mean - sd, ymax = mean + sd), width = .2, position = position_dodge(0.9)) +
theme_classic2() +
rotate_x_text(angle = 45) +
theme(legend.position = "none") +
labs(title = input$GeneSymbol, x = NULL, y = "FPKM_value") +
theme(plot.title = element_text(hjust = 0.5)) +
theme(plot.margin = unit(c(20, 5, 1, 5), "mm"))+
theme(axis.text.x=element_text(vjust=1,size=12)) -> v$barplot1
})
output$barplot1 <- renderPlot({
v$barplot1
})
}
# Create Shiny app ----
shinyApp(ui = ui, server = server)

shiny click on plot update input

I have this very simple shiny app
When input changes, the graph changes accordingly
When a point is selected within the graph the corresponding model is displayed on the right of the input text box
I would like to see the selection to be displayed inside the text box
Can anyone please point me in the right direction
Thanks for any help
require(ggplot2)
require(dplyr)
require(Cairo)
require(dplyr)
mtcars2 <- datasets::mtcars %>% rownames_to_column(var = 'model')
ui <- fluidPage(
fluidRow(
column(width = 3,
selectInput(inputId = '.model', label = 'input model', choices = mtcars2$model, selected = NULL)),
br(),br(),
column(width = 3,
textOutput('click_1A'), label = 'selected model')
),
fluidRow(
column(width = 8,
plotOutput("plot1", height = 350, brush = "plot_brush", click = "plot_click")),
)
)
server <- function(input, output) {
global <- reactiveValues(.model = NULL)
# scatter plot
output$plot1 <- renderPlot({
selected_model <- input$.model
ggplot(mtcars2, aes(x=mpg,y=disp), color = 'red') +
geom_point(size = 3, col = 'red') +
geom_point(data = filter(mtcars2, model == selected_model), col = 'blue', size = 5) +
theme_bw() +
theme(legend.position = 'none')
})
# MODEL name
output$click_1A <- renderText({
near_out <- nearPoints(mtcars2, input$plot_click, addDist = TRUE)
global$.model <- near_out %>%
pull(model)
})
}
shinyApp(ui, server)
Thanks #Ben
Here is the clean version of what was trying to achieve:
require(ggplot2)
require(tidyr)
require(tibble)
require(lubridate)
require(Cairo)
require(dplyr)
mtcars2 <- datasets::mtcars %>% rownames_to_column(var = 'model')
ui <- fluidPage(
fluidRow(
column(width = 3,
selectInput(inputId = '.model', label = 'input model', choices = mtcars2$model, selected = NULL)),
),
fluidRow(
column(width = 8,
plotOutput("plot1", height = 350, brush = "plot_brush", click = "plot_click")),
)
)
server <- function(input, output, session) {
global <- reactiveValues(.model = NULL)
# scatter plot
output$plot1 <- renderPlot({
selected_model <- input$.model
ggplot(mtcars2, aes(x=mpg,y=disp, label = model), color = 'red') +
geom_point(size = 3, col = 'red') +
geom_point(data = filter(mtcars2, model == selected_model), col = 'blue', size = 5) +
#geom_text() +
theme_bw() +
theme(legend.position = 'none')
})
observeEvent(
eventExpr = input$plot_click,
handlerExpr = {
selected_model <- nearPoints(mtcars2, input$plot_click, maxpoints = 1, addDist = F) %>% pull(model)
updateSelectInput(session, inputId = ".model", choices = mtcars2$model, selected = selected_model)}
)
}
shinyApp(ui, server)

Resources