使用来自Flextable的add_header_row来创建不同宽度的列

Question

我的数据如下：

dat <- structure(list(rn = c("type_A", "type_B", "type_C"
), freq = list(c(0, 0, 0, 5, 7, 16, 28), c(2, 1, 0, 5, 0, 8), 
    c(0, 0, 3, 5, 12, 53, 73)), colspan = list(c(`25` = 1, `100` = 2, 
`250` = 1, `500` = 1, `1000` = 1, Infinity = 3, SUM = 1), c(`25` = 1, 
`100` = 2, `250` = 1, `500` = 1, Infinity = 4, SUM = 1), c(`25` = 1, 
`50` = 1, `100` = 1, `250` = 1, `500` = 1, Infinity = 4, SUM = 1
))), row.names = c(NA, 3L), class = "data.frame")

total_colspan = c(0, 25, 50, 100, 250, 500, 1000, 1500, 3000, "Infinity", "SUM")

      rn                   freq             colspan
1 type_A  0, 0, 0, 5, 7, 16, 28 1, 2, 1, 1, 1, 3, 1
2 type_B       2, 1, 0, 5, 0, 8    1, 2, 1, 1, 4, 1
3 type_C 0, 0, 3, 5, 12, 53, 73 1, 1, 1, 1, 1, 4, 1

我想创建一个带有不同列跨度的表（但它们都添加到10），在R-Markdown Word文档中，如下表：

建议我尝试flextable（链接）。我正在尝试使用标题选项来创建这些不同的Colspan。我考虑过这样的事情：

dat_table <- flextable(dat)
dat_table <- lapply(dat_table, add_header_row, values = unlist(freq), colwidths = unlist(colspan))

但这是不起作用的。

编辑：

我的第二次尝试：

dat <- structure(list(rn = c("type_A", "type_B", "type_C"
), freq = list(c(0, 0, 0, 5, 7, 16, 28), c(2, 1, 0, 5, 0, 8), 
    c(0, 0, 3, 5, 12, 53, 73)), colspan = list(c(1, 2, 1, 1, 1, 3, 1),  c(1, 2, 1, 1, 4, 1), c(1, 1, 1, 1,  1, 4, 1
))), row.names = c(NA, 3L), class = "data.frame")

# The thresholds as in the picture
thresholds <- data.frame(c("Lower threshold","Upper threshold"), c(0,25), c(25,50), c(50,100), c(100,250), c(250,500),c(500,1000),c(1000,1500),c(1500,3000),c(3000, "Infinity"), c("", "SUM"))
names(thresholds) <- c("One", "Two", "Three", "Four", "Five", "Six", "Seven", "Eight", "Nine", "Ten", "Eleven")
thresholds <- flextable(thresholds)

# There was one column to few in the example
dat <- transform(dat, colspan=Map('c', 1, dat[["colspan"]] ))
dat <- transform(dat, freq=Map('c', "", dat[["freq"]] ))

# for loop to stick to the syntax
for (i in nrow(dat)) {
 thresholds <- add_header_row(thresholds, values = dat[[2]][[i]], colwidths = dat[[3]][[i]])
}

出于某种原因，它仅添加一行（虽然允许添加更多标头）。

Answer 1

这是一个可能太过分的解决方案，但似乎可以执行您要寻找的事情：

library(tidyverse)
library(flextable)

dat <- structure(list(rn = c("type_A", "type_B", "type_C"
), freq = list(c(0, 0, 0, 5, 7, 16, 28), c(2, 1, 0, 5, 0, 8), 
               c(0, 0, 3, 5, 12, 53, 73)), colspan = list(c(1, 2, 1, 1, 1, 3, 1),  c(1, 2, 1, 1, 4, 1), c(1, 1, 1, 1,  1, 4, 1
               ))), row.names = c(NA, 3L), class = "data.frame")

# The thresholds as in the picture
thresholds <- data.frame(c("Lower threshold","Upper threshold"), c(0,25), c(25,50), c(50,100), c(100,250), c(250,500),c(500,1000),c(1000,1500),c(1500,3000),c(3000, "Infinity"), c("", "SUM"))
names(thresholds) <- c("One", "Two", "Three", "Four", "Five", "Six", "Seven", "Eight", "Nine", "Ten", "Eleven")

