add target in collapse_rows #484
diff --git a/R/collapse_rows.R b/R/collapse_rows.R
index 4ae0145..e520b40 100644
--- a/R/collapse_rows.R
+++ b/R/collapse_rows.R
@@ -7,7 +7,7 @@
#' specify column styles, you should use `column_spec` before `collapse_rows`.
#'
#' @param kable_input Output of `knitr::kable()` with `format` specified
-#' @param columns A numeric value or vector indicating in which column(s) rows
+#' @param columns A numeric value or vector indicating in which column(s) rows
#' need to be collapsed.
#' @param valign Select from "top", "middle"(default), "bottom". The reason why
#' "top" is not default is that the multirow package on CRAN win-builder is
@@ -35,7 +35,8 @@
row_group_label_position = c('identity', 'stack'),
custom_latex_hline = NULL,
row_group_label_fonts = NULL,
- headers_to_remove = NULL) {
+ headers_to_remove = NULL,
+ target = NULL) {
kable_format <- attr(kable_input, "format")
if (!kable_format %in% c("html", "latex")) {
warning("Please specify format in kable. kableExtra can customize either ",
@@ -44,8 +45,13 @@
return(kable_input)
}
valign <- match.arg(valign, c("middle", "top", "bottom"))
+ if (!is.null(target)) {
+ if (length(target) > 1 && is.integer(target)) {
+ stop("target can only be a length 1 integer")
+ }
+ }
if (kable_format == "html") {
- return(collapse_rows_html(kable_input, columns, valign))
+ return(collapse_rows_html(kable_input, columns, valign, target))
}
if (kable_format == "latex") {
latex_hline <- match.arg(latex_hline, c("full", "major", "none", "custom"))
@@ -57,22 +63,27 @@
}
}
-collapse_rows_html <- function(kable_input, columns, valign) {
+collapse_rows_html <- function(kable_input, columns, valign, target) {
kable_attrs <- attributes(kable_input)
- kable_xml <- read_kable_as_xml(kable_input)
+ kable_xml <- kable_as_xml(kable_input)
kable_tbody <- xml_tpart(kable_xml, "tbody")
kable_dt <- rvest::html_table(xml2::read_html(as.character(kable_input)))[[1]]
if (is.null(columns)) {
columns <- seq(1, ncol(kable_dt))
}
+ if (!is.null(target)) {
+ if (!target %in% columns) {
+ stop("target has to be within the range of columns")
+ }
+ }
if (!is.null(kable_attrs$header_above)) {
kable_dt_col_names <- unlist(kable_dt[kable_attrs$header_above, ])
kable_dt <- kable_dt[-(1:kable_attrs$header_above),]
names(kable_dt) <- kable_dt_col_names
}
- kable_dt$row_id <- seq(nrow(kable_dt))
- collapse_matrix <- collapse_row_matrix(kable_dt, columns)
+ # kable_dt$row_id <- seq(nrow(kable_dt))
+ collapse_matrix <- collapse_row_matrix(kable_dt, columns, target = target)
for (i in 1:nrow(collapse_matrix)) {
matrix_row <- collapse_matrix[i, ]
@@ -101,17 +112,34 @@
return(out)
}
-collapse_row_matrix <- function(kable_dt, columns, html = T) {
+split_factor <- function(x) {
+ group_idx <- seq(1, length(x))
+ return(factor(unlist(lapply(group_idx, function(i) {rep(i, x[i])}))))
+}
+
+collapse_row_matrix <- function(kable_dt, columns, html = T, target = NULL) {
if (html) {
column_block <- function(x) c(x, rep(0, x - 1))
} else {
column_block <- function(x) c(rep(0, x - 1), x)
}
mapping_matrix <- list()
- for (i in columns) {
- mapping_matrix[[paste0("x", i)]] <- unlist(lapply(
- rle(kable_dt[, i])$lengths, column_block))
+ if (is.null(target)) {
+ for (i in columns) {
+ mapping_matrix[[paste0("x", i)]] <- unlist(lapply(
+ rle(kable_dt[, i])$lengths, column_block))
+ }
+ } else {
+ target_group = split_factor(rle(kable_dt[, target])$lengths)
+ for (i in columns) {
+ column_split = split(kable_dt[, i], target_group)
+ mapping_matrix[[paste0("x", i)]] <- unlist(lapply(
+ column_split, function(sp) {
+ lapply(rle(sp)$length, column_block)
+ }))
+ }
}
+
mapping_matrix <- data.frame(mapping_matrix)
return(mapping_matrix)
}