highcharts 如何在highcharter中为多个箱线图系列设置下钻功能？

以下解决方案

原始问题：*

我试图在highcharter中创建一个使用箱线图的下钻图。
这里的目标是从每月时间尺度的箱形图开始。过程如下：
1.初始视图-以月份为x轴的箱线图
1.单击特定月份可深入查看一系列新的箱线图，其中x轴是构成所选月份的周数
1.最后，单击所选月份中的某周，然后深入查看一系列新的箱线图，其中x轴表示该周的特定日期。
需要注意的是，我以两种方式修改了data_to_boxplot函数。首先，在get_box_values中添加了显示观测数的功能。其次，我在data_to_boxplot中添加了一个与系列名称相对应的下钻字段。该字段在hc_drilldown中使用

代码：

library(purrr)
library(dplyr)
library(tidyr)
library(lubridate)
library(highcharter)
library(data.table)

# Helper functions

group_by_timescale = function(x,unit="day") {
  if (unit=="month") {
    lubridate::rollback(x, roll_to_first = TRUE)
  } else if (unit=="week") {
    floor_date(x, "week", week_start = 1)+6
  } else if (unit=="day") {
    x
  }
}
get_box_values <- function(x) {
  boxplot.stats(x)$stats %>% 
    t() %>% 
    cbind(boxplot.stats(x)$n) %>% 
    as.data.frame() %>%
    setNames(c("low", "q1", "median", "q3", "high", "obs"))
}
get_outliers_values <- function(x) {
  boxplot.stats(x)$out
}

# Modified highcharter function

data_to_boxplot_2 = function (data, variable, group_var = NULL, group_var2 = NULL, add_outliers = FALSE, ...) {
  stopifnot(is.data.frame(data), !missing(variable))
  # browser()
  dx <- data %>% 
    transmute(`:=`(x, {
      {
        variable
      }
    }))
  if (!missing(group_var)) {
    dg <- data %>% select({
      {
        group_var
      }
    })
  }
  else {
    dg <- data.frame(rep(0, nrow(dx)))
  }
  if (!missing(group_var2)) {
    dg2 <- data %>% select({
      {
        group_var2
      }
    })
  }
  else {
    dg2 <- data.frame(rep(NA, nrow(dx)))
  }
  dg <- dg %>% setNames("name")
  dg2 <- dg2 %>% setNames("series")
  dat <- bind_cols(dx, dg, dg2)
  dat1 <- dat %>% 
    group_by(series, name) %>% 
    summarise(data = list(get_box_values(x)),.groups = "drop") %>% 
    unnest(cols = data) %>%
    mutate(drilldown = name) %>% # add drilldown name to series
    group_nest(series) %>% 
    mutate(data = map(data, list_parse)) %>% 
    rename(name = series) %>% 
    mutate(id = name) %>% 
    mutate(type = "boxplot", ...)

  if (add_outliers) {
    dat2 <- dat %>% 
      mutate(name = as.numeric(factor(name)) - 1) %>% 
      group_by(series, name) %>% 
      summarise(y = list(get_outliers_values(x)),.groups = "drop") %>% 
      unnest(cols = y) %>% 
      rename(x = name) %>% 
      group_nest(series) %>% 
      mutate(data = map(data, list_parse)) %>% 
      rename(linkedTo = series) %>% 
      mutate(type = "scatter", showInLegend = FALSE, ...)

    dout <- bind_rows(dat1, dat2)
  }
  else {
    dout <- dat1
  }
  dout
}

# Sample data

dates = sort(rep(seq.Date(from = as_date("2021-01-01"), to = as_date("2021-12-31"), by = "day"),15))
data = data.table(
  day = dates,
  values = floor(runif(length(dates), 0, 1000))
)

data[, `:=` (
  weeks = group_by_timescale(day, "week"),
  months = group_by_timescale(day, "month")
)]

# Create Boxplot series

month_dt = data_to_boxplot_2(data, variable = values, group_var = months, name = "month")
week_dt = data_to_boxplot_2(data, variable = values, group_var = weeks, group_var2 = months, name = "week")
day_dt = data_to_boxplot_2(data, variable = values, group_var = day, group_var2 = weeks, name = "day")

# Drilldown HC plot

hc <- highchart() %>%
  hc_title(text = "Basic drilldown") %>%
  hc_xAxis(type = "category") %>%
  hc_legend(enabled = FALSE) %>%
  hc_plotOptions(series = list(borderWidth = 0,dataLabels = list(enabled = TRUE))) %>%
  hc_add_series_list(month_dt) %>%
  hc_drilldown(allowPointDrilldown = TRUE,
               series = list(week_dt, day_dt))

