Merge pull request #159 from georgegui/master

Add a new layout and other features for collapse_rows for LaTeX
diff --git a/R/collapse_rows.R b/R/collapse_rows.R
index ec33c5a..98a6ba2 100644
--- a/R/collapse_rows.R
+++ b/R/collapse_rows.R
@@ -9,7 +9,16 @@
 #' @param kable_input Output of `knitr::kable()` with `format` specified
 #' @param columns Numeric column positions where rows need to be collapsed.
 #' @param latex_hline Option controlling the behavior of adding hlines to table.
-#' Choose from `full`, `major`, `none`.
+#' Choose from `full`, `major`, `none`, `custom`.
+#' @param custom_latex_hline Numeric column positions whose collapsed rows will
+#' be separated by hlines.
+#' @param row_group_label_position Option controlling positions of row group
+#' labels. Choose from `identity`, `stack`.
+#' @param row_group_label_fonts A list of arguments that can be supplied to
+#' group_rows function to format the row group label when
+#' `row_group_label_position` is `stack`
+#' @param headers_to_remove Numeric column positions where headers should be
+#' removed when they are stacked.
 #'
 #' @examples dt <- data.frame(a = c(1, 1, 2, 2), b = c("a", "a", "a", "b"))
 #' x <- knitr::kable(dt, "html")
@@ -17,7 +26,11 @@
 #'
 #' @export
 collapse_rows <- function(kable_input, columns = NULL,
-                          latex_hline = c("full", "major", "none")) {
+                          latex_hline = c("full", "major", "none", "custom"),
+                          row_group_label_position = c('identity', 'stack'),
+                          custom_latex_hline = NULL,
+                          row_group_label_fonts = NULL,
+                          headers_to_remove = NULL) {
   # if (is.null(columns)) {
   #   stop("Please specify numeric positions of columns you want to collapse.")
   # }
@@ -32,8 +45,12 @@
     return(collapse_rows_html(kable_input, columns))
   }
   if (kable_format == "latex") {
-    latex_hline <- match.arg(latex_hline, c("full", "major", "none"))
-    return(collapse_rows_latex(kable_input, columns, latex_hline))
+    latex_hline <- match.arg(latex_hline, c("full", "major", "none", "custom"))
+    row_group_label_position <- match.arg(row_group_label_position,
+                                          c('identity', 'stack'))
+    return(collapse_rows_latex(kable_input, columns, latex_hline,
+      row_group_label_position, row_group_label_fonts, custom_latex_hline,
+      headers_to_remove))
   }
 }
 
@@ -96,7 +113,9 @@
   return(mapping_matrix)
 }
 
-collapse_rows_latex <- function(kable_input, columns, latex_hline) {
+collapse_rows_latex <- function(kable_input, columns, latex_hline,
+                                row_group_label_position, row_group_label_fonts,
+                                custom_latex_hline, headers_to_remove) {
   table_info <- magic_mirror(kable_input)
   out <- enc2utf8(as.character(kable_input))
 
@@ -106,6 +125,8 @@
 
   contents <- table_info$contents
   kable_dt <- kable_dt_latex(contents)
+
+  collapse_matrix_rev <- collapse_row_matrix(kable_dt, columns, html = TRUE)
   collapse_matrix <- collapse_row_matrix(kable_dt, columns, html = FALSE)
 
   new_kable_dt <- kable_dt
@@ -115,9 +136,15 @@
       is.null(table_info$column_width[[paste0("column_", columns[j])]]),
       "*", table_info$column_width[paste0("column_", columns[j])])
     for (i in seq(1:nrow(collapse_matrix))) {
-      new_kable_dt[i, j] <- collapse_new_dt_item(
-        kable_dt[i, j], collapse_matrix[i, j], column_width, align = column_align
-      )
+      if(row_group_label_position == 'stack'){
+        if(j < ncol(collapse_matrix)|(collapse_matrix_rev[i, j] == 0)){
+          new_kable_dt[i, j] <- ''
+        }
+      } else {
+        new_kable_dt[i, j] <- collapse_new_dt_item(
+          kable_dt[i, j], collapse_matrix[i, j], column_width, align = column_align
+        )
+      }
     }
   }
 
@@ -132,6 +159,20 @@
   }
 
   new_contents <- c()
