根据闪亮应用程序中的输入选择设置图例标签

Question

在下面闪亮的应用程序中，我想用以下逻辑修改图例中的名称。当 geom_line(aes(x,y)) 时，除了品牌名称应粘贴 Sell Out，当 geom_line(aes(x1,y1)) 时，除了品牌名称应粘贴 Gross Sales，当 geom_line(aes(x2,y2)) 时，此外品牌名称应粘贴 Gross Profit。例如 CHOKIS Sell Out.

## app.R ##
library(shiny)
library(shinydashboard)
library(plotly)
BRAND<-c("CHOKIS","CHOKIS","CHOKIS","CHOKIS","CHOKIS","CHOKIS","LARA CHOCO CHIPS","LARA CHOCO CHIPS","LARA CHOCO CHIPS")
BRAND_COLOR<-c("#8050f0","#8050f0","#8050f0","#8050f0","#8050f0","#8050f0","#f050c0","#f050c0","#f050c0")

x<-c(23,34,56,77,78,34,34,64,76)
y<-c(43,54,76,78,87,98,76,76,56)
x1<-c(23,34,56,75,78,34,34,64,76)
y1<-c(33,54,76,76,87,98,76,76,56)
x2<-c(53,34,56,77,78,34,34,84,76)
y2<-c(63,54,76,78,87,98,76,76,86)
r<-c(58,46,76,76,54,21,69,98,98)

graph1.data<-data.frame(BRAND,BRAND_COLOR,x,y,x1,y1,x2,y2)



ui <- dashboardPage(
  dashboardHeader(),
  dashboardSidebar(
    selectInput("metric","Metric",c('Gross Sales','Gross Profit','Sell Out'),multiple = T,selected = "Sell Out")
  ),
  dashboardBody(
    plotlyOutput("line")
  )
)

server <- function(input, output) {
  brand.colors <- graph1.data$BRAND_COLOR
  names(brand.colors) <- graph1.data$BRAND
  
  output$line<-renderPlotly({
    metric<-input$metric
    
    if(length(metric) == 1) {
      for ( i in 1:length(brand.colors))
      {
        graph1.data$BRAND[i]=paste(graph1.data$BRAND[i],metric)
      }
      #print(graph1.data$BRAND)
      if (metric!="Sell Out"){
        brand.colors <- c(rep("gray",length(graph1.data$BRAND)))
        graph1.data$BRAND = c("Insignificant")
       
      }
      
      names(brand.colors) <- graph1.data$BRAND
      
      p <- graph1.data %>% ggplot2::ggplot(aes(x, y, color = BRAND))
      p <- p + 
        ggplot2::geom_line(aes(x)) + 
        # warnings suppressed on text property
        suppressWarnings(ggplot2::geom_point(aes(x, y, size = r), show.legend = TRUE)) +
        ggplot2::scale_color_manual(values = brand.colors)
      
    }else if(length(metric) == 2) {
      for ( i in 1:length(brand.colors)) {
        graph1.data$BRAND[i]=paste(graph1.data$BRAND[i],metric[2])
        graph1.data$BRAND1[i]=paste(graph1.data$BRAND[i],metric[1])  ## not sure what this is for
      }
      names(brand.colors) <- graph1.data$BRAND
      
      if ((metric[1]=="Sell Out") || (metric[2]=="Sell Out")) {
        
        p <- graph1.data %>%  ggplot2::ggplot(aes(x1, y1, color = BRAND)) +
          geom_line(linetype="dashed") + geom_point()+
          # warnings suppressed on text property
          suppressWarnings(ggplot2::geom_point(aes(x1, y1, size = r), show.legend = TRUE)) +
          scale_color_manual(values = brand.colors,labels=brand.colors)
        
        p <- p +
          geom_line(aes(x,y),color=brand.colors) + geom_point()+
          suppressWarnings(ggplot2::geom_point(aes(x, y, size = r), show.legend = TRUE)) #+
        # scale_color_manual(values = brand.colors,labels=brand.colors)
        
      } else { # if ((metric[1]!="Sell Out") && (metric[2]!="Sell Out"))
        
        p <- graph1.data %>%  ggplot2::ggplot(aes(x,y,color=BRAND)) +
          geom_line() + geom_point() +  
          # warnings suppressed on text property
          suppressWarnings(ggplot2::geom_point(aes(x, y, size = r), show.legend = TRUE))  +
          ggplot2::scale_color_manual(values = brand.colors,labels=brand.colors)
        
        p <- p + geom_line(aes(x1, y1,linetype="dashed"),color=brand.colors) + geom_point() +
          suppressWarnings(ggplot2::geom_point(aes(x1, y1, size = r), show.legend = TRUE)) #+
        # ggplot2::scale_color_manual(values = brand.colors,labels=brand.colors)
      }
    } else if(length(metric) == 3) {
      p <- graph1.data %>%
        ggplot2::ggplot(aes(x=x2, y=y2,color=BRAND))
      p<- p+
        geom_line(aes(x2),linetype="dotted") +
        suppressWarnings(ggplot2::geom_point(aes(x2, y2, size = r), show.legend = TRUE))
      
      
      
      brand.colors1<-graph1.data$BRAND_COLOR
      names(brand.colors1) <- graph1.data$BRAND
      p<- p+
        geom_line(aes(x1,y1,linetype="dashed")) +
        suppressWarnings(ggplot2::geom_point(aes(x1, y1, size = r), show.legend = TRUE)) #+
      # ggplot2::scale_color_manual(values = brand.colors1)
      p <- p +
        geom_line(aes(x,y)) +
        # warnings suppressed on text property
        suppressWarnings(ggplot2::geom_point(aes(x, y, size = r), show.legend = TRUE))+
        ggplot2::scale_color_manual(values = brand.colors1)
      
    }
    
  })
  
}