下面是图输出的图像。单击X轴值时，应该会生成一个新的箱形图，但没有任何React。我怀疑这与我的数据分组方式有关，但不确定。任何有关此方面的帮助都是很好的！谢谢x1c 0d1x

EDIT：解决方案

我对R还是一个新手，所以我的解释可能无意中忽略了一些细节。我发现hc_drilldown(series)需要一个highcharts series选项中的序列配置数组。当使用data_to_boxplot函数时，输出是一个带有嵌套列表的tibble。因此，为了将向下钻取序列添加到hc_drilldown中，需要将tibble解析为列表。使用highcharter::list_parse2删除所有名称，我需要保留序列中的名称值，如“name”、“id”等。
我创建了一个函数来输出n个向下钻取序列的hc向下钻取箱形图。在我的示例中，我最终使用了rlist::list.parse(series) %>% setNames(NULL)，因为这只会删除列表中的顶级名称，但现在我想起来了，我确信highcharter::list_parse也能正常工作（谢谢@Kat）。然后，我需要做的就是在hc_drilldown中使用c()追加列表。需要注意的是，所使用的下钻列中的值需要是唯一的，即具有唯一的“id”，否则，单击第一个系列下钻可能会绕过中间级别而直接转到最细的系列。在下面的示例中，点击每月“2021-08-01”将跳过8月份的周，并转到日钻取系列。

新工作代码

library(purrr)
library(dplyr)
library(tidyr)
library(lubridate)
library(highcharter)
library(data.table)

# Helper functions

group_by_timescale = function(x,unit="day") {
  if (unit=="month") {
    lubridate::rollback(x, roll_to_first = TRUE)
  } else if (unit=="week") {
    floor_date(x, "week", week_start = 1)+6
  } else if (unit=="day") {
    x
  }
}
get_box_values <- function(x) {
  boxplot.stats(x)$stats %>% 
    t() %>% 
    cbind(boxplot.stats(x)$n) %>% 
    as.data.frame() %>%
    setNames(c("low", "q1", "median", "q3", "high", "obs"))
}
get_outliers_values <- function(x) {
  boxplot.stats(x)$out
}

# Modified HC function

data_to_boxplot_2 = function (data, variable, group_var = NULL, group_var2 = NULL, 
drilldown = FALSE, add_outliers = FALSE, ...) {
  stopifnot(is.data.frame(data), !missing(variable))
  # browser()
  dx <- data %>% 
    transmute(`:=`(x, {
      {
        variable
      }
    }))
  if (!missing(group_var)) {
    dg <- data %>% select({
      {
        group_var
      }
    })
  }
  else {
    dg <- data.frame(rep(0, nrow(dx)))
  }
  if (!missing(group_var2)) {
    dg2 <- data %>% select({
      {
        group_var2
      }
    })
  }
  else {
    dg2 <- data.frame(rep(NA, nrow(dx)))
  }
  dg <- dg %>% setNames("name")
  dg2 <- dg2 %>% setNames("series")
  dat <- bind_cols(dx, dg, dg2)
  dat1 <- dat %>% 
    group_by(series, name) %>% 
    summarise(data = list(get_box_values(x)),.groups = "drop") %>% 
    unnest(cols = data)

  if(drilldown) {
    dat1 <- dat1 %>%
      mutate(drilldown = name)
  }

  dat1 <- dat1 %>%
    group_nest(series) %>% 
    mutate(data = map(data, list_parse)) %>% 
    rename(name = series) %>% 
    mutate(id = name) %>% 
    mutate(type = "boxplot", ...)

  if (add_outliers) {
    dat2 <- dat %>% 
      mutate(name = as.numeric(factor(name)) - 1) %>% 
      group_by(series, name) %>% 
      summarise(y = list(get_outliers_values(x)),.groups = "drop") %>% 
      unnest(cols = y) %>% 
      rename(x = name) %>% 
      group_nest(series) %>% 
      mutate(data = map(data, list_parse)) %>% 
      rename(linkedTo = series) %>% 
      mutate(type = "scatter", showInLegend = FALSE, ...)

    dout <- bind_rows(dat1, dat2)
  }
  else {
    dout <- dat1
  }
  dout
}

# Sample data

dates = sort(rep(seq.Date(from = as_date("2021-01-01"), to = as_date("2021-12-31"), by = "day"),15))
data = data.table(
  day = dates,
  values = floor(runif(length(dates), 0, 1000))
)

data[, `:=` (
  weeks = group_by_timescale(day, "week"),
  months = group_by_timescale(day, "month")
)]

# vector indicating the relationship between each drilldown series

# the first position is the top level

groups = c("months", "weeks", "day")

# create hc drilldown boxplot

