flextable fancy footer

flextable_fancy.R

library(openxlsx2) # github with #496 for all tables
library(flextable)

### wrapper function to add flextable objects to openxlsx2 worksheets
wb_add_flextable <- function(wb, sheet = current_sheet(), ft) {
  
  # get all rows to merge
  merge_rows <- function(ft_part, part_rows) {
    
    rows <- ft_part$spans$rows
    rows_to_merge <- vector("list", length = nrow(rows))
    
    # base - 1!
    base <- min(part_rows) - 1L
    
    for (row in seq_len(nrow(rows))) {
      rrs <- rows[row, ]
      # last - 1!
      last <- which(rrs > 1)[1] - 1L + base
      rrs <- rrs[rrs > 1 ]
      out <- vector("list", length = length(rrs))
      for (rr in seq_along(rrs)) {
        out[[rr]] <- seq_len(rrs[rr]) + last
        last <- last + rrs[rr]
      }
      rows_to_merge[[row]] <- out
    }
    
    rows_to_merge
  }
  
  # get all columns to merge
  merge_cols <- function(ft_part, part_cols) {
    
    cols <- ft_part$spans$columns
    cols_to_merge <- vector("list", length = ncol(cols))
    
    base <- min(part_cols) - 1L
    
    for (col in seq_len(ncol(cols))) {
      ccs <- cols[, col]
      last <- which(ccs > 1)[1] -1L + base
      ccs <- ccs[ccs > 1 ]
      out <- vector("list", length = length(ccs))
      for (cc in seq_along(ccs)) {
        out[[cc]] <- seq_len(ccs[cc]) + last
        last <- last + ccs[cc]
      }
      cols_to_merge[[col]] <- out
    }
    
    cols_to_merge
  }
  
  # create single column as large as the table
  wb_merge_ft_cap <- function(wb, caption_rows, ft_width) {
    wb$merge_cells(rows = caption_rows, cols = seq_len(ft_width))
  }
  
  # merge row wise
  wb_merge_ft_rows <- function(wb, merge_rows, header_rows) {
    for (rows in seq_along(merge_rows)) {
      if (length(rows)) {
        mm_rows <- merge_rows[[rows]]
        for (row in seq_along(mm_rows)) {
          m_cols <- mm_rows[[row]]
          m_rows <- header_rows[[rows]]
          wb$merge_cells(rows = m_rows, cols = m_cols)
        }
      }
    }
    
    invisible(wb)
  }
  
  # merge column wise
  wb_merge_ft_cols <- function(wb, merge_cols) {
    for (cols in seq_along(merge_cols)) {
      if (length(cols)) {
        mm_cols <- merge_cols[[cols]]
        for (col in seq_along(mm_cols)) {
          m_rows <- mm_cols[[col]]
          wb$merge_cells(rows = m_rows, cols = cols)
        }
      }
    }
    
    invisible(wb)
  }
  
  # some borders
  openxlsx2_border <- function(ddims, width, style) {
    border <- matrix("", nrow = nrow(ddims), ncol = ncol(ddims))
    
    for (i in seq_len(ncol(border))) {
      for (j in seq_len(nrow(border))) {
        if (width[j, i] > 0)
          if (width[j, i] < 1 && style[j, i] == "solid")
            border[j, i] <- "hair"
        if (width[j, i] == 1 && style[j, i] == "solid")
          border[j, i] <- "medium"
        if (width[j, i] > 1 && style[j, i] == "solid")
          border[j, i] <- "thick"
      }
    }
    
    border
  }
  
  # some styles
  wb_style_ft <- function(wb, ft_part, dims) {
    
    ddims <- dims_to_dataframe(dims, fill = TRUE)
    
    text_rotation <- ft_part$styles$cells$text.direction$data
    
    v_align <- ft_part$styles$cells$vertical.align$data
    h_align <- ft_part$styles$pars$text.align$data
    
    p_top    <- ft$body$styles$pars$padding.top
    p_bottom <- ft$body$styles$pars$padding.bottom
    
    # bg_color <- ft$body$styles$cells$background.color
    font_size       <- ft_part$styles$text$font.size$data
    font_family     <- ft_part$styles$text$font.family$data
    font_bold       <- ft_part$styles$text$bold$data
    font_italic     <- ft_part$styles$text$italic$data
    font_underlined <- ft_part$styles$text$underlined$data
    font_color      <- ft_part$styles$text$color$data
    
    bottom_width  <- ft_part$styles$cells$border.width.bottom$data
    bottom_style  <- ft_part$styles$cells$border.style.bottom$data
    bottom_color  <- ft_part$styles$cells$border.color.bottom$data
    bottom_border <- openxlsx2_border(ddims, bottom_width, bottom_style)
    
    top_width     <- ft_part$styles$cells$border.width.top$data
    top_style     <- ft_part$styles$cells$border.style.top$data
    top_color     <- ft_part$styles$cells$border.color.top$data
    top_border    <- openxlsx2_border(ddims, top_width, top_style)
    
    left_width    <- ft_part$styles$cells$border.width.left$data
    left_style    <- ft_part$styles$cells$border.style.left$data
    left_color    <- ft_part$styles$cells$border.color.left$data
    left_border   <- openxlsx2_border(ddims, left_width, left_style)
    
    right_width   <- ft_part$styles$cells$border.width.right$data
    right_style   <- ft_part$styles$cells$border.style.right$data
    right_color   <- ft_part$styles$cells$border.color.right$data
    right_border  <- openxlsx2_border(ddims, right_width, right_style)
    
    bg_color <- ft_part$styles$cells$background.color$data
    sh_color <- ft_part$styles$text$shading.color$data
    
    part_rows <- as.numeric(rownames(ddims))
    part_cols <- col2int(colnames(ddims))
    
    rowheight <- round(ft_part$rowheights * 91.4400, 0 )
    wb$set_row_heights(rows = part_rows, heights = rowheight)
    
    # loop over all cells
    for (i in seq_len(ncol(ddims))) {
      for (j in seq_len(nrow(ddims))) {
        
        f_f <- unname(font_family[j, i])
        f_c <- wb_colour(unname(font_color[j, i]))
        f_s <- as.character(unname(font_size[j, i]))
        
        wb$add_font(
          dims      = ddims[j, i],
          name      = f_f,
          color     = f_c,
          size      = f_s,
          bold      = ifelse(font_bold[j, i], "1", ""),
          italic    = ifelse(font_italic[j, i], "1", ""),
          underline = ifelse(font_underlined[j, i], "1", "")
        )
        
        t_brd <- top_border[j, i]
        t_color <- unname(top_color[j, i])
        t_clr <- if (t_color != "transparent") wb_colour(t_color) else NULL
        b_brd <- bottom_border[j, i]
        b_color <- unname(bottom_color[j, i])
        b_clr <- if (b_color != "transparent") wb_colour(b_color) else NULL
        l_brd <- left_border[j, i]
        l_color <- unname(left_color[j, i])
        l_clr <- if (l_color != "transparent") wb_colour(l_color) else NULL
        r_brd <- right_border[j, i]
        r_color <- unname(right_color[j, i])
        r_clr <- if (r_color != "transparent") wb_colour(r_color) else NULL
        
        wb$add_border(
          dims          = ddims[j, i],
          top_border    = t_brd,
          top_color     = t_clr,
          bottom_border = b_brd,
          bottom_color  = b_clr,
          left_border   = l_brd,
          left_color    = l_clr,
          right_border  = r_brd,
          right_color   = r_clr
        )
        
        t_r <- unname(text_rotation[j, i])
        if      (t_r == "tbrl") t_r <- "180"
        else if (t_r == "btlr") t_r <- "90"
        else    t_r <- ""
        
        wb$add_cell_style(
          dims       = ddims[j, i],
          horizontal = h_align[j, i],
          vertical   = v_align[j, i],
          textRotation = t_r,
          wrapText   = "1"
        )
        
        bg_c <- bg_color[j, i]
        sh_c <- sh_color[j, i]
        if (any(c(bg_c, sh_c) != "transparent")) {
          
          if (sh_c != "transparent")
            bg_c <- sh_c
          
          if (bg_c != "transparent") {
            wb$add_fill(
              dims  = ddims[j, i],
              color = wb_colour(unname(bg_c))
            )
          }
        }
        
      }
    }
    
    m_rows <- merge_rows(ft_part, part_cols)
    m_cols <- merge_cols(ft_part, part_rows)
    
    part_rows <- as.numeric(rownames(ddims))
    wb_merge_ft_rows(wb, m_rows, part_rows)
    wb_merge_ft_cols(wb, m_cols)
    
  }
  
  
  ### get flextable dimensions --------------------------------------------
  
  has_caption <- !is.null(ft$caption$value) && ft$caption$simple_caption
  has_footer  <- nrow(ft$footer$dataset) > 0
  has_header  <- nrow(ft$header$dataset) > 0
  
  vars <- ft$col_keys
  ft_width <- length(vars)
  
  caption_rows <- sum(has_caption)
  header_rows  <- seq_len(nrow(ft$header$dataset)) + max(caption_rows)
  dataset_rows <- seq_len(nrow(ft$body$dataset))   + max(header_rows)
  footer_rows  <- seq_len(nrow(ft$footer$dataset)) + max(dataset_rows)
  
  if (has_caption) dims_cap <- paste0(int2col(1), min(caption_rows), ":", int2col(ft_width), max(caption_rows))
  
  dims_hdr <- paste0(int2col(1), min(header_rows), ":", int2col(ft_width), max(header_rows))
  dims_dat <- paste0(int2col(1), min(dataset_rows), ":", int2col(ft_width), max(dataset_rows))
  
  if (has_footer) dims_ftr <- paste0(int2col(1), min(footer_rows), ":", int2col(ft_width), max(footer_rows))
  
  
  ### openxlsx2 part ------------------------------------------------------
  
  wb <- wb$clone(deep = TRUE)
  
  ## add data
  if (has_caption) {
    wb$add_data(sheet = sheet, dims = dims_cap, x = ft$caption$value)
    wb_merge_ft_cap(wb, caption_rows, ft_width)
    wb$add_font(sheet = sheet, dims = dims_cap, name = "Times")
  }
  
  # sections
  
  if (has_header) {
    df <- ft$header$content$content$data
    
    names <- colnames(df)
    
    mmat <- matrix("", nrow = nrow(df), ncol = ncol(df))
    
    for (j in seq_len(nrow(df))) {
      for (i in seq_along(names)) {
        
        col <- df[j, i][[1]]
        
        string <- NULL
        for (k in seq_len(nrow(col))) {
          
          txt <- col$txt[k]
          
          if (is.na(col$font.size[k])) font_size <- NULL
          else font_size <- col$font.size[k]
          
          if (is.na(col$italic[k])) italic <- FALSE
          else italic <- col$italic[k]
          
          if (is.na(col$bold[k])) bold <- FALSE
          else bold <- col$bold[k]
          
          if (is.na(col$underline[k])) underline <- FALSE
          else underline <- col$underline[k]
          
          if (is.na(col$color[k])) color <- NULL
          else color <- col$color[k]
          
          if (is.na(col$font.family[k])) font <- NULL
          else font <- col$font.family[k]
          
          if (is.na(col$vertical.align[k])) valign <- NULL
          else valign <- col$vertical.align[k]
          
          if (is.na(col$cs.family[k])) cs_family <- NULL
          else cs_family <- col$cs.family[k]
          
          if (is.na(col$shading.color[k])) outline <- NULL
          else outline <- col$shading.color[k]
          
          if (is.null(string))
            string <- fmt_txt(txt, size = font_size, italic = italic, bold = bold, underline = underline, color = color, font = font, vert_align = valign, charset = cs_family, outline = outline)
          else
            string <- string + fmt_txt(txt, size = font_size, italic = italic, bold = bold, underline = underline, color = color, font = font, vert_align = valign, charset = cs_family, outline = outline)
        }
        
        mmat[j, i] <- string
        
      }
    }
    
    header <- as.data.frame(mmat)
    wb$add_data(sheet = sheet, dims = dims_hdr, x = header, colNames = FALSE)  
  } else {
    wb$add_data(sheet = sheet, dims = dims_hdr, x = ft$header$dataset, colNames = FALSE)  
  }
  
  wb_style_ft(wb, ft$header, dims = dims_hdr)
  
  wb$add_data(sheet = sheet, dims = dims_dat, x = ft$body$dataset[vars], colNames = FALSE, na.strings = NULL)
  wb_style_ft(wb, ft$body, dims = dims_dat)
  
  if (has_footer) {
    df <- ft$footer$content$content$data
    
    footer <- data.frame(string = vector("character", nrow(df)))
    for (i in seq_len(nrow(df))) {
      
      col <- df[[i]]
      
      string <- NULL
      for (j in seq_len(nrow(col))) {
        
        if (is.na(col[j, ]$vertical.align))  valign <- NULL
        else valign <- col[j, ]$vertical.align
       
        if (is.null(string)) 
          string <- fmt_txt(col[j, ]$txt, vert_align = valign)
        else
          string <- string + fmt_txt(col[j, ]$txt, vert_align = valign)
      }
      
      footer$string[i] <- string
      
    }
    
    wb$add_data(sheet = sheet, dims = dims_ftr, x = footer, col_names = FALSE)
    
    wb_style_ft(wb, ft$footer, dims = dims_ftr)
  }
  
  # some column width
  colwidth <- round(ft$header$colwidths * 9.14400, 0)
  wb$set_col_widths(cols = seq_len(ft_width), widths = colwidth)
  
  invisible(wb)
}


