R Shiny 没有 plot 条形框 Z32FA6E1B78A9D4028953E60564A2 上的对话框
[英]R Shiny does not plot the bar plot on dialogue box
问题描述
我正在尝试在我的 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. 并希望实现类似但没有成功的事情。
我用于 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)
然后正如您所观察到的，这是重要的一点，我将 output plot 放在 ui 中：
plotOutput("frequencies_symptom", height = "130px", width = "100%"),
然后在plot_freq_country上应用 function fake_data 。 plot 与对话框中的这张图片一模一样。
不过需要注意的是，当我在不同的国家移动时，在 map 上，我希望栏 plot 能够自我更新，因为它正在 SuperZip shiny 应用程序中提供的链接中更新自身。
您可能还需要 css 文件，它位于此链接： https://github.com/gabrielburcea/stackoverflow_fake_data/blob/master/style.ZC7A628CBA22E28EB17B5F5C666
在更真实的数据上添加我的完整代码。
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)
还有一些更真实的数据在这里： https://github.com/gabrielburcea/stackoverflow_fake_data/blob/master/test.data.csv
1 个解决方案
解决方案1
1 已采纳 2020-07-19 21:21:06
尝试这个
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)
你会得到这个 output （请将 style3.css 修改为你的 styles.css）：
闪亮R中的箱形图
声明:本站的技术帖子网页，遵循CC BY-SA 4.0协议，如果您需要转载，请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.