在基于闪亮小部件的曲线图中添加新轨迹

Question

我有这个数据框，其中包含每个 VaccinationWeek 的每个 Country 的 Value 和每周的累积值 (EU)。

VaccinationWeek Country Value
1          2020w1      EU     3
2          2020w1     CHE     2
3          2020w1     ITA     1
4          2020w2      EU     5
5          2020w2     CHE     3
6          2020w2     ITA     2

我创建了一个闪亮的应用程序，当用户从pickerInput() 中选择（默认）无国家时，折线图中只会显示欧盟线：

对于用户在上述行中选择的每个国家/地区（通常超过 2 个），将添加该国家/地区的相应行，悬停文本将在所有行中包含欧盟和所选国家/地区的数据，例如：

library(shiny)
library(plotly)
library(shinyWidgets)

VaccinationWeek<-c("2020w1","2020w1","2020w1","2020w2","2020w2","2020w2")
Country<-c("EU","CHE","ITA","EU","CHE","ITA")
Value<-c(3,2,1,5,3,2)
dat<-data.frame(VaccinationWeek,Country,Value)


ui <- fluidPage(
  sidebarLayout(
    sidebarPanel(
      pickerInput(
        inputId = "p1",
        label = "",
        choices = c("CHE","ITA"),
        multiple = TRUE,
        selected = c("CHE","ITA"),
        options = pickerOptions(`actions-box` = TRUE)
      )
    ),
    mainPanel(
    plotlyOutput("line")
    )
  )
)

server <- function(input, output) {
  output$line<-renderPlotly({
    dat <- subset(dat, Country %in% input$p1)
    
    plot_ly(dat,
            x = ~VaccinationWeek, 
            y = ~Value,
            text = ~Value) %>%
      add_trace(
        type = 'scatter',
        mode = 'lines+markers+text',
        fill = 'tozeroy',
        fillcolor = 'lightgreen',
        marker = list(color = 'green'),
        line = list(color = 'green'),
        textposition = "top center",
        hovertemplate = paste0("<b>%{x}</b>
                           Value: %{y} 
                          <extra></extra>"),
        hoveron = 'points') 
    
  })
}

shinyApp(ui = ui, server = server)

Answer 1

这是一个只有线条的想法（请参阅您的第二张图片）。

library(shiny)
library(plotly)
library(shinyWidgets)

VaccinationWeek<-c("2020w1","2020w1","2020w1","2020w2","2020w2","2020w2")
Country<-c("EU","CHE","ITA","EU","CHE","ITA")
Value<-c(3,2,1,5,3,2)
dat<-data.frame(VaccinationWeek,Country,Value)


ui <- fluidPage(
  sidebarLayout(
    sidebarPanel(
      pickerInput(
        inputId = "p1",
        label = "",
        choices = c("CHE","ITA"),
        multiple = TRUE,
        selected = c("CHE","ITA"),
        options = pickerOptions(`actions-box` = TRUE)
      )
    ),
    mainPanel(
      plotlyOutput("line")
    )
  )
)

server <- function(input, output) {
  output$line<-renderPlotly({
    
    dat <- subset(dat, Country %in% c("EU",input$p1))

    plot_ly(dat,
            x = ~VaccinationWeek, 
            y = ~Value,
            text = ~Value,
            color = ~Country,
            customdata = dat$Country) %>%
      add_trace(
        type = 'scatter',
        mode = 'lines+markers',
        hovertemplate = paste("Country: %{customdata}",
                              "Uptake first dose (%): %{y}", 
                              "<extra></extra>",
                              sep = "\n"),
        hoveron = 'points') %>%
      add_text(    
        textposition = "top center",
        showlegend = F,
        hoverinfo = "skip") %>% 
      layout(hovermode = "x unified",
             hoverlabel = "none",
             legend = list(itemclick = F, itemdoubleclick = F))
    
  })
}

shinyApp(ui = ui, server = server)

或每个国家/地区的填充区域和单线的线图（您的第一张添加线的图像）。

# Just the plot, needs to be copied into the shiny app 
    plot_ly(x = ~VaccinationWeek, 
            y = ~Value,
            text = ~Value,
            color = ~Country) %>%
      add_trace(
        data = subset(dat, Country == "EU"),
        customdata = subset(dat, Country == "EU")$Country,
        type = 'scatter',
        mode = 'lines+markers',
        fill = 'tozeroy',
        fillcolor = 'lightgreen',
        marker = list(color = 'green'),
        line = list(color = 'green'),
        hovertemplate = paste("Country: %{customdata}",
                              "Uptake first dose (%): %{y}", 
                              "<extra></extra>",
                              sep = "\n"),
        hoveron = 'points') %>%
      add_text(        
        data = subset(dat, Country == "EU"),
        textposition = "top center",
        showlegend = F,
        hoverinfo = "skip") %>%
      add_trace(
        data = subset(dat, Country != "EU"),
        customdata = subset(dat, Country != "EU")$Country,
        type = 'scatter',
        mode = 'lines+markers',
        hovertemplate = paste("Country: %{customdata}",
                              "Uptake first dose (%): %{y}", 
                              "<extra></extra>",
                              sep = "\n"),
        hoveron = 'points')  %>% 
      add_text(        
        data = subset(dat, Country != "EU"),
        textposition = "top center",
        showlegend = F,
        hoverinfo = "skip") %>%
      layout(hovermode = "x unified",
             hoverlabel = "none",
             legend = list(itemclick = F, itemdoubleclick = F))