tests/testthat/test-images.R

In flextable: Functions for Tabular Reporting

data <- iris[c(1:3, 51:53, 101:104), ]
col_keys <- c(
  "Species",
  "sep_1",
  "Sepal.Length",
  "Sepal.Width",
  "sep_2",
  "Petal.Length",
  "Petal.Width"
)
img.file <- file.path(R.home("doc"), "html", "logo.jpg")

rlogo <- tempfile(fileext = ".jpg")
file.copy(img.file, rlogo)

test_that("images", {
  ft <- flextable(data, col_keys = col_keys)
  ft <- compose(
    ft,
    j = "Sepal.Length",
    value = as_paragraph(
      as_chunk("blah blah "),
      as_image(rlogo, width = .3, height = 0.23),
      " ",
      as_chunk(
        sprintf("val: %.1f", Sepal.Length),
        props = fp_text(color = "orange", vertical.align = "superscript")
      )
    )
  )
  ft <- compose(
    ft,
    j = "sep_1",
    value = as_paragraph(
      as_image(rlogo, width = .3, height = 0.23)
    )
  )
  ft <- compose(
    ft,
    j = "Petal.Length",
    value = as_paragraph(
      "blah blah ",
      as_chunk(
        Sepal.Length,
        props = fp_text(color = "orange", vertical.align = "superscript")
      )
    )
  )
  ft <- style(
    ft,
    pr_c = fp_cell(margin = 0, border = fp_border(width = 0)),
    pr_p = fp_par(padding = 0, border = fp_border(width = 0)),
    pr_t = fp_text(font.size = 10),
    part = "all"
  )
  ft <- autofit(ft, add_w = 0, add_h = 0)

  dims <- ft$body$colwidths
  expect_equal(as.vector(dims["sep_1"]), .3, tolerance = .00001)

  docx_file <- tempfile(fileext = ".docx")
  doc <- read_docx()
  doc <- body_add_flextable(doc, value = ft)
  expect_error(
    {
      print(doc, target = docx_file)
    },
    NA
  )
})

plot1 <- tempfile(fileext = ".png")
plot2 <- tempfile(fileext = ".png")
ragg::agg_png(filename = plot1, width = 300, height = 300, units = "px")
plot(1:15, 1:15)
dev.off()
ragg::agg_png(filename = plot2, width = 300, height = 300, units = "px")
plot(1:150, 1:150)
dev.off()

df <- data.frame(
  plot = c(plot1, plot2)
)

test_that("multiple images", {
  skip_if_not_installed("magick")

  ft <- flextable(df)
  ft <- mk_par(
    ft,
    j = "plot",
    value = as_paragraph(as_image(rlogo, width = .3, height = 0.23)),
    part = "header"
  )
  ft <- mk_par(
    ft,
    j = "plot",
    value = as_paragraph(as_image(plot, guess_size = TRUE))
  )
  chunk_info <- flextable::information_data_chunk(ft)
  expect_equal(chunk_info$img_data, c(rlogo, df$plot))
  expect_equal(chunk_info$width, c(.3, 300 / 72, 300 / 72))
  expect_equal(chunk_info$height, c(.23, 300 / 72, 300 / 72))

  docx_path <- save_as_docx(ft, path = tempfile(fileext = ".docx"))
  doc <- read_docx(docx_path)
  images_path <- doc$doc_obj$relationship()$get_images_path()
  expect_equal(
    gsub("([a-z0-9]+)(\\.png|\\.jpg)$", "\\2", basename(images_path)),
    c(".jpg", ".png", ".png")
  )

  html_path <- save_as_html(ft, path = tempfile(fileext = ".html"))
  doc <- read_html(html_path)
  all_imgs <- xml_find_all(doc, "//img")
  src_imgs <- xml_attr(all_imgs, "src")
  expect_length(src_imgs, 3)
  if (length(src_imgs) == 3) {
    expect_match(
      src_imgs[1],
      "data:image/jpeg",
      fixed = TRUE
    )
    expect_match(
      src_imgs[2],
      "data:image/png",
      fixed = TRUE
    )
    expect_match(
      src_imgs[3],
      "data:image/png",
      fixed = TRUE
    )
  }

  zz <- gen_grob(ft)
  expect_s3_class(
    zz$children$cell_1_1$children$contents$ftgrobs[[1]],
    "rastergrob"
  )
  expect_s3_class(
    zz$children$cell_2_1$children$contents$ftgrobs[[1]],
    "rastergrob"
  )
  expect_s3_class(
    zz$children$cell_3_1$children$contents$ftgrobs[[1]],
    "rastergrob"
  )

  ft <- flextable(df)
  ft <- colformat_image(ft, j = "plot", width = 300 / 72, height = 300 / 72)
  zz <- gen_grob(ft)
  expect_s3_class(zz$children$cell_1_1$children$contents$ftgrobs[[1]], "text")
  expect_s3_class(
    zz$children$cell_2_1$children$contents$ftgrobs[[1]],
    "rastergrob"
  )
  expect_s3_class(
    zz$children$cell_3_1$children$contents$ftgrobs[[1]],
    "rastergrob"
  )
})