out <- map(1:nrow(dat), function(index){
  out <- data.frame("freq" = dat$freq[[index]], 
                    "span" = dat$colspan[[index]]) %>% 
    tidyr::uncount(span, .id = 'span') %>% 
    mutate(freq = ifelse(span>1, NA, freq)) %>% 
    t %>% 
    as.data.frame() %>% 
    mutate(rn = dat$rn[[index]],
           across(everything(), ~as.character(.))) %>% 
    select(rn, everything()) %>% 
    set_names(nm = names(thresholds)) %>% 
    slice(1)
  return(out)
}) 

combined <- thresholds %>% 
  mutate(across(everything(),  ~as.character(.))) %>% 
  bind_rows(out) 

spans <- map(1:length(dat$colspan), function(index){
  spans <- dat$colspan[[index]] %>%  
    as_tibble() %>% 
    mutate(idx = row_number()) %>% 
    tidyr::uncount(value, .remove = F) %>% 
    group_by(idx) %>%
    mutate(pos = 1:n(),
           value = ifelse(pos != 1, 0, value)) %>% 
    ungroup() %>% 
    select(value) %>% 
    t
  return(append(1, spans))
})

myft <- flextable(combined) %>% 
  theme_box()

myft$body$spans$rows[3:nrow(myft$body$spans$rows),] <- matrix(unlist(spans), ncol = ncol(combined), byrow = TRUE)

myft

^{由 reprex软件包（v2.0.1）}

这使表：

Answer 2

我认为您无法在这里通过Colspan选项，而无需黑客攻击。如果可能的话，我建议您添加需要手动组合的细胞。据我所知，这是Flextable：

library(flextable)
library(tidyverse)

# clean up the object
dat_clean <- dat %>% 
  mutate(freq = map2(freq, colspan, ~rep(.x, .y))) %>% 
  select(-colspan) %>% 
  unnest(freq) %>% 
  group_by(rn) %>% 
  mutate(col = paste0("col_", row_number())) %>% 
  pivot_wider(names_from = col, values_from = freq)

flextable(dat_clean) %>% 
  merge_at(i = 1, j = 3:4, part = "body") %>% 
  merge_at(i = 1, j = 7:9, part = "body") %>% 
  border_inner(part="all", border = fp_border_default()) %>% 
  align(align = "center", part = "all")

^由

Answer 3

合并这两个表有点棘手。这是我最接近复制您所需的桌子的最接近的。首先，我以合适的方式创建了您的数据：

thresholds <- data.frame(c("Lower threshold", "Upper threshold", "type_A", "type_B", "type_C"), 
                         c(0,25, 0, 2, 0), 
                         c(25,50, 0, 1, 0), 
                         c(50,100, NA, NA,3), 
                         c(100,250,0,0,5), 
                         c(250,5005,5,5,12),
                         c(500,1000,7,0,53),
                         c(1000,1500,16,NA,NA),
                         c(1500,3000,NA,NA,NA),
                         c(3000, "Infinity",NA,NA,NA), 
                         c("SUM", "SUM", 28,8,73))
names(thresholds) <- c("One", "Two", "Three", "Four", "Five", "Six", "Seven", "Eight", "Nine", "Ten", "Eleven")

使用官员软件包，您可以提供您想要的水平和垂直线不同的颜色。使用Merge_at函数您可以合并某些单元格。使用Border_inner功能，您可以在表中获得边框。您可以使用以下代码：

library(officer)
std_border = fp_border(color="gray")

library(flextable)
library(dplyr)
thresholds %>%
  flextable() %>%
  merge_at(i = 3, j = 3:4, part = "body") %>% 
  merge_at(i = 4, j = 3:4, part = "body") %>% 
  merge_at(i = 3, j = 8:10, part = "body") %>%
  merge_at(i = 4, j = 7:10, part = "body") %>% 
  merge_at(i = 5, j = 7:10, part = "body") %>% 
  border_inner(border = std_border) %>%
  align(align = "left", part = "all") 

输出：