R Shiny 没有 plot 条形框 Z32FA6E1B78A9D4028953E60564A2 上的对话框
[英]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.
我正在尝试在我的 shiny 应用程序的对话框中添加一个条形 plot。但我没有成功。 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. 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:我用于 shiny 应用程序的代码是这样的：
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:然后正如您所观察到的，这是重要的一点，我将 output plot 放在 ui 中：
plotOutput("frequencies_symptom", height = "130px", width = "100%"),
And then apply the function plot_freq_country on the fake_data .然后在plot_freq_country上应用 function fake_data 。 The plot is exactly like in this picture on the dialogue box. plot 与对话框中的这张图片一模一样。
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.不过需要注意的是，当我在不同的国家移动时，在 map 上，我希望栏 plot 能够自我更新，因为它正在 SuperZip shiny 应用程序中提供的链接中更新自身。
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您可能还需要 css 文件，它位于此链接： https://github.com/gabrielburcea/stackoverflow_fake_data/blob/master/style.ZC7A628CBA22E28EB17B5F5C666
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还有一些更真实的数据在这里： https://github.com/gabrielburcea/stackoverflow_fake_data/blob/master/test.data.csv
1 个解决方案
解决方案1
1 已采纳 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):你会得到这个 output （请将 style3.css 修改为你的 styles.css）：
声明:本站的技术帖子网页，遵循CC BY-SA 4.0协议，如果您需要转载，请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.
相关问题
闪亮R中的箱形图 - Box Plot in Shiny R
条形图错误与Shiny R - Bar plot error with Shiny R
R - Shiny - 动态选择条形图 - R - Shiny - Dynamic selection bar plot
R Shiny 仪表板的堆栈条形图 - Stack Bar Plot For R Shiny Dashboard
R Shiny Plot单击带有几何图形栏和刻面的 - R Shiny Plot Click with geom bar and facets
R Shiny Bar图和input $ var问题 - R Shiny Bar Plot and input$var issue
R闪亮帮助：带有2个以上滤镜的条形图 - R Shiny Help: Bar plot with 2+ filters
R将箱形图与条形图结合使用有效，但反之则不行 - R combining a box plot with a bar plot works but not the other way around
在R中使用Shiny进行绘图 - Making a plot with Shiny in R
R闪亮的情节大小 - R shiny plot size
相关标签