drilldown_boxplot = function(dt, var, dd_groups, parent_name = "Monthly") {
  dd_size = length(dd_groups)
  all_dd = list()

  # create boxplot series lists
  for (idx in 1:dd_size) {
    if (idx == 1) {
      all_dd[[idx]] = data_to_boxplot_2(dt, variable = get(var), group_var = dd_groups[idx], 
                                         drilldown = TRUE, name = parent_name)
    } else if (idx == length(dd_groups)) {
      all_dd[[idx]] = data_to_boxplot_2(dt, variable = get(var), group_var = dd_groups[idx], 
                                         group_var2 = dd_groups[idx-1])
    } else {
      all_dd[[idx]] = data_to_boxplot_2(dt, variable = get(var), group_var = dd_groups[idx], 
                                         group_var2 = dd_groups[idx-1], drilldown = TRUE)
    }
  }

  parent_series = all_dd[[1]]
  child_series = tail(all_dd, dd_size-1)
  child_series_exp = c()

  # parse lists to be readable in hc_drilldown
  for (i in 1:length(child_series)) {
    s = rlist::list.parse(child_series[[i]]) %>% setNames(NULL)
    child_series_exp = c(child_series_exp, s)
  }

  # create hc drilldown boxplot
  hc = highchart() %>%
    hc_xAxis(type = "category") %>%
    hc_legend(enabled = FALSE) %>%
    hc_plotOptions(series = list(borderWidth = 0, dataLabels = list(enabled = TRUE))) %>%
    hc_add_series_list(parent_series) %>%
    hc_drilldown(allowPointDrilldown = TRUE,
                 series = child_series_exp)

  return(hc)
}

drilldown_boxplot(data, "values", groups)

我只是错过了数据的存在，对此感到抱歉。你确实提供了很多内容。
我可以让你的第一个钻取到周，但另一个层次到天。我实际上还没有能够找到任何例子，该级别的任何其他。我发现这是奇怪的。我知道我的天与PowerBI工作有多个层次的钻取。如果这是可能的，在HC，我还没有弄清楚。
您只需要修改对hc_drilldown的调用。

hc_drilldown(allowPointDrilldown = TRUE,
             series = list_parse(week_dt))

整个调用创建hc：


# Drilldown HC plot

(hc <- highchart() %>%
  hc_title(text = "Basic drilldown") %>%
  hc_xAxis(type = "category") %>%
  hc_legend(enabled = FALSE) %>%
  hc_plotOptions(series = list(borderWidth = 0,
                               dataLabels = list(enabled = TRUE))) %>%
  hc_add_series_list(month_dt) %>%
  hc_drilldown(allowPointDrilldown = TRUE,
               series = list_parse(week_dt))

我觉得必须有一种方法来添加另一个深入层次。如果我弄清楚了，我会编辑我的答案。

已更新 *

根据前后的评论，我更改了属性：向下钻取、id和名称来尝试获取highcharter以识别第三级深度。这不一定能正常工作，因为我认为在您更新的问题（解决方案？）中数据的结构发生了变化。哎呀，您知道我的意思。
在创建对象week_dt之前，我添加了data[, "weeks" := lubridate::week(weeks)]以将嵌套周内容的id更改为周编号。
在创建了months_dt、weeks_dt和day_dt之后，我更改了属性。
在months_dt中，我将属性drilldown更改为月份标签。当创建m2时，它只是一个月份列表，我随后会使用它。我在代码中使用<<-来更改months_dt。

m2 <- lapply(1:length(month_dt$data[[1]]), 
             function(x){
               val <- month_dt$data[[1]][[x]][[8]]
               month_dt$data[[1]][[x]][[8]] <<- lubridate::month(val, 
                                                                 label = T) %>% 
                 as.character()
             })

然后使用m2使months_dt中的属性drilldown与附加到特定月份组（而不是嵌套周的数据）的每个周组的name和id匹配。

week_dt$id <- unlist(m2)
week_dt$name <- unlist(m2)

我修改了对象days_dt的分组名称，使之与周内的drilldown相匹配，即一年中的1：52周。由于id已经包含了这些信息，所以我使用了它。

day_dt$name <- day_dt$id

然后，当仍然没有创建一个能够生成第三级下钻的关系时（您现在已经在工作了），我从day_dt中删除了drilldown属性。

lapply(1:length(day_dt$data),
       function(x) {
         lapply(1:length(day_dt$data[[x]]),
                function(y){
                  day_dt$data[[x]][[y]][8] <<- NULL
                })
       })

这并没有像我希望的那样起作用，所以我最初没有包含它。也许星期数字需要是字符字段，在drilldown和name/id之间？这似乎不太可能，因为日期类型和字符类型都适用于月和星期之间。

highcharts 如何在highcharter中为多个箱线图系列设置下钻功能？

以下解决方案

代码：

EDIT：解决方案

新工作代码

1条答案

相关问题

热门标签

最新问答