Recreating a {flextable}

[JanMarvin]

In davidgohel/flextable#430 a flextable export to xlsx was requested.

Though I can not offer this, we still can try to recreate a flextable with openxlsx2. This is using the first example from https://ardata-fr.github.io/flextable-book/

library(openxlsx2)
library(flextable)

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

wb <- wb_workbook()$
  add_worksheet(grid = FALSE, zoom = 150)$
  ## add data
  add_data(dims = "A1", x = ft$caption$value)$
  add_data(dims = "A2", x = ft$header$dataset, colNames = FALSE)$
  add_data(dims = "A4", x = ft$body$dataset, colNames = FALSE, na.strings = NULL)$
  add_data(dims = "A14", x = ft$footer$dataset$Ozone)$
  ## fonts
  add_font(dims = "A1", name = "Times")$
  add_font(dims = "A2:F3", name = ft$header$styles$text$font.family$data[[1]], bold = "1")$
  add_font(dims = "A14", name = "Arial", color = wb_colour("darkgray"))$
  ## borders
  add_border(dims = "A2:F3", bottom_border = "", top_border = "medium", left_border = "", right_border = "", inner_hgrid = "hair")$
  add_border(dims = "A4:F13", bottom_border = "medium", top_border = "medium", left_border = "", right_border = "", inner_hgrid = "hair")$
  ## merge cells
  merge_cells(rows = 1, cols = 1:6)$
  merge_cells(rows = 2, cols = 1:4)$
  merge_cells(rows = 2, cols = 5:6)$
  merge_cells(rows = 14:15, cols = 1:6)$
  ## adjust cell alignment
  add_cell_style(dims = "A1", horizontal = "center")$
  add_cell_style(dims = "A2:F3", horizontal = "right")$
  add_cell_style(dims = "E2", horizontal = "right")$
  add_cell_style(dims = "A14", horizontal = "left", wrapText = "1")$
  ## numfmt
  add_numfmt(dims = "C4:C13", numfmt = "#.0")$
  ## increase row height
  set_row_heights(rows = 1:14, heights = 17)
  
  
# wb$open()

This is using the row_heights PR (the last line), other than that basic openxlsx2 functions.

Pinging @davidgohel and @sjewo

[sjewo]

Maybe the export functions in flextable (like this for latex tables ) could give some insights how to extract the relevant format options.

[JanMarvin]

Thanks, I'm not really a flextable user, just came across while looking at officer things. I might have a look, at least openxlsx2 could provide some export function flextable to XLSX. There are some things like conditional formatting or sparklines that could be supported with native open XML functions. Not sure about icons, have not experimented with that.
The basic stuff most likely looks similar to the code above? Maybe colored borders, fonts and format styles? That should be straightforward and we only have to pick the required color from flextable. It probably won't make it for the upcoming 0.4 release, but maybe for some rainy winter evenings ahead.

[JanMarvin]

I've tweaked this a bit further. A couple of things worth mentioning:

• with even medium sized tables the function below gets slow very fast, because of many loops over all cells of a table (multiple times). There might be ways to tweak this, but for a POC I was to lazy to tweak it further.
• some things are not implemented
  • subscripts
  • tabulation
  • merged cell regions that overlap
  • images in cells
  • ggplot plots in cells / data bars etc.
  • number formats like separators for big numbers
  • labeled column names
  • printing numbers with standard deviation
  • non simple captions

Basically there are some known drawbacks, but maybe one is lucky and has a flextable that isn't tweaked to the latest :)

@matt-dray you might be interested in this as well (found your {a11ytables} EARL slides yesterday)

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, 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

  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
  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) {
    wb$add_data(sheet = sheet, dims = dims_ftr, x = ft$footer$dataset[,1])
    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()