R Shiny does not plot the bar plot on dialogue box
Question
I am trying to add a bar plot on the dialogue box in my shiny app.And I am not succeeding. I am have inspired by this shiny app ( https://shiny.rstudio.com/gallery/superzip-example.html ), where the histogram appears on the dialogue box and it is updating itself when moving on different zip code. And was hoping to achieve something similar yet not succeeding.
The code I am using for my shiny app is this:
library(shiny)
library(tidyverse)
library(leaflet.extras)
library(leaflet)
library(RColorBrewer)
library(scales)
library(lattice)
library(dplyr)
fake_data <- read_csv("https://raw.githubusercontent.com/gabrielburcea/stackoverflow_fake_data/master/gather_divided.csv")
min_date <- as.Date("2020-04-09", "%Y-%m-%d")
max_date <- as.Date("2020-05-06",, "%Y-%m-%d")
plot_freq_country <- function(data, start_date = min_date,
end_date = max_date,
title = "Frequency accross Symptoms"){
plot <- ggplot2::ggplot(fake_data, ggplot2::aes(x = Symptom, y = n, fill = n)) +
ggplot2::coord_flip() +
ggplot2::geom_bar(stat = "identity", position = "dodge") +
ggplot2::scale_fill_viridis_c(option = "magma", direction = -1) +
ggplot2::scale_x_discrete(limits = unique(fake_data$Symptom)) +
#ggplot2::theme(legend.position = "bottom") +
#ggplot2::guides(fill = ggplot2::guide_legend(nrow = 3)) +
ggplot2::theme_minimal()
plotly::ggplotly(plot)
}
# Define UI for application that draws a histogram
ui <- bootstrapPage(
navbarPage(theme = shinytheme("flatly"), header = "",
"Symptom Tracker", id = "nav",
tabPanel("Interactive map",
div(class = "outer",
tags$head(includeCSS("styles.css")),
#tags$head(tags$link(rel = "stylesheet", type = "text/css", href = "style.css")),
leafletOutput("map", width = "100%", height = 1000),
tags$style(type = "text/css", ".container-fluid {padding-left:0px;padding-right:0px;}"),
tags$style(type = "text/css", ".navbar {margin-bottom: .5px;}"),
tags$style(type = "text/css", ".container-fluid .navbar-header .navbar-brand {margin-left: 0px;}"),
#Floating panel
absolutePanel(id = "controls", style="z-index:400;", class = "panel panel-default", fixed = TRUE,
draggable = TRUE, top = 75, left = 55,
width = 330, height = "auto",
h4("symptoms"),
selectInput("symptom", "Select symptom", c("Chills",
"Cough", "Diarrhoea",
"Fatigue",
"Headache",
"Loss of smell and taste",
"Muscle ache",
"Nasal congestion",
"Nausea and vomiting",
"Shortness of breath",
"Sore throat",
"Sputum",
"Temperature")
),
plotOutput("frequencies_symptom", height = "130px", width = "100%"),
tags$div(id="cite",
'Data provided by fake.data'
)
)))
)
)
server <- function(input, output) {
filtered_data <- reactive({
fake_data %>%
dplyr::filter(Symptom %in% input$symptom)
})
output$frequencies_symptom <- renderPlot({
plot_freq_country(data = fake_data, start_date = min_date,
end_date = max_date,
title = "Frequency accross Symptoms")
})
output$map <- renderLeaflet({
leaflet() %>%
addTiles(urlTemplate = "//{s}.tiles.mapbox.com/v3/jcheng.map-5ebohr46/{z}/{x}/{y}.png",
attribution = 'Maps by <a href="http://www.mapbox.com/">Mapbox</a>') %>%
addMarkers(data = filtered_data(), clusterOptions = markerClusterOptions())
})
}
# Run the application
shinyApp(ui = ui, server = server)
Then as you observe, this is the bit that is important, I place my output plot in ui:
plotOutput("frequencies_symptom", height = "130px", width = "100%"),
And then apply the function plot_freq_country on the fake_data . The plot is exactly like in this picture on the dialogue box.
The caveat though, is that when I move on different country, on the map, I am hoping the bar plot to update itself as it is updating itself on the SuperZip shiny app in the link provided.
You may need the css file as well and it is at this link: https://github.com/gabrielburcea/stackoverflow_fake_data/blob/master/style.css
Addition of my full code on a more realistic data.
pivot_data$Country <-
dplyr::recode(
pivot_data$Country,
'United States of America' = 'USA',
'Great Britain' = 'United Kingdom'
)
pivot_data$Date <- as.Date(pivot_data$'Date.Completed', tz = "Europe/London")
pivot_data$Gender <- as.factor(pivot_data$Gender)
pivot_data$Country <- as.factor(pivot_data$Country)
pivot_data$Location <- as.factor(pivot_data$Location)
pivot_data$Chills <- as.factor(pivot_data$Chills)
pivot_data$Cough <- as.factor(pivot_data$Cough)
pivot_data$Diarrhoea <- as.factor(pivot_data$Diarrhoea)
pivot_data$Fatigue <- as.factor(pivot_data$Fatigue)
pivot_data$Headache <- as.factor(pivot_data$Headcahe)
pivot_data$loss_smell_taste <- as.factor(pivot_data$'Loss.of.smell.and.taste')
pivot_data$muscle_ache <- as.factor(pivot_data$'Muscle.Ache')
pivot_data$nasal_congestion <- as.factor(pivot_data$'Nasal.Congestion')
pivot_data$nausea_vomiting <- as.factor(pivot_data$'Nausea.and.Vomiting')
pivot_data$shortness_breath <- as.factor(pivot_data$'Shortness.of.Breath')
pivot_data$sore_throat <- as.factor(pivot_data$'Sore.Throat')
pivot_data$sputum <- as.factor(pivot_data$Sputum)
pivot_data$temperature <- as.factor(pivot_data$Temperature)
level_key_chills <-
c(
'Yes' = "Chills",
'No' = "No",
'Yes' = "Mild",
'Yes' = "Moderate",
'Yes' = "Severe"
)
level_key_cough <-
c(
'Yes' = "Cough",
'No' = "No",
'Yes' = "Mild",
'Yes' = "Moderate",
'Yes' = "Severe"
)
level_key_diarrhoea <-
c(
'No' = "No",
'Yes' = "Mild",
'Yes' = "Moderate",
'Yes' = "Severe"
)
level_key_fatigue <-
c(
'No' = "No",
'Yes' = "Mild",
'Yes' = "Moderate",
'Yes' = "Severe"
)
level_key_headache <-
c(
'No' = "No",
'Yes' = "Mild",
'Yes' = "Moderate",
'Yes' = "Severe",
'Yes' = "Headcahe"
)
level_key_loss_smell_taste <-
c(
'No' = "Loss of smell and taste",
'No' = "No",
'Yes' = "Mild",
'Yes' = "Moderate",
'Yes' = "Severe"
)
level_key_muschle_ache <-
c(
'No' = "No",
'No' = "Muscle Ache",
'Yes' = "Mild",
'Yes' = "Moderate",
'Yes' = "Severe"
)
level_key_nasal_congestion <-
c(
'No' = "No",
'No' = "Nasal Congestion",
'Yes' = "Mild",
'Yes' = "Moderate",
'Yes' = "Severe"
)
level_key_nausea_vomiting <-
c(
'No' = "No",
'Yes' = "Nausea and Vomiting",
'Yes' = "Mild",
'Yes' = "Moderate",
'Yes' = "Severe"
)
level_key_self_diagnosis <-
c(
'No' = "None",
'Yes' = "Mild",
'Yes' = "Moderate",
'Yes' = "Severe"
)
level_key_short_breath <-
c(
'No' = "No",
'No' = "Shortness of Breath",
'Yes' = "Mild",
'Yes' = "Moderate",
'Yes' = "Severe"
)
level_key_sore_throat <-
c(
'No' = "No",
'No' = "Sore Throat",
'Yes' = "Mild",
'Yes' = "Moderate",
'Yes' = "Severe"
)
level_key_sputum <-
c(
'No' = "No",
'No' = "Sputum",
'Yes' = "Mild",
'Yes' = "Moderate",
'Yes' = "Severe"
)
level_key_care_home_worker <-
c('Yes' = 'Yes',
'No' = 'No')
level_key_temperature <-
c('No' = 'No',
Yes = '37.5-38',
Yes = '37.5-38',
Yes = "38.2-39",
Yes = '38.1-39',
Yes = '39.1-41',
Yes = 'Temperature'
)
data_not_sev <- pivot_data %>%
dplyr::mutate(
Chills = forcats::fct_recode(Chills,!!!level_key_chills),
Cough = forcats::fct_recode(Cough,!!!level_key_cough),
Diarrhoea = forcats::fct_recode(Diarrhoea,!!!level_key_diarrhoea),
Fatigue = forcats::fct_recode(Fatigue,!!!level_key_fatigue),
Headache = forcats::fct_recode(Headache,!!!level_key_headache),
'Loss of smell and taste' = forcats::fct_recode(loss_smell_taste,!!!level_key_loss_smell_taste),
'Muscle ache' = forcats::fct_recode(muscle_ache,!!!level_key_muschle_ache),
'Nasal congestion' = forcats::fct_recode(nasal_congestion,!!!level_key_nasal_congestion),
'Nausea and vomiting' = forcats::fct_recode(nausea_vomiting,!!!level_key_nausea_vomiting),
'Shortness of breath' = forcats::fct_recode(shortness_breath,!!!level_key_short_breath),
'Sore throat' = forcats::fct_recode(sore_throat,!!!level_key_sore_throat),
Temperature = forcats::fct_recode(temperature, !!!level_key_temperature),
Sputum = forcats::fct_recode(Sputum,!!!level_key_sputum),
) %>%
dplyr::select(
ID,
Date,
Country,
Location,
Chills,
Cough,
Diarrhoea,
Fatigue,
Headache,
'Loss of smell and taste',
'Muscle ache',
'Nasal congestion',
'Nausea and vomiting',
'Shortness of breath',
'Sore throat',
Sputum,
Temperature,
lat,
lon
)
gather_divided <- data_not_sev %>%
tidyr::pivot_longer(cols = 5:17,
names_to = "Symptom",
values_to = "Severity") %>%
dplyr::filter(Severity != "No") %>%
dplyr::group_by(Symptom, Country, Location, lon, lat) %>%
dplyr::tally() %>%
dplyr::mutate(Frequency = n/sum(n))
gather_divided$Symptom <- as.character(gather_divided$Symptom)
gather_divided$Country <- as.character(gather_divided$Country)
gather_divided$Location <- as.character(gather_divided$Location)
gather_divided$rownum <- seq.int(nrow(gather_divided))
gather_divided <- data.table(gather_divided)
# Define UI for application that draws a histogram
ui <- bootstrapPage(
navbarPage(theme = shinytheme("flatly"), header = "",
"Symptom Tracker", id = "nav",
tabPanel("Interactive map",
div(class = "outer",
tags$head(includeCSS("styles.css")),
#tags$head(tags$link(rel = "stylesheet", type = "text/css", href = "style.css")),
leafletOutput("map", width = "100%", height = 1000),
tags$style(type = "text/css", ".container-fluid {padding-left:0px;padding-right:0px;}"),
tags$style(type = "text/css", ".navbar {margin-bottom: .5px;}"),
tags$style(type = "text/css", ".container-fluid .navbar-header .navbar-brand {margin-left: 0px;}"),
#Floating panel
absolutePanel(id = "controls", style="z-index:400;", class = "panel panel-default", fixed = TRUE,
draggable = TRUE, top = 75, left = 55,
width = 330, height = "auto",
h4("symptoms"),
selectInput("symptom", "Select symptom", c("Chills",
"Cough", "Diarrhoea",
"Fatigue",
"Headache",
"Loss of smell and taste",
"Muscle ache",
"Nasal congestion",
"Nausea and vomiting",
"Shortness of breath",
"Sore throat",
"Sputum",
"Temperature")
),
plotOutput("barplot"),
# absolutePanel(id = "logo", class = "card", bottom = 20, left = 60, width = 80, fixed=TRUE, draggable = FALSE, height = "auto",
# tags$a(tags$img(src="logo.png",height='40',width='80'))),
#
# absolutePanel(id = "logo", class = "card", bottom = 20, left = 20, width = 30, fixed=TRUE, draggable = FALSE, height = "auto",
# actionButton("twitter_share", label = "", icon = icon("twitter"),style='padding:5px',
# onclick = sprintf("window.open('%s')",
# "twitter"))),
#
tags$div(id="cite",
'Data provided by fake.data'
)
)))
)
)
server <- function(input, output) {
filtered_data <- reactive({
gather_divided %>%
dplyr::filter(Symptom %in% input$symptom)
})
output$frequencies_symptom <- renderPlot({
plot_freq_country(data = data_not_sev,
start_date = min_date,
end_date = max_date,
title = "Frequency accross Symptoms")
})
output$map <- renderLeaflet({
leaflet() %>%
addTiles(urlTemplate = "//{s}.tiles.mapbox.com/v3/jcheng.map-5ebohr46/{z}/{x}/{y}.png",
attribution = 'Maps by <a href="http://www.mapbox.com/">Mapbox</a>') %>%
addMarkers(data = filtered_data(), clusterOptions = markerClusterOptions())
})
# When a marker is hovered over...
observeEvent(input$mymap_marker_mouseover$id, {
## when a marker is hovered over...subset data to that country
filt_dat <- reactive({
pointer <- input$mymap_marker_mouseover$id
t <- 0.5
la <- input$mymap_marker_mouseover$lat
lo <- input$mymap_marker_mouseover$lng
df <- subset(gather_divided, ((lat-t < la & la < lat+t) & (lon-t < lo & lo < lon+t)))
df
})
output$barplot <- renderPlot({
mycountry <- unique(filt_dat()$Country)
plot <- ggplot2::ggplot(filt_dat(), aes(x = Symptom, y = n, fill = n)) +
ggplot2::geom_bar(stat = "identity", position = "dodge") +
ggplot2::scale_fill_viridis_c(option = "magma", direction = -1, breaks = unique(filt_dat()$n)) +
scale_x_discrete(breaks = unique(filt_dat()$Symptom)) +
scale_y_continuous(breaks = unique(filt_dat()$n), labels=unique(filt_dat()$n) ) +
guides(fill = "none") +
theme_minimal() + labs(fill=NULL, title=mycountry) + coord_flip()
#plotly::ggplotly(plot)
plot
})
observeEvent(input$mymap_marker_mouseout$id, {
leafletProxy("mymap") %>% clearPopups()
})
})
}
# Run the application
shinyApp(ui, server)
and a bit of data which is more realistic is here: https://github.com/gabrielburcea/stackoverflow_fake_data/blob/master/test.data.csv
1 answers
solution1
1 ACCPTED 2020-07-19 21:21:06
Try this
fake_data <- read_csv("https://raw.githubusercontent.com/gabrielburcea/stackoverflow_fake_data/master/gather_divided.csv")
fake_data <- fake_data %>% mutate(rownum = (1:nrow(fake_data)))
### Define UI for application that draws a histogram
ui <- bootstrapPage(
navbarPage(theme = shinytheme("flatly"), header = "",
"Symptom Tracker", id = "nav",
tabPanel("Interactive map",
div(class = "outer",
#tags$head(includeCSS("style3.css")),
tags$head(tags$link(rel = "stylesheet", type = "text/css", href = "style3.css")),
leafletOutput("mymap", width = "100%", height = 1000),
tags$style(type = "text/css", ".container-fluid {padding-left:0px;padding-right:0px;}"),
tags$style(type = "text/css", ".navbar {margin-bottom: .5px;}"),
tags$style(type = "text/css", ".container-fluid .navbar-header .navbar-brand {margin-left: 0px;}"),
#Floating panel
absolutePanel(id = "controls", style="z-index:400;", class = "panel panel-default", fixed = TRUE,
draggable = TRUE, top = 75, left = 55,
width = 330, height = "auto",
h4("symptoms"),
selectInput("symptom", "Select symptom", c("Chills",
"Cough", "Diarrhoea",
"Fatigue",
"Headache",
"Loss of smell and taste",
"Muscle ache",
"Nasal congestion",
"Nausea and vomiting",
"Shortness of breath",
"Sore throat",
"Sputum",
"Temperature")
),
tags$div(id="cite",
'Data provided by fake.data'
),
plotOutput("barplot")
)))
)
)
server <- function(input, output, session) {
filtered_data <- reactive({
fake_data %>%
dplyr::filter(Symptom %in% input$symptom)
})
output$mymap <- renderLeaflet({
leaflet() %>%
addTiles(urlTemplate = "//{s}.tiles.mapbox.com/v3/jcheng.map-5ebohr46/{z}/{x}/{y}.png",
attribution = 'Maps by <a href="http://www.mapbox.com/">Mapbox</a>') %>%
addMarkers(data = filtered_data(), clusterOptions = markerClusterOptions(), layerId = filtered_data()$rownum)
})
# When a marker is hovered over...
observeEvent(input$mymap_marker_mouseover$id, {
## when a marker is hovered over...subset data to that country
filtered_data2 <- reactive({
pointer <- input$mymap_marker_mouseover$id
t <- 0.5
la <- input$mymap_marker_mouseover$lat
lo <- input$mymap_marker_mouseover$lng
df <- subset(fake_data, ((lat-t < la & la < lat+t) & (lon-t < lo & lo < lon+t)))
df
})
output$barplot <- renderPlot({
mycountry <- unique(filtered_data2()$Country)
plot <- ggplot2::ggplot(filtered_data2(), aes(x = Symptom, y = n, fill = n)) +
ggplot2::geom_bar(stat = "identity", position = "dodge") +
ggplot2::scale_fill_viridis_c(option = "magma", direction = -1, breaks = unique(filtered_data2()$n)) +
scale_x_discrete(breaks = unique(filtered_data2()$Symptom)) +
scale_y_continuous(breaks = unique(filtered_data2()$n), labels=unique(filtered_data2()$n) ) +
# theme(legend.position = "right") +
guides(fill = "none") +
theme_minimal() + labs(fill=NULL, title=mycountry) + coord_flip()
#plotly::ggplotly(plot)
plot
})
observeEvent(input$mymap_marker_mouseout$id, {
leafletProxy("mymap") %>% clearPopups()
})
})
}
# Run the application
shinyApp(ui = ui, server = server)
You will get this output (please modify style3.css to your styles.css):
The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.
Related Question
Box Plot in Shiny R
Bar plot error with Shiny R
R - Shiny - Dynamic selection bar plot
Stack Bar Plot For R Shiny Dashboard
R Shiny Plot Click with geom bar and facets
R Shiny Bar Plot and input$var issue
R Shiny Help: Bar plot with 2+ filters
R combining a box plot with a bar plot works but not the other way around
Making a plot with Shiny in R
R shiny plot size
Related Tags