GaB
Reputation: 1134
R Shiny does not plot the bar plot on dialogue box
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
Upvotes: 0
Views: 167
Answers (1)
YBS
Reputation: 21349
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):
Upvotes: 1
Related Questions
- Couldn't show my simple bar charts separately on Shiny R dashboardBody
- How to create interactive x y axes for bar chart using R Shiny
- Shiny - Can't get Barplot to display
- Problem with reactive bar plot in Shiny App
- Bars are not displayed when axis value is given as input in a shiny app
- Plot Bar Chart in R - Year issue
- bars missing when using shiny to create ggplot bar chart
- R display barPlot labels
- Bar plot error with Shiny R
- Graph is not displayed in shiny [R]