shinyApp(ui, server)

Answer 1

如果您以长格式设置数据框，可能会更容易。

试试这个

## app.R ##
library(shiny)
library(shinydashboard)
library(plotly)
library(tidyr)
BRAND<-c("CHOKIS","CHOKIS","CHOKIS","CHOKIS","CHOKIS","CHOKIS","LARA CHOCO CHIPS","LARA CHOCO CHIPS","LARA CHOCO CHIPS")
BRAND_COLOR<-c("#8050f0","#8050f0","#8050f0","#8050f0","#8050f0","#8050f0","#f050c0","#f050c0","#f050c0")

x<-c(23,34,56,77,78,34,34,64,76)
y<-c(43,54,76,78,87,98,76,76,56)
x1<-c(23,34,56,75,78,34,34,64,76)
y1<-c(33,54,76,76,87,98,76,76,56)
x2<-c(53,34,56,77,78,34,34,84,76)
y2<-c(63,54,76,78,87,98,76,76,86)
r<-c(58,46,76,76,54,21,69,98,98)

mt <- c('Sell Out','Gross Sales','Gross Profit')

graph1.data<-data.frame(BRAND,BRAND_COLOR,x,y,x1,y1,x2,y2)

ui <- dashboardPage(
  dashboardHeader(),
  dashboardSidebar(
    selectInput("metric","Metric",c('Gross Sales','Gross Profit','Sell Out'),multiple = T,selected = "Sell Out")
  ),
  dashboardBody(
    plotlyOutput("line")
  )
)

server <- function(input, output) {

  mydata <- eventReactive(input$metric,{
    
    df <- graph1.data %>% rename(x0=x,y0=y) %>% 
      dplyr::mutate(row = 1:n(),r=r) %>% 
      pivot_longer(cols = -c(row,BRAND,BRAND_COLOR,r))   %>% 
      separate(col = name, into = c("var", "series"), sep = 1) %>%
      pivot_wider(id_cols = c(BRAND,BRAND_COLOR,r,row, series), names_from = "var", values_from = "value") %>% 
      dplyr::mutate(metric=ifelse(series==0,mt[1],ifelse(series==1,mt[2],mt[3]))) %>% 
      dplyr::mutate(label=ifelse(series==0,paste(BRAND,mt[1]),ifelse(series==1,paste(BRAND,mt[2]),paste(BRAND,mt[3])))) %>% print(n=Inf)
    
    df %>% dplyr::filter(metric %in% input$metric)
  })

  myplot <- reactive({
    req(mydata(),input$metric)
    brand.colors <- mydata()$BRAND_COLOR
    names(brand.colors) <- mydata()$label
    
    if(length(input$metric) == 1) {
      p <- mydata() %>% ggplot2::ggplot(aes(x, y, color = label))
    }else {
      p <- mydata() %>% ggplot2::ggplot(aes(x, y, group=metric, color = label))
    }
    p <- p + ggplot2::geom_line(aes(x)) +
      # warnings suppressed on text property
      suppressWarnings(ggplot2::geom_point(aes(x, y, size = r), show.legend = TRUE)) +
      ggplot2::scale_color_manual(values = brand.colors)
    p
  })

  output$line <- renderPlotly({
    req(myplot())
    ggplotly(myplot())
  })
}

shinyApp(ui, server)

根据闪亮应用程序中的输入选择设置图例标签

Set the labels of legend based on input selection in shiny app

r

ggplot2

shiny