Question

我正在drilldowns中的Highcharter上工作，我想根据列名创建自定义颜色配置文件。我能够对初始图形执行此操作，但无法在第二级（如果需要的话在随后的第三级）中执行此操作。目前，下钻只是采用初始列的颜色，我想为下钻提供自定义配色方案。

问题是我将Colors2放在list()中的地方。

下面是代码：

library (shinyjs)
library (tidyr)
library (data.table)
library (highcharter)
library (dplyr)
library (shinydashboard)
library (shiny)

x <- c("Farm","Farm","Farm","City","City","City","Ocean","Ocean")
y <- c("Sheep","Sheep","Cow","Car","Bus","Bus","Boat","Boat")
z <- c("Bill","Tracy","Sandy","Bob","Carl","Newt","Fig","Tony")
a <- c(1,1,1,1,1,1,1,1)

dat <- data.frame(x,y,z,a)

header <- dashboardHeader()
body <- dashboardBody(highchartOutput("Working"))
sidebar <- dashboardSidebar()

ui <- dashboardPage(header, sidebar, body)

server <- function(input, output, session) {


  output$Working <- renderHighchart({

    #Custom Color Profile
    Set1 <- dat$x == "Farm"
    Set1[is.na(Set1)] <- FALSE
    Set2 <- dat$x == "City"
    Set2[is.na(Set2)] <- FALSE
    Set3 <- dat$x == "Ocean"
    Set3[is.na(Set3)] <- FALSE
    dat[Set1, "Colors"] <- "#E4551F"
    dat[Set2, "Colors"] <- "#00AB8E"
    dat[Set3, "Colors"] <- "#E4551F"

    Set1 <- dat$y == "Sheep"
    Set1[is.na(Set1)] <- FALSE
    Set2 <- dat$y == "Cow"
    Set2[is.na(Set2)] <- FALSE
    Set3 <- dat$y == "Car"
    Set3[is.na(Set3)] <- FALSE
    Set4 <- dat$y == "Bus"
    Set4[is.na(Set4)] <- FALSE
    Set5 <- dat$y == "Boat"
    Set5[is.na(Set5)] <- FALSE
    dat[Set1, "Colors2"] <- "#009A00"
    dat[Set2, "Colors2"] <- "#F6FC00"
    dat[Set3, "Colors2"] <- "#FF7900"
    dat[Set4, "Colors2"] <- "#D20000"
    WIP[Set5, "Colors2"] <- "#009A00"

    #First Tier
    datSum <- dat %>%
      group_by(x, Colors) %>%
      summarize(Quantity = sum(a)
      )
    Lvl1dfStatus <- tibble(name = datSum$x, y = datSum$Quantity, Colors = datSum$Colors, drilldown = tolower(name))

    #Second Tier
    Level_2_Drilldowns <- lapply(unique(dat$x), function(x_level) {
      datSum2 <- dat[dat$x == x_level,]

      datSum2 <- datSum2 %>%
        group_by(y, Colors2) %>%
        summarize(Quantity = sum(a)
        )
      Lvl2dfStatus <- tibble(name = datSum2$y,y = datSum2$Quantity, Colors = datSum2$Colors2, drilldown = tolower(paste(x_level, name, sep = "_")))

      list(id = tolower(x_level), type = "column", data = list_parse(Lvl2dfStatus))
    })

    #Third Tier
    Level_3_Drilldowns <- lapply(unique(dat$x), function(x_level) {
      datSum2 <- dat[dat$x == x_level,]

      lapply(unique(datSum2$y), function(y_level) {
        datSum3 <- datSum2[datSum2$y == y_level,]

        datSum3 <- datSum3 %>%
          group_by(z) %>%
          summarize(Quantity = sum(a)
          )
        Lvl3dfStatus <- tibble(name = datSum3$z,y = datSum3$Quantity)

        list(id = tolower(paste(x_level, y_level, sep = "_")), type = "column", data = list_parse2(Lvl3dfStatus))
      })
    }) %>% unlist(recursive = FALSE)

    #Graph
    highchart() %>%
      hc_xAxis(type = "category") %>%
      hc_add_series(Lvl1dfStatus, "column", hcaes(x = name, y = y, color = Colors)) %>%
      hc_plotOptions(column = list(stacking = "normal")) %>%
      hc_drilldown(
        allowPointDrilldown = TRUE,
        series = c(Level_2_Drilldowns, Level_3_Drilldowns)
      )
  })

}


shinyApp(ui, server)

R Highcharter：自定义调色板，用于深化级别

0 个答案: