R/lorem_text.R

In textshaping: Bindings to the 'HarfBuzz' and 'Fribidi' Libraries for Text Shaping

#' Get gibberish text in various scripts
#'
#' Textshaping exists partly to allow all the various scripts that exists in the
#' world to be used in R graphics. This function returns gibberish filler text
#' (lorem ipsum text) in various scripts for testing purpose. Some of these are
#' transliterations of the original lorem ipsum text while others are based an
#' a distribution model.
#'
#' @param script A string giving the script to fetch gibberish for
#' @param n The number of paragraphs to fetch. Each paragraph will be its own
#' element in the returned character vector.
#'
#' @return a charactor vector of length `n`
#'
#' @export
#'
#' @references https://generator.lorem-ipsum.info
#'
#' @examples
#' # Defaults to standard lorem ipsum
#' lorem_text()
#'
#' # Get two paragraphs of hangul (Korean)
#' lorem_text("hangul", 2)
#'
#' # Get gibberish bi-directional text
#' lorem_bidi()
#'
lorem_text <- function(
  script = c(
    "latin",
    "chinese",
    "arabic",
    "devanagari",
    "cyrillic",
    "kana",
    "hangul",
    "greek",
    "hebrew",
    "armenian",
    "georgian"
  ),
  n = 1
) {
  script <- match.arg(script)
  file <- paste0(script, ".txt")
  file <- system.file("lorem", file, package = "textshaping")
  rep_len(readLines(file), n)
}

#' @rdname lorem_text
#'
#' @param ltr,rtl scripts to use for left-to-right and right-to-left text
#' @param ltr_prop The approximate proportion of left-to-right text in the final
#' string
#' @export
#'
lorem_bidi <- function(
  ltr = c(
    "latin",
    "chinese",
    "devanagari",
    "cyrillic",
    "kana",
    "hangul",
    "greek",
    "armenian",
    "georgian"
  ),
  rtl = c("arabic", "hebrew"),
  ltr_prop = 0.9,
  n = 1
) {
  ltr <- match.arg(ltr)
  rtl = match.arg(rtl)
  ltr_split <- if (ltr %in% c("chinese", "kana", "hangul")) "" else " "
  ltr <- lorem_text(ltr, n)
  rtl <- lorem_text(rtl, n)
  mapply(
    function(ltr, rtl) {
      if (ltr_prop >= 0.5) {
        prop <- ltr_prop
        main <- ltr
        sub <- rtl
        sub_merge <- " "
        main_merge <- ltr_split
      } else {
        prop <- 1 - ltr_prop
        main <- rtl
        sub <- ltr
        sub_merge <- ltr_split
        main_merge <- " "
      }
      n_insert <- min(ceiling(length(main) * (1 - prop)), length(sub))
      n_chunks <- ceiling(stats::runif(1, n_insert * (prop - 0.5), n_insert))
      sub <- lapply(
        split(
          sub[seq_len(n_insert)],
          sort(c(
            seq_len(n_chunks),
            sample(n_chunks, n_insert - n_chunks, TRUE)
          ))
        ),
        paste,
        collapse = sub_merge
      )
      insertions <- sort(sample(length(main), n_chunks))
      for (i in rev(seq_along(insertions))) {
        main <- append(main, sub[[i]], insertions[i])
      }
      paste(main, collapse = main_merge)
    },
    ltr = strsplit(ltr, ltr_split),
    rtl = strsplit(rtl, " ")
  )
}