test_that("minibar", {
  ft <- flextable(data.frame(n = 1:2))

  ft <- mk_par(
    ft,
    j = 1,
    value = as_paragraph(
      minibar(value = n, max = 10, width = .5, barcol = "red", bg = "yellow")
    ),
    part = "body"
  )
  minibar1 <- flextable::information_data_chunk(ft)$img_data[[2]]
  expect_s3_class(minibar1, "raster")
  expect_equal(nrow(minibar1), 1)
  expect_equal(ncol(minibar1), 36)
  expect_equal(minibar1[1:3], rep("#FF0000", 3))
  expect_equal(minibar1[4:36], rep("#FFFF00", 33))

  minibar2 <- flextable::information_data_chunk(ft)$img_data[[3]]
  expect_s3_class(minibar2, "raster")
  expect_equal(nrow(minibar2), 1)
  expect_equal(ncol(minibar2), 36)
  expect_equal(minibar2[1:7], rep("#FF0000", 7))
  expect_equal(minibar2[8:36], rep("#FFFF00", 29))
})

# linerange ----
test_that("linerange basic", {
  ft <- flextable(head(iris, 5))
  ft <- compose(
    ft,
    j = "Sepal.Length",
    value = as_paragraph(
      linerange(value = Sepal.Length)
    ),
    part = "body"
  )
  chunk_info <- information_data_chunk(ft)
  body_chunks <- chunk_info[chunk_info$.part == "body", ]
  sl_chunks <- body_chunks[body_chunks$.col_id == "Sepal.Length", ]
  expect_equal(nrow(sl_chunks), 5)
  expect_true(all(sl_chunks$width == 1))
  expect_true(all(sl_chunks$height == 0.2))
  expect_true(
    all(vapply(sl_chunks$img_data, inherits, logical(1), "raster"))
  )
})

test_that("linerange with min max and colors", {
  vals <- c(2, 5, 8)
  ft <- flextable(data.frame(x = vals))
  ft <- compose(
    ft,
    j = "x",
    value = as_paragraph(
      linerange(
        value = x,
        min = 0,
        max = 10,
        rangecol = "blue",
        stickcol = "green",
        bg = "white",
        width = 2,
        height = .3
      )
    ),
    part = "body"
  )
  chunk_info <- information_data_chunk(ft)
  body_chunks <- chunk_info[
    chunk_info$.part == "body" &
      chunk_info$.col_id == "x",
  ]
  expect_equal(nrow(body_chunks), 3)
  expect_true(all(body_chunks$width == 2))
  expect_true(all(body_chunks$height == 0.3))
})

test_that("linerange all NA values", {
  ft <- flextable(data.frame(x = c(NA_real_, NA_real_)))
  ft <- compose(
    ft,
    j = "x",
    value = as_paragraph(
      linerange(value = x)
    ),
    part = "body"
  )
  chunk_info <- information_data_chunk(ft)
  body_chunks <- chunk_info[
    chunk_info$.part == "body" &
      chunk_info$.col_id == "x",
  ]
  expect_equal(nrow(body_chunks), 2)
})

test_that("linerange raster_width < 2 errors", {
  expect_error(
    linerange(value = 1:3, raster_width = 1),
    "raster_width"
  )
})

test_that("linerange unit cm", {
  vals <- c(3, 6)
  ft <- flextable(data.frame(x = vals))
  ft <- compose(
    ft,
    j = "x",
    value = as_paragraph(
      linerange(value = x, width = 2, height = 0.5, unit = "cm")
    ),
    part = "body"
  )
  chunk_info <- information_data_chunk(ft)
  body_chunks <- chunk_info[
    chunk_info$.part == "body" &
      chunk_info$.col_id == "x",
  ]
  # cm -> in conversion: 2cm / 2.54 ~ 0.787
  expect_true(all(abs(body_chunks$width - 2 / 2.54) < 0.01))
})

