Crop images based on number of text length

Question

I have a dataset with a column storing hundreds of writing samples. My goal is to export each writing sample into a separate image. Below, my current code:

library(tidyverse)
library(ggplot2)
library(ggtext)
library(magick)

df <- data.frame(
      ID = 1:2,
      Sample = c("Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. \r\r\nUt enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat.", "Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, sunt in culpa qui officia deserunt mollit anim id est laborum.")
    )

First, I calculate the number of characters for each writing sample (spaces between words included) to establish the text size in ggtext::geom_textbox. This will enable users to set the same text size across all the writing samples:

max_text <- df |> 
  rowwise() |> 
  mutate(n = nchar(Sample)) |> 
  ungroup() |> 
  top_n(1, n)

p_longest_text <- ggplot(max_text, aes(label = Sample)) +
  ggtext::geom_textbox(x = 0, y = 1, width = 0.9, hjust = 0, vjust = 1, size = 3, box.colour = "white") +
  theme_void()

ggsave("longest_text.png", p_longest_text, width = 1000, height = 1200, units = "px", bg = "white")

After establishing an adequate text size, I can use the value (in the current toy data set is size = 3) in the for-loop to generate one image for each writing sample. The text size will be the same across all the images:

for(i in 1:nrow(df)) {
    tec <- paste0(df[i,]$ID, ".png")
    p <- ggplot(df[i,], aes(label = Sample)) +
      ggtext::geom_textbox(x = 0, y = 1, width = 0.9, hjust = 0, vjust = 1, size = 3, box.colour = "white") +
      theme_void()
    ggsave(tec, p, width = 1000, height = 1200, units = "px", bg = "white")
}

Unfortunately, two issues remain:

1. I am unable to crop out the empty space. Unfortunately, image_trim() does not work well because it leaves no margin between the text and the cropped section. image_crop seems more promising but I don't know how to adjust it to each image differently.
2. Right now, the code requires the user to manually try different text sizes to determine the value to use in the for-loop. It would be great to automatize this process so that the chunk of code can be run without a user's decision.

Any help will be appreciated!

Answer 1

I suspect your initial attempt with image_trim() is the way to go.

To add margin around the trimmed image you can use image_border().

image_border(image, "white", "20x20")

That creates a border of 20px high and wide around the image.

https://cran.r-project.org/web/packages/magick/vignettes/intro.html

---

Text Size

As for the text size, If performance isn't a huge problem, you brute-force the calculation:

Start with a good guess. Say 5.

Run the calculations, but make the height of the images much larger than your end-desired goal.

Run the trim. If the trimmed image is larger than your desired height of 1000px, the text size is too large. Reduce it and try again.

If the trimmed image is smaller than your desired height, try increasing it. If if that becomes too big, you know the original guess is the right one.

This brute force technique only works if your performance is not important since it involves applying all the image transformations to each iteration.

On the other hand, using a monospaced font would allow you to calculate the exact number of lines needed for a particular block of text, which should allow you to calculate the required height of a given value of text size. Without a monospace font, I fear that calculating the text size without actually rendering the text would be very difficult due to the font's automatic resizing and compression due to the different combinations of letters.

For example, in this font, the L and l take up vastly different space. Also in some fonts depending on the letter before or after a given letter the spacing can be adjusted to make it look more natural.

Answer 2

Instead of {ggplot2} I relied on writing an html file and using javascript to check for overflow.

Packages Used

library(chromote)
library(htmltools)
library(magick)
library(purrr)
library(stringi)
library(tidyverse)

Some Functions

write_text_html <- function(
  text, 
  file,
  font_size = 12, 
  font_family = "Courier New",
  dimensions = c(992, 744),
  width = dimensions[1], 
  height = dimensions[2], 
  border = c(0, 0),
  border_width = border[1],
  border_height = border[2]
) {
  css <- sprintf(
    paste(
      c(
        "",
        ".content {",
        "  display: flex;",
        "  justify-content: center;",
        "  align-items: center;",
        "  width: %spx;",
        "  height: %spx;",
        "  font-family: '%s';",
        "  font-size: %spx;",
        "  padding-left: %spx;",
        "  padding-bottom: %spx;",
        "  padding-right: %spx;",
        "  padding-top: %spx;",
        "  overflow: hidden;",
        "}",
        ""
      ),
      collapse = "\n"
    ), 
    width - 2 * border_width, 
    height - 2 * border_height, 
    font_family, 
    font_size,
    border_width,
    border_height,
    border_width,
    border_height
  )
  
  htmltools::tagList(
    htmltools::tags$style(css),
    htmltools::tags$body(
      htmltools::tags$div(id = "content", class = "content", text)
    )
  ) %>% 
    htmltools::html_print()
}

