R/wrap-notes.R

In kbrevoort/kpbtemplates: Kenneth P. Brevoort's Templates

#' Wrap Notes
#'
#' Takes a character string that is to appear as notes below a graph and places
#' line breaks at appropriate places to wrap the line to conform to the appropriate
#' width given the supplied font size.
#' @param text Character scalar with the text to be included.
#' @param width Numeric scalar giving the alloted width for the viewport
#' @param unit Character scalar giving the units in which the width is expressed
#' (i.e., 'in', 'mm').
wrap_notes <- function(text,
                       width = 3,
                       unit = 'in',
                       gp = set_gp()) {

  purrr::map(stringr::str_split(text, '\n'),
                           wrap_single_paragraph,
                           width = width,
                           unit = unit,
                           gp = gp) %>%
    unlist() %>%
    paste0(collapse = '\n')
}

set_gp <- function(col = 'black',
                   size = 12L,
                   family = 'serif',
                   face = 'plain',
                   lineheight = 1) {
  gp <- grid::gpar(col = col,
                   fontsize = size,
                   fontfamily = family,
                   fontface = face,
                   lineheight = lineheight)
}

wrap_single_paragraph <- function(text, width, unit, gp) {
  # This will store the portions of each paragraph
  note_lines <- NULL

  old_length <- Inf
  while(nchar(text) > 0 & nchar(text) < old_length) {
    old_length <- nchar(text)

    best_break <- identify_best_break(text, width, unit, gp)

    # ADd identified segment as its own line
    note_lines <- substr(text, 1L, best_break) %>%
      stringr::str_trim() %>%
      c(note_lines, .)

    # Remove the identified segment from text
    text <- substring(text, best_break + 1L) %>%
      stringr::str_trim()
  }

  note_lines
}

#' Identify Best Break
#'
#' Finds the position in the character scalar that contains the most characters
#' without exceeding the specified width.
#' @param txt Character scalar of note text
#' @param width Numeric scalar giving width of available space
#' @param unit Character scalar giving the units of measurement to be used.
#' @param gp Graphical parameters to be used in printing the text. Generated by
#' grid::gpar.
#' @importFrom stringr str_locate_all str_trim
identify_best_break <- function(txt, width, unit, gp) {

  candidate_breaks <- c(stringr::str_locate_all(txt, '\\s+')[[1L]][, 2],
                       nchar(txt)) %>%
    unique()

  n <- length(candidate_breaks)
  if (n == 0)
    return(nchar(txt))

  for (i in 1:n) {

    short_line <- substr(txt, 1L, candidate_breaks[i]) %>%
      stringr::str_trim()

    grob_width <- create_noteGrob(short_line, gp = gp, as_textGrob = TRUE) %>%
      calc_grob_width(unit)

    if (grob_width > width) {
      if (i == 1) # The first split is too long.
        return(candidate_breaks[1])
      return(candidate_breaks[i - 1L])
    }
  }

  candidate_breaks[n]
}

#' Caculate Width of Graphical Object
#'
#' Returns the width of a graphical object (grob) in the specifie units.
#' @param gr A graphical object
#' @param unit Character scalar providing the unit to use in calculating the width
#' (i.e., 'in', 'mm')
#' @importFrom grid grobWidth convertWidth
calc_grob_width <- function(gr, unit) {
  grid::grobWidth(gr) %>%
    grid::convertWidth(unit, valueOnly = TRUE)
}

#' @importFrom grid grobHeight convertHeight
calc_grob_height <- function(gr, unit) {
  grid::grobHeight(gr) %>%
    grid::convertHeight(unit, valueOnly = TRUE)
}

#' Create a Note Graphical Object
#'
#' Creates the noteGrob object
#' @param note_text Character scalar of text to put in the note
#' @param gp Graphic parameter list covering how the text is to be formatted.
#' Created by call to grid::gpar.
#' @importFrom grid textGrob grob
create_noteGrob <- function(note_text, gp, as_textGrob = FALSE) {
  ret_grob <- grid::textGrob(note_text,
                             x = 0,
                             hjust = 0,
                             vjust = 0.5,
                             gp = gp,
                             vp = grid::viewport(width = unit(0.8, 'npc'),
                                                 height = unit(0.8, 'npc')))

  if (as_textGrob)
    return(ret_grob)

  #grid::grob(tg = ret_grob, cl = 'noteGrob')
  class(ret_grob) <- 'noteGrob'
  ret_grob
}

preDrawDetails.noteGrob <- function(x) {
   #browser()
#   h <- convertHeight(unit(1, "snpc"), "mm", valueOnly=TRUE)
#   fs <- rescale(h, to=c(18, 7), from=c(120, 20))
#   pushViewport(viewport(gp = gpar(fontsize = fs)))
}

grid.draw.noteTable <- function(x, ...) {
  #browser()
  cat('being run\n')
  class(x) <- class(x)[-1]  # Remove first element
  grid::grid.draw(x, ...)
#  notegrob2textgrob(x)
#  grid:::grid.draw.grob(x, ...)
}

notegrob2textgrob <- function(x) {
  class(x) <- c('text', 'grob', 'gDesc')

  x
}

add_notes <- function(obj, txt, gp) {
  grid::grid.newpage()
  w <- grid::convertWidth(unit(1, 'npc'), 'in', valueOnly = TRUE) * 0.9

  z <- wrap_notes(txt, width = w, unit = 'in', gp = set_gp(size = 8L))
  my_grob <- create_noteGrob(paste0('\n', z, '\n'),
                             gp = set_gp(size = 8L),
                             as_textGrob = TRUE)
  mygrob_hgt <- calc_grob_height(notegrob2textgrob(my_grob), 'in')

  g <- gridExtra::arrangeGrob(obj, notegrob2textgrob(my_grob),
                              nrow = 2,
                              ncol = 1L,
                              widths = unit(w / 0.9, 'in'),
                              #heights = unit(c(1, 1), c('null', 'null')),
                              heights = unit(c(1, mygrob_hgt), c('null', 'in')),
                              padding = unit(2, 'in'))

}

wrap_caption <- function(ggobj, width = 6.5, unit = 'in') {
  if (!is.ggplot(ggobj))
    stop('wrap_caption only works with ggplot objects.')

  params <- ggobj$theme$plot.caption
  cap_size <- set_text_size(params, ggobj)

  new_cap <- wrap_notes(text = ggobj$labels$cap,
                        width = width,
                        unit = unit,
                        gp = set_gp(col = params$colour,
                                    size = cap_size,
                                    family = params$family,
                                    face = params$face,
                                    lineheight = params$lineheight))
  ggobj$labels$caption <- new_cap

  ggobj
}

wrap_title <- function(ggobj, width = 6.5, unit = 'in') {
  if (!is.ggplot(ggobj))
    stop('wrap_title only works with ggplot objects.')

  params <- ggobj$theme$plot.title
  title_size <- set_text_size(params, ggobj)

  new_title <- wrap_notes(text = ggobj$labels$title,
                          width = width,
                          unit = unit,
                          gp = set_gp(col = params$colour,
                                      size = title_size,
                                      family = params$family,
                                      face = params$face,
                                      lineheight = params$lineheight))
  ggobj$labels$title <- new_title

  ggobj
}

set_text_size <- function(params, obj) {
  if (class(params$size) == 'rel') {
    ret <- obj$theme$text$size * as.numeric(params$size)
  } else {
    ret <- params$size
  }

  ret
}