# plot_chunk ----
test_that("plot_chunk box type", {
  library(data.table)
  z <- as.data.table(iris)
  z <- z[, list(z = list(.SD$Sepal.Length)), by = "Species"]
  ft <- flextable(z, col_keys = c("Species", "box"))
  ft <- mk_par(
    ft,
    j = "box",
    value = as_paragraph(
      plot_chunk(value = z, type = "box")
    )
  )
  chunk_info <- information_data_chunk(ft)
  box_chunks <- chunk_info[
    chunk_info$.part == "body" &
      chunk_info$.col_id == "box",
  ]
  expect_equal(nrow(box_chunks), 3)
  expect_true(all(file.exists(unlist(box_chunks$img_data))))
})

test_that("plot_chunk line type", {
  library(data.table)
  z <- as.data.table(iris)
  z <- z[, list(z = list(.SD$Sepal.Length)), by = "Species"]
  ft <- flextable(z, col_keys = c("Species", "pl"))
  ft <- mk_par(
    ft,
    j = "pl",
    value = as_paragraph(
      plot_chunk(value = z, type = "line")
    )
  )
  chunk_info <- information_data_chunk(ft)
  pl_chunks <- chunk_info[
    chunk_info$.part == "body" &
      chunk_info$.col_id == "pl",
  ]
  expect_equal(nrow(pl_chunks), 3)
  expect_true(all(file.exists(unlist(pl_chunks$img_data))))
})

test_that("plot_chunk points type", {
  library(data.table)
  z <- as.data.table(iris)
  z <- z[, list(z = list(.SD$Sepal.Length)), by = "Species"]
  ft <- flextable(z, col_keys = c("Species", "pl"))
  ft <- mk_par(
    ft,
    j = "pl",
    value = as_paragraph(
      plot_chunk(value = z, type = "points")
    )
  )
  chunk_info <- information_data_chunk(ft)
  pl_chunks <- chunk_info[
    chunk_info$.part == "body" &
      chunk_info$.col_id == "pl",
  ]
  expect_equal(nrow(pl_chunks), 3)
  expect_true(all(file.exists(unlist(pl_chunks$img_data))))
})

test_that("plot_chunk density type", {
  library(data.table)
  z <- as.data.table(iris)
  z <- z[, list(z = list(.SD$Sepal.Length)), by = "Species"]
  ft <- flextable(z, col_keys = c("Species", "pl"))
  ft <- mk_par(
    ft,
    j = "pl",
    value = as_paragraph(
      plot_chunk(value = z, type = "density")
    )
  )
  chunk_info <- information_data_chunk(ft)
  pl_chunks <- chunk_info[
    chunk_info$.part == "body" &
      chunk_info$.col_id == "pl",
  ]
  expect_equal(nrow(pl_chunks), 3)
  expect_true(all(file.exists(unlist(pl_chunks$img_data))))
})

test_that("plot_chunk free_scale", {
  library(data.table)
  z <- as.data.table(iris)
  z <- z[, list(z = list(.SD$Sepal.Length)), by = "Species"]
  ft <- flextable(z, col_keys = c("Species", "pl"))
  ft <- mk_par(
    ft,
    j = "pl",
    value = as_paragraph(
      plot_chunk(
        value = z,
        type = "box",
        free_scale = TRUE
      )
    )
  )
  chunk_info <- information_data_chunk(ft)
  pl_chunks <- chunk_info[
    chunk_info$.part == "body" &
      chunk_info$.col_id == "pl",
  ]
  expect_equal(nrow(pl_chunks), 3)
})

# gg_chunk ----
test_that("gg_chunk", {
  skip_if_not_installed("ggplot2")
  library(ggplot2)
  library(data.table)

  z <- as.data.table(iris)
  z <- z[,
    list(
      gg = list(
        ggplot(.SD, aes(Sepal.Length, Sepal.Width)) +
          geom_point() +
          theme_void()
      )
    ),
    by = "Species"
  ]

  ft <- flextable(z)
  ft <- mk_par(
    ft,
    j = "gg",
    value = as_paragraph(
      gg_chunk(value = gg, width = 1, height = 1)
    )
  )
  chunk_info <- information_data_chunk(ft)
  gg_chunks <- chunk_info[
    chunk_info$.part == "body" &
      chunk_info$.col_id == "gg",
  ]
  expect_equal(nrow(gg_chunks), 3)
  expect_true(all(file.exists(unlist(gg_chunks$img_data))))
  expect_true(all(gg_chunks$width == 1))
  expect_true(all(gg_chunks$height == 1))
})