path_to_uri <- function(path) {
  path %>% 
    # get forward slash on windows
    normalizePath(winslash = "/") %>% 
    # replace drive:/ with drive:// so C:/ becomes C://
    gsub(x = ., pattern = ":/", replacement = "://") %>%
    # appends file:/// to make valid uri
    paste0("file:///", .)
}

html_has_overflow <- function(html) {
  b <- chromote::ChromoteSession$new() # new session or tab
  
  html %>% 
    path_to_uri() %>% 
    b$Page$navigate()
  
  Sys.sleep(3)
  
  x <- b$Runtime$evaluate(paste0(
    "var obj = document.getElementById('content');",
    "obj.scrollHeight > obj.offsetHeight"
  ))
  
  Sys.sleep(3)
  
  b$close() # close tab
  
  return(x$result$value)
}

write_html_png <- function(
  html, 
  png, 
  dimensions = c(992, 744),
  width = dimensions[1], 
  height = dimensions[2]
) {
  b <- chromote::ChromoteSession$new() # new session or tab
  
  html %>% 
    path_to_uri() %>% 
    b$Page$navigate()
  
  Sys.sleep(3)
  
  b$screenshot(png, selector = ".content")
  
  Sys.sleep(3)
  
  b$close() # close tab
  
  magick::image_blank(width, height, color = "white") %>% 
    magick::image_composite(
      magick::image_read(png), 
      gravity = "center"
    ) %>% 
    magick::image_write(png)
}

max_font_size_no_overflow <- function(
  text,
  font_size_range,
  font_size_min = min(font_size_range),
  font_size_max = max(font_size_range),
  font_family = "Courier New",
  border = c(0, 0),
  border_width = border[1],
  border_height = border[2],
  target_dimensions = c(992, 744),
  target_width = target_dimensions[1],
  target_height = target_dimensions[2]
) {
  mfsno <- purrr::map_dfr(
    font_size_min:font_size_max, 
    ~ {
      has_overflow <- write_text_html(
        text = text,
        file = tempfile(fileext = ".html"),
        font_size = ., 
        font_family = font_family,
        dimensions = c(target_width, target_height),
        border = c(border_width, border_height)
      ) %>% 
        html_has_overflow()
      
      dplyr::tibble(font_size = ., has_overflow)
    }
  ) %>% 
    dplyr::filter(!has_overflow) %>% 
    dplyr::arrange(dplyr::desc(font_size)) %>% 
    dplyr::slice(1) %>% 
    dplyr::pull(font_size)
  
  if(length(mfsno) != 1)
    stop("Maximum font size unidentified.")
  else
    mfsno
}

Example Usage

# so example lipsum is always the same
set.seed(42)

# make example samples
tbl <- dplyr::tibble(
  sample = stringi::stri_rand_lipsum(5),
  id = 1:length(sample)
)

# desired image settings
font_size_range <- c(10, 20)
border <- c(100, 100)
dimensions <- c(500, 500)

# identify sample with most characters
longest_sample <- tbl %>% 
  dplyr::mutate(nchar = nchar(sample)) %>% 
  dplyr::arrange(dplyr::desc(nchar)) %>% 
  dplyr::slice(1) %>% 
  dplyr::select(id, sample)

# identify the maximum font size without 
# overflow for the largest sample
common_font_size <- max_font_size_no_overflow(
  text = longest_sample$sample, 
  font_size_range = font_size_range, 
  font_family = "Courier New", 
  border = border,
  target_dimensions = dimensions
)

# write html files for each sample at the 
# common font size and compose a png file
purrr::pwalk(tbl, function(sample, id) {
  write_text_html(
    text = sample,
    file = tempfile(fileext = ".html"),
    font_size = common_font_size, 
    font_family = "Courier New",
    dimensions = dimensions,
    border = border
  ) %>% 
    write_html_png(
      png = paste0(id, ".png"), 
      dimensions = dimensions
    )
})

Output

1.png

2.png

3.png

4.png

5.png

^{Created on 2022-11-01 with reprex v2.0.2}