无反应的传奇

Question

如何在这个闪亮的应用中创建静态传奇？

传说必须包含所有4个异常因子水平，而不管它们是否存在于反应性图中。因子水平为正常，暂定， low 和 high

输入数据框架自动创建下面的脚本。 传奇点和情节点的颜色和形状应匹配。

我还必须将悬停信息当前保存在AES_STRING（）中

# Load libraries
library(dplyr)
library(shiny)
library(plotly)
library(ggplot2)
library(dplyr)
library(scales)
library(shinyWidgets)
library(lubridate)


# Create input dataframe
DF <- data.frame(
  recordID = as.factor(c(101, 102, 103, 104, 105, 106, 107, 108)),
  Category = as.factor(c('X', 'X', 'Z', 'Z', 'Z', 'Z', 'X', 'X')),
  CategoryTRUEFALSE = c(TRUE, TRUE, FALSE, FALSE, FALSE, FALSE, TRUE, TRUE),
  startDate = as_date(c('2022-01-01', '2022-01-02', '2022-01-03','2022-01-04', '2015-08-18', '2015-08-19', '2015-08-20','2015-08-21')),
  companyName = as.factor(c('CompanyZ', 'CompanyZ', 'CompanyZ', 'CompanyZ', 'CompanyA', 'CompanyA', 'CompanyA', 'CompanyA')),
  wayPoint = as.factor(c('WP1', 'WP1', 'WP1', 'WP1', 'WP2', 'WP2', 'WP2', 'WP2')),
  Capacity = c(8000, 8000, 8000, 8000 , 13000, 13000, 13000, 13000),
  finalDestination = as.factor(c('PortA', 'PortA', 'PortA', 'PortA', 'PortB', 'PortB', 'PortB', 'PortB')),
  Duration = (c(15, 17, 16, 40, 109, 111, 125, 177)),
  Anomaly = (c('NORMAL', 'LOW', 'NORMAL', 'HIGH', 'NORMAL', 'TENTATIVE', 'NORMAL', 'HIGH'))
)  %>%
  mutate(Anomaly = factor(Anomaly, levels = c('NORMAL', 'TENTATIVE', 'LOW', 'HIGH')))



# Info columns
VARS_info <- c('recordID', 'startDate', 'Category', 'CategoryTRUEFALSE', 'Duration', 'Anomaly')

# Declare selector variables
VARS_selector <- c('companyName', 'wayPoint', 'Capacity', 'finalDestination')