test_that("gg_chunk unit cm", {
  skip_if_not_installed("ggplot2")
  library(ggplot2)

  plots <- list(
    ggplot(iris, aes(Sepal.Length)) +
      geom_histogram() +
      theme_void()
  )
  ft <- flextable(data.frame(g = "a"))
  ft <- mk_par(
    ft,
    j = "g",
    value = as_paragraph(
      gg_chunk(
        value = plots,
        width = 3,
        height = 2,
        unit = "cm"
      )
    )
  )
  chunk_info <- information_data_chunk(ft)
  gg_chunks <- chunk_info[
    chunk_info$.part == "body" &
      chunk_info$.col_id == "g",
  ]
  expect_true(abs(gg_chunks$width - 3 / 2.54) < 0.01)
  expect_true(abs(gg_chunks$height - 2 / 2.54) < 0.01)
})

# grid_chunk ----
test_that("grid_chunk", {
  library(grid)

  grobs <- list(
    circleGrob(gp = gpar(fill = "red", col = "transparent")),
    rectGrob(gp = gpar(fill = "blue", col = "transparent"))
  )
  ft <- flextable(data.frame(a = c("circle", "rect")))
  ft <- mk_par(
    ft,
    j = "a",
    value = as_paragraph(
      grid_chunk(
        value = grobs,
        width = .5,
        height = .5
      )
    )
  )
  chunk_info <- information_data_chunk(ft)
  grid_chunks <- chunk_info[
    chunk_info$.part == "body" &
      chunk_info$.col_id == "a",
  ]
  expect_equal(nrow(grid_chunks), 2)
  expect_true(all(file.exists(unlist(grid_chunks$img_data))))
  expect_true(all(grid_chunks$width == 0.5))
  expect_true(all(grid_chunks$height == 0.5))
})

test_that("grid_chunk in docx output", {
  library(grid)

  grobs <- list(
    circleGrob(gp = gpar(fill = "green", col = "transparent"))
  )
  ft <- flextable(data.frame(a = "dot"))
  ft <- mk_par(
    ft,
    j = "a",
    value = as_paragraph(
      grid_chunk(value = grobs, width = .3, height = .3)
    )
  )
  docx_file <- tempfile(fileext = ".docx")
  doc <- read_docx()
  doc <- body_add_flextable(doc, value = ft)
  expect_no_error(print(doc, target = docx_file))
  expect_true(file.exists(docx_file))
})

test_that("as_image alt text in DOCX", {
  ft <- flextable(head(iris, 2))
  ft <- compose(
    ft,
    i = 1,
    j = 1,
    value = as_paragraph(
      as_image(src = rlogo, width = 0.3, height = 0.23, alt = "R logo")
    ),
    part = "body"
  )
  doc <- read_docx()
  doc <- body_add_flextable(doc, ft)
  out <- print(doc, target = tempfile(fileext = ".docx"))
  unpack_dir <- tempfile()
  officer::unpack_folder(out, unpack_dir)
  doc_xml <- paste(
    readLines(
      file.path(unpack_dir, "word", "document.xml")
    ),
    collapse = ""
  )
  expect_true(grepl('descr="R logo"', doc_xml))
})

test_that("as_image alt text in HTML", {
  ft <- flextable(head(iris, 2))
  ft <- compose(
    ft,
    i = 1,
    j = 1,
    value = as_paragraph(
      as_image(src = rlogo, width = 0.3, height = 0.23, alt = "R logo")
    ),
    part = "body"
  )
  html <- as.character(htmltools::tagList(htmltools_value(ft)))
  expect_true(grepl('alt="R logo"', html))
})

test_that("as_image without alt has empty alt", {
  ft <- flextable(head(iris, 2))
  ft <- compose(
    ft,
    i = 1,
    j = 1,
    value = as_paragraph(
      as_image(src = rlogo, width = 0.3, height = 0.23)
    ),
    part = "body"
  )
  html <- as.character(htmltools::tagList(htmltools_value(ft)))
  expect_true(grepl('alt=""', html))
})

test_that("paragraph borders restored via style()", {
  border <- fp_border_default(width = 0.75, color = "black")
  ft <- qflextable(head(iris, 3)) |> border_remove()
  ft <- add_header_row(
    ft,
    values = c("Sepal", "Petal", "Species"),
    colwidths = c(2, 2, 1)
  )
  ft <- style(
    x = ft,
    part = "header",
    i = 1,
    j = c(1, 3),
    pr_p = officer::fp_par(
      border.bottom = border,
      text.align = "center"
    )
  )
  doc <- read_docx()
  doc <- body_add_flextable(doc, ft)
  out <- print(doc, target = tempfile(fileext = ".docx"))
  unpack_dir <- tempfile()
  officer::unpack_folder(out, unpack_dir)
  doc_xml <- paste(
    readLines(
      file.path(unpack_dir, "word", "document.xml")
    ),
    collapse = ""
  )
  expect_true(grepl("w:pBdr", doc_xml))
})