ft <- flextable(airquality[ sample.int(10),])
ft <- add_header_row(ft,
                     colwidths = c(4, 2),
                     values = c("Air quality", "Time")
)
ft <- theme_vanilla(ft)
ft <- add_footer_lines(ft, "Daily air quality measurements in New York, May to September 1973.")
ft <- color(ft, part = "footer", color = "#666666")
ft <- set_caption(ft, caption = "New York Air Quality Measurements")
ft

library(palmerpenguins)
library(dplyr)
#> 
#> Attaching package: 'dplyr'
#> The following objects are masked from 'package:stats':
#> 
#>     filter, lag
#> The following objects are masked from 'package:base':
#> 
#>     intersect, setdiff, setequal, union

dat <- penguins |>
  select(species, island, ends_with("mm")) |>
  group_by(species, island) |>
  summarise(
    across(
      where(is.numeric),
      .fns = list(
        avg = ~ mean(.x, na.rm = TRUE),
        sd = ~ sd(.x, na.rm = TRUE)
      )
    ),
    .groups = "drop") |>
  rename_with(~ tolower(gsub("_mm_", "_", .x, fixed = TRUE)))

ft_pen <- flextable(dat) |>
  colformat_double() |>
  autofit()
ft_pen

ft_pen <- ft_pen |>
  separate_header() |>
  align(align = "center", part = "all") |>
  autofit()
ft_pen

myft <- as.data.frame(matrix(runif(5*5), ncol = 5)) %>% 
  flextable() %>% 
  colformat_double() %>% autofit() %>% 
  align(align = "center", part = "all") %>% 
  bg(bg = "black", part = "header") %>% 
  color(color = "white", part = "all") %>% 
  bg(bg = scales::col_numeric(palette = "viridis", domain = c(0, 1)))
myft


## create workbook with tables
wb <- wb_workbook()$
  add_worksheet("ft", zoom = 150, gridLines = FALSE)$
  add_worksheet("ft_pen", zoom = 150, gridLines = FALSE)$
  add_worksheet("myft", zoom = 150, gridLines = FALSE)

wb <- wb_add_flextable(wb, "ft", ft) %>% 
  wb_add_flextable("ft_pen", ft_pen) %>% 
  wb_add_flextable("myft", myft)

# wb$open()