# UI
ui <- navbarPage(title = "Anomaly Browser",
                 
                 
                 tabPanel("Browse data",
                          sidebarLayout(
                            sidebarPanel(
                              
                              
                              selectInput(inputId = "companyName",
                                          label = "Rail haul provider: ",
                                          choices = sort(unique(Shiny$companyName)),
                                          multiple = FALSE),
                              
                              
                              selectInput(inputId = "wayPoint",
                                          label = "Load point: ",
                                          choices = NULL,
                                          multiple = FALSE),
                              
                              
                              selectInput(inputId = "capacity",
                                          label = "Capacity: ",
                                          choices = NULL,
                                          multiple = FALSE),
                              
                              
                              selectInput(inputId = "finalDestination",
                                          label = "Terminal: ",
                                          choices = NULL,
                                          multiple = FALSE),
                              
                              br(),
                              br(),
                              
                              
                              
                              switchInput(inputId = "category",
                                          onLabel = "X",
                                          offLabel = "Z",
                                          onStatus = "GreenStatus",
                                          offStatus = "RedStatus",
                                          inline = TRUE,
                                          value = TRUE,
                                          size = 'large'
                              ),
                              
                              
                              
                              br(),
                              br(),
                              downloadLink("downloadData", "Download plot data"),
                              br(),
                              width = 2, 
                              
                              # switchInput color while on
                              tags$head(tags$style(HTML('.bootstrap-switch .bootstrap-switch-handle-off.bootstrap-switch-GreenStatus,
                                       .bootstrap-switch .bootstrap-switch-handle-on.bootstrap-switch-GreenStatus {
                                        background: green;
                                        color: white;
                                        }'))),
                              
                              # switchInput color while off
                              tags$head(tags$style(HTML('.bootstrap-switch .bootstrap-switch-handle-off.bootstrap-switch-RedStatus,
                                       .bootstrap-switch .bootstrap-switch-handle-on.bootstrap-switch-RedStatus {
                                        background: darkred;
                                        color: white;
                                        }'))),
                              
                            ),
                            
                            mainPanel(
                              
                              plotlyOutput(outputId = "scatterplot", width = "120%", height = "800px"),
                              DT::dataTableOutput(outputId = "Table1", width = "125%")
                              
                            ))))









# Server
server <- function(input, output, session) {
  
  
  observeEvent(input$companyName,{
    updateSelectInput(session,'wayPoint',
                      choices=sort(unique(Shiny$wayPoint[Shiny$companyName %in% input$companyName])))
  })
  
  
  observeEvent(input$wayPoint,{
    updateSelectInput(session,'capacity',
                      choices=sort(unique(Shiny$Capacity[Shiny$wayPoint %in% input$wayPoint &
                                                           Shiny$companyName %in% input$companyName])))
    
    
  })
  
  observeEvent(input$capacity,{
    updateSelectInput(session,'finalDestination',
                      choices=sort(unique(Shiny$finalDestination[Shiny$Capacity == input$capacity &
                                                               Shiny$wayPoint %in% input$wayPoint &
                                                               Shiny$companyName %in% input$companyName])))
  })
  
  observeEvent(input$wayPoint,{
    updateSelectInput(session,'finalDestination',
                      choices=sort(unique(Shiny$finalDestination[Shiny$Capacity == input$capacity &
                                                               Shiny$wayPoint %in% input$wayPoint &
                                                               Shiny$companyName %in% input$companyName])))
  })
  
  
  
  
  
  observeEvent(input$finalDestination,{
    updateSelectInput(session,'category',
                      choices=sort(unique(Shiny$Category[Shiny$finalDestination %in% input$finalDestination &
                                                           Shiny$Capacity == input$capacity &
                                                           Shiny$wayPoint %in% input$wayPoint &
                                                           Shiny$companyName %in% input$companyName])))
  })
  
  
  
  # Selected
  selected1 <- reactive({
    req(input$companyName, input$wayPoint, input$capacity, input$finalDestination)
    Shiny %>%
      select(all_of(VARS_info), all_of(VARS_selector)) %>%
      filter(companyName %in% input$companyName &
               wayPoint %in% input$wayPoint &
               Capacity == input$capacity &
               finalDestination %in% input$finalDestination &
               CategoryTRUEFALSE %in% input$category) %>%
      select(-CategoryTRUEFALSE)
  })
  
  
  
  
  
  
  # Create scatterplot object the plotOutput function is expecting
  output$scatterplot <- renderPlotly({
    
    p <- ggplot(data = selected1(), aes_string("startDate", "Duration",
                                               A = "startDate", B = "Duration", C = "recordID", D = 'Anomaly'))
    p  <- p + ggtitle(paste0(input$companyName, " - ", input$wayPoint, " - ", input$finalDestination, " - ", input$capacity, " (", unique(selected1()$Category), ")")) +
      xlab('Cycle Start Date') + ylab("Duration  (mins)") + theme(text = element_text(size = 13))
    
    p  <- p + scale_x_date(date_breaks = "months", date_labels = "%b-%Y") +
      
      geom_smooth(method = "gam", formula = y ~ s(x, bs = "cs", k = 1), colour = "black", lwd = 0.7, se = FALSE)
    
    p  <- p + geom_point(data = selected1()[which(selected1()$Anomaly=='NORMAL'),],
                         pch=21, fill= NA, size=1.0, colour="darkgreen", stroke=1.5)
    p  <- p + geom_point(data = selected1()[which(selected1()$Anomaly=='TENTATIVE'),],
                         pch=21, fill= NA, size=1.0, colour="royalblue3", stroke=1.5)
    p  <- p + geom_point(data = selected1()[which(selected1()$Anomaly=='LOW'),],
                         pch=21, fill= NA, size=1.0, colour="orange", stroke=1.5)
    p  <- p + geom_point(data = selected1()[which(selected1()$Anomaly=='HIGH'),],
                         pch=21, fill= NA, size=1.0, colour="red", stroke=1.5)
    
    
    ggplotly(p, tooltip = c("A", "B", "C", "D"))
    
  })
  
  
  
  
  # Data table Tab-1
  output$Table1 <- DT::renderDataTable({
    DT::datatable(data = selected1(),
                  options = list(pageLength = 20),
                  rownames = FALSE)
  })
  
  
  
  
  
  # Save CSV
  output$downloadData <- downloadHandler(
    filename = function() {paste0(input$companyName,'_',input$wayPoint,'_',input$finalDestination,'_',unique(selected1()$Category),'_','cap=',input$capacity,'.csv')},
    content = function(file) {
      write.csv(selected1(), file, row.names = FALSE)
      
    })
  
  
}


# Create a Shiny app object
shinyApp(ui = ui, server = server)

Answer 1

我们可以通过提供包含数据集中所有可用级别的虚拟 data.frame 来强制 ggplot 显示所有图例项。

此外，我使用 scale_colour_manual 来减少代码：

# Load libraries
library(dplyr)
library(shiny)
library(plotly)
library(ggplot2)
library(dplyr)
library(scales)
library(shinyWidgets)
library(lubridate)

# Create input dataframe
DF <- data.frame(
  recordID = as.factor(c(101, 102, 103, 104, 105, 106, 107, 108)),
  Category = as.factor(c('X', 'X', 'Z', 'Z', 'Z', 'Z', 'X', 'X')),
  CategoryTRUEFALSE = c(TRUE, TRUE, FALSE, FALSE, FALSE, FALSE, TRUE, TRUE),
  startDate = as_date(c('2022-01-01', '2022-01-02', '2022-01-03','2022-01-04', '2015-08-18', '2015-08-19', '2015-08-20','2015-08-21')),
  companyName = as.factor(c('CompanyZ', 'CompanyZ', 'CompanyZ', 'CompanyZ', 'CompanyA', 'CompanyA', 'CompanyA', 'CompanyA')),
  wayPoint = as.factor(c('WP1', 'WP1', 'WP1', 'WP1', 'WP2', 'WP2', 'WP2', 'WP2')),
  Capacity = c(8000, 8000, 8000, 8000 , 13000, 13000, 13000, 13000),
  finalDestination = as.factor(c('PortA', 'PortA', 'PortA', 'PortA', 'PortB', 'PortB', 'PortB', 'PortB')),
  Duration = (c(15, 17, 16, 40, 109, 111, 125, 177)),
  Anomaly = (c('NORMAL', 'LOW', 'NORMAL', 'HIGH', 'NORMAL', 'TENTATIVE', 'NORMAL', 'HIGH'))
) %>% mutate(Anomaly = factor(Anomaly, levels = c('NORMAL', 'TENTATIVE', 'LOW', 'HIGH')))

DF <- with(DF, DF[order(Anomaly),])

dummyDF <- DF[!duplicated(DF$Anomaly),]
dummyDF$startDate <- as.Date(NA)

colours = c("NORMAL" = "darkgreen", "TENTATIVE" = "royalblue3", "LOW" = "orange", "HIGH" = "red")

# Info columns
VARS_info <- c('recordID',
               'startDate',
               'Category',
               'CategoryTRUEFALSE',
               'Duration',
               'Anomaly')

# Declare selector variables
VARS_selector <- c('companyName', 'wayPoint', 'Capacity', 'finalDestination')

# UI
ui <- navbarPage(title = "Anomaly Browser",
                 tabPanel("Browse data",
                          sidebarLayout(
                            sidebarPanel(
                              selectInput(
                                inputId = "companyName",
                                label = "Rail haul provider: ",
                                choices = sort(unique(DF$companyName)),
                                multiple = FALSE
                              ),
                              selectInput(
                                inputId = "wayPoint",
                                label = "Load point: ",
                                choices = NULL,
                                multiple = FALSE
                              ),
                              selectInput(
                                inputId = "capacity",
                                label = "Capacity: ",
                                choices = NULL,
                                multiple = FALSE
                              ),
                              selectInput(
                                inputId = "finalDestination",
                                label = "Terminal: ",
                                choices = NULL,
                                multiple = FALSE
                              ),
                              br(),
                              br(),
                              switchInput(
                                inputId = "category",
                                onLabel = "X",
                                offLabel = "Z",
                                onStatus = "GreenStatus",
                                offStatus = "RedStatus",
                                inline = TRUE,
                                value = TRUE,
                                size = 'large'
                              ),
                              br(),
                              br(),
                              downloadLink("downloadData", "Download plot data"),
                              br(),
                              width = 2,
                              # switchInput color while on
                              tags$head(tags$style(
                                HTML(
                                  '.bootstrap-switch .bootstrap-switch-handle-off.bootstrap-switch-GreenStatus,
                                   .bootstrap-switch .bootstrap-switch-handle-on.bootstrap-switch-GreenStatus {
                                     background: green; 
                                     color: white;
                                  }'
                                )
                              )),
                              # switchInput color while off
                              tags$head(tags$style(
                                HTML(
                                  '.bootstrap-switch .bootstrap-switch-handle-off.bootstrap-switch-RedStatus,
                                   .bootstrap-switch .bootstrap-switch-handle-on.bootstrap-switch-RedStatus {
                                     background: darkred;
                                     color: white;
                                  }'
                                )
                              )),
                            ),
                            mainPanel(
                              plotlyOutput(
                                outputId = "scatterplot",
                                width = "120%",
                                height = "800px"
                              ),
                              DT::dataTableOutput(outputId = "Table1", width = "125%")
                            )
                          )))

# Server
server <- function(input, output, session) {
  observeEvent(input$companyName, {
    updateSelectInput(session, 'wayPoint',
                      choices = sort(unique(DF$wayPoint[DF$companyName %in% input$companyName])))
  })
  observeEvent(input$wayPoint, {
    updateSelectInput(session, 'capacity',
                      choices = sort(unique(DF$Capacity[DF$wayPoint %in% input$wayPoint &
                                                          DF$companyName %in% input$companyName])))
  })
  observeEvent(input$capacity, {
    updateSelectInput(session, 'finalDestination',
                      choices = sort(unique(DF$finalDestination[DF$Capacity == input$capacity &
                                                                  DF$wayPoint %in% input$wayPoint &
                                                                  DF$companyName %in% input$companyName])))
  })
  observeEvent(input$wayPoint, {
    updateSelectInput(session, 'finalDestination',
                      choices = sort(unique(DF$finalDestination[DF$Capacity == input$capacity &
                                                                  DF$wayPoint %in% input$wayPoint &
                                                                  DF$companyName %in% input$companyName])))
  })
  observeEvent(input$finalDestination, {
    updateSelectInput(session, 'category',
                      choices = sort(unique(DF$Category[DF$finalDestination %in% input$finalDestination &
                                                          DF$Capacity == input$capacity &
                                                          DF$wayPoint %in% input$wayPoint &
                                                          DF$companyName %in% input$companyName])))
  })
  
  # Selected
  selected1 <- reactive({
    req(input$companyName,
        input$wayPoint,
        input$capacity,
        input$finalDestination)
    DF %>%
      select(all_of(VARS_info), all_of(VARS_selector)) %>%
      filter(
        companyName %in% input$companyName &
          wayPoint %in% input$wayPoint &
          Capacity == input$capacity &
          finalDestination %in% input$finalDestination &
          CategoryTRUEFALSE %in% input$category
      ) %>%
      select(-CategoryTRUEFALSE)
  })
  
  # Create scatterplot object the plotOutput function is expecting
  output$scatterplot <- renderPlotly({
    p <- ggplot(
      data = dummyDF,
      aes(x = startDate, y = Duration, color = Anomaly, A = startDate, B = Duration, C = recordID, D = Anomaly)
    ) + geom_point(
      pch = 21,
      fill = NA,
      size = 1.0,
      stroke = 1.5
    ) + geom_point(
      data = selected1(),
      pch = 21,
      fill = NA,
      size = 1.0,
      stroke = 1.5
    ) + scale_colour_manual(values = colours)
    
    p  <- p + ggtitle(
      paste0(
        input$companyName,
        " - ",
        input$wayPoint,
        " - ",
        input$finalDestination,
        " - ",
        input$capacity,
        " (",
        unique(selected1()$Category),
        ")"
      )
    ) +
      xlab('Cycle Start Date') + ylab("Duration  (mins)") + theme(text = element_text(size = 13))
    
    p  <- p + scale_x_date(date_breaks = "months", date_labels = "%b-%Y") +
      geom_smooth(
        method = "gam",
        formula = y ~ s(x, bs = "cs", k = 1),
        colour = "black",
        lwd = 0.7,
        se = FALSE
      )
    
    ggplotly(p, tooltip = c("A", "B", "C", "D")) %>% layout(legend = list(
      itemclick = FALSE,
      itemdoubleclick = FALSE,
      groupclick = FALSE,
      itemsizing = "constant",
      itemwidth = 100
      # x = [...],
      # xanchor = [...],
      # y = [...],
      # yanchor = [...]
    ))
  })
  
  # Data table Tab-1
  output$Table1 <- DT::renderDataTable({
    DT::datatable(
      data = selected1(),
      options = list(pageLength = 20),
      rownames = FALSE
    )
  })
  
  # Save CSV
  output$downloadData <- downloadHandler(
    filename = function() {
      paste0(
        input$companyName,
        '_',
        input$wayPoint,
        '_',
        input$finalDestination,
        '_',
        unique(selected1()$Category),
        '_',
        'cap=',
        input$capacity,
        '.csv'
      )
    },
    content = function(file) {
      write.csv(selected1(), file, row.names = FALSE)
    }
  )
}

# Create a Shiny app object
shinyApp(ui = ui, server = server)

我还在 ggplotly 上提供了一个 layout 调用，以避免图例点击, 拥有完全静态的图例。但不确定是否需要这样做。

关于图例位置，请运行 schema() 并导航：
对象 ► 布局 ► layoutAttributes ► 图例 ► x
有关参数的更多信息，例如：

设置图例的 x 位置（以标准化坐标表示）。
对于垂直图例，默认为 1.02；对于垂直图例，默认为 0
水平图例。

这里有关图例项的相关帖子可以找到尺寸。