+  if(row_group_label_position == 'stack'){
+    if(is.null(headers_to_remove)) headers_to_remove <- head(columns, -1)
+    table_info$colnames[headers_to_remove] <- ''
+    new_header <- paste(table_info$colnames, collapse = ' & ')
+    out <- sub(contents[1], new_header, out)
+    table_info$contents[1] <- new_header
+  }
+  if(latex_hline == 'custom' & is.null(custom_latex_hline)){
+    if(row_group_label_position == 'stack'){
+      custom_latex_hline = 1:2
+    } else {
+      custom_latex_hline = 1
+    }
+  }
   for (i in seq(1:nrow(collapse_matrix))) {
     new_contents[i] <- paste0(new_kable_dt[i, ], collapse = " & ")
     table_info$contents[i + 1] <- new_contents[i]
@@ -146,7 +187,13 @@
           midline_groups(which(as.numeric(midrule_matrix[i, ]) > 0),
                          table_info$booktabs),
           ""
-        )
+        ),
+         "custom" = ifelse(
+          sum(as.numeric(midrule_matrix[i, custom_latex_hline])) > 0,
+          midline_groups(which(as.numeric(midrule_matrix[i, ]) > 0),
+                         table_info$booktabs),
+          ""
+         )
       )
       new_contents[i] <- paste0(new_contents[i], "\\\\\\\\\n", row_midrule)
     }
@@ -157,6 +204,10 @@
   out <- structure(out, format = "latex", class = "knitr_kable")
   table_info$collapse_rows <- TRUE
   attr(out, "kable_meta") <- table_info
+  if(row_group_label_position == 'stack'){
+    group_row_index_list <- collapse_rows_index(kable_dt, head(columns, -1))
+    out <- collapse_rows_latex_stack(out, group_row_index_list, row_group_label_fonts)
+  }
   return(out)
 }
 
@@ -193,3 +244,52 @@
   out <- paste0(out, collapse = "\n")
   return(out)
 }
+
+
+collapse_rows_index <- function(kable_dt, columns)  {
+  format_to_row_index <- function(x){
+    x = rle(x)
+    out = x$lengths
+    names(out) = x$values
+    out
+  }
+  group_rows_index_list <- lapply(columns, function(x) {
+    format_to_row_index(kable_dt[, x])
+  })
+  return(group_rows_index_list)
+}
+
+
+collapse_rows_latex_stack <- function(kable_input, group_row_index_list,
+                                      row_group_label_fonts){
+  merge_lists <- function(default_list, updated_list){
+    for(x in names(updated_list)){
+      default_list[[x]] <- updated_list[[x]]
+    }
+    return(default_list)
+  }
+  default_font_list <- list(
+    list(bold = T, italic = F),
+    list(bold = F, italic = T),
+    list(bold = F, italic = F)
+  )
+  n_default_fonts = length(default_font_list)
+  n_supplied_fonts = length(row_group_label_fonts)
+  group_row_font_list <- list()
+  out <- kable_input
+  for(i in 1:length(group_row_index_list)){
+    if(i > n_default_fonts){
+      group_row_args <- default_font_list[[n_default_fonts]]
+    } else {
+      group_row_args <- default_font_list[[i]]
+    }
+    if(i <= n_supplied_fonts){
+      group_row_args <- merge_lists(group_row_args, row_group_label_fonts[[i]])
+    }
+    group_row_args <- merge_lists(
+      list(kable_input = out, index = group_row_index_list[[i]]),
+      group_row_args)
+    out <- do.call(group_rows, group_row_args)
+  }
+  return(out)
+}
diff --git a/vignettes/awesome_table_in_pdf.Rmd b/vignettes/awesome_table_in_pdf.Rmd
index fe9e7f6..1112e24 100644
--- a/vignettes/awesome_table_in_pdf.Rmd
+++ b/vignettes/awesome_table_in_pdf.Rmd
@@ -347,6 +347,41 @@
   collapse_rows(1:2)
 ```
 
+When there are too many layers, sometimes the table can become too wide. You can choose to stack the first few layers by setting `row_group_label_position` to `stack`. 
+
+
+```{r}
+collapse_rows_dt <- expand.grid(
+  Country = sprintf('Country with a long name %s', c('A', 'B')),
+  State = sprintf('State %s', c('a', 'b')),
+  City = sprintf('City %s', c('1', '2')),
+  District = sprintf('District %s', c('1', '2'))
+) %>% arrange(Country, State, City) %>%
+  mutate_all(as.character) %>%
+  mutate(C1 = rnorm(n()),
+         C2 = rnorm(n()))
+
+kable(collapse_rows_dt, format = "latex", 
+      booktabs = T, align = "c", linesep = '') %>%
+  collapse_rows(1:3, row_group_label_position = 'stack') 
+```
+
+To better distinguish different layers, you can format the each layer using `row_group_label_fonts`. You can also customize the hlines to better differentiate groups.
+
+```{r}
+row_group_label_fonts <- list(
+  list(bold = T, italic = T), 
+  list(bold = F, italic = F)
+  )
+kable(collapse_rows_dt, format = "latex", 
+                     booktabs = T, align = "c", linesep = '') %>%
+  column_spec(1, bold=T) %>%
+  collapse_rows(1:3, latex_hline = 'custom', custom_latex_hline = 1:3, 
+                row_group_label_position = 'stack', 
+                row_group_label_fonts = row_group_label_fonts) 
+```
+
+
 # Table Footnote
 
 > Now it's recommended to use the new `footnote` function instead of `add_footnote` to make table footnotes.