logos/logo_functions.R

In goldingn/greta: Simple and Scalable Statistical Modelling in R

# functions for creating logos etc.

# get the coordinates and links to tile the logo 'repeats' times.
# x_start and y_start give the position of the first node
logo_shape <- function (x_start = 0, y_range = c(0, 1)) {

  # coordinates and links of the base shape
  coords <- data.frame(x = c(0, 0, 1, 1, 2, 2, 3),
                       y = c(0, 1, 0.5, 1.5, 0, 1, 0.5))

  links <- rbind(c(1, 3),
                 c(2, 3),
                 c(3, 6),
                 c(4, 6),
                 c(5, 7),
                 c(6, 7))

  scale <- abs(diff(y_range)) / 1.6
  coords$x <- coords$x * scale + x_start
  coords$y <- coords$y * scale + y_range[1]

  list(coords = coords, links =links)

}

plot_logo <- function (background = c('white', 'purple', 'light', 'lighter'),
                       pointsize = 4.5,
                       add = FALSE,
                       edge_width = 1,
                       ...) {

  background <- match.arg(background)

  data <- logo_shape(...)

  bg_col <- switch (background,
                    white = 'white',
                    light = greta:::greta_col('light'),
                    lighter = greta:::greta_col('lighter'),
                    purple = greta:::greta_col('main'))

  link_col <- switch (background,
                      white = greta:::greta_col('light'),
                      light = greta:::greta_col('dark'),
                      lighter = greta:::greta_col('dark'),
                      purple = greta:::greta_col('dark'))

  node_col <- switch (background,
                      white = greta:::greta_col('dark'),
                      light = greta:::greta_col('dark'),
                      lighter = greta:::greta_col('dark'),
                      purple = greta:::greta_col('dark'))

  if (!add) {

    old_mar <- par()$mar
    old_xpd <- par()$xpd
    old_bg <- par()$bg

    on.exit( par(mar = old_mar, xpd = old_xpd, bg = old_bg) )

    par(mar = rep(2, 4),
        xpd = NA,
        bg = bg_col)

    plot.new()
    plot.window(xlim = range(data$coords$x),
                ylim = range(data$coords$y),
                asp = 1)


  }

  # loop though from right to left, plotting points and edges to ensure
  # gaps on either side distances

  x_loc <- sort(unique(data$coords$x),
                decreasing = TRUE)

  for (loc in x_loc) {

    # find relevant nodes and edges
    idx_nodes <- which(data$coords$x %in% loc)
    idx_edges <- which(data$links[, 2] %in% idx_nodes)
    nodes <- data$coords[idx_nodes, , drop = FALSE]
    edges <- data$links[idx_edges, , drop = FALSE]

    # plot nodes with fat edge
    points(y ~ x,
           data = nodes,
           pch = 21,
           bg = node_col,
           col = bg_col,
           cex = pointsize - 1.5,
           lwd = pointsize * 4 * edge_width)

    # plot lines
    for (i in seq_len(nrow(edges))) {
      link <- edges[i, ]
      lines(x = data$coords$x[link],
            y = data$coords$y[link],
            lwd = pointsize * 2.3 * edge_width,
            col = link_col)
    }

    # plot nodes with thin edge
    points(y ~ x,
           data = nodes,
           pch = 21,
           bg = node_col,
           col = bg_col,
           cex = pointsize - 1.5,
           lwd = 0)

  }

}

# greta logo generation
# Muli fontface from: https://fonts.google.com/specimen/Muli

# plot a purple banner, with greta in white
# 'width' gives the width:height ratio
# 'margin' gives the proportion of the vertical height to use a border on each side
# the text is scaled to never exceed that border
#' @importFrom graphics par plot.new plot.window strheight strwidth text
banner <- function (background = c('purple', 'white', 'light', 'lighter'),
                    transparent_bg = FALSE,
                    width = 8, margin = 0.2,
                    font = c('Muli', 'sans'),
                    add_logo = TRUE, ...) {

  font <- match.arg(font)
  background <- match.arg(background)

  # warn if the banner isn't height-filled
  min_width <- 3.184175 + 2 * margin * (1 - 3.184175)
  if (width < min_width) {
    warning ('with a margin of ',
             margin,
             ' the minimum width to ensure the banner is height-filled is ',
             min_width)
  }

  bg_col <- switch (background,
                    white = 'white',
                    light = greta:::greta_col('light'),
                    lighter = greta:::greta_col('lighter'),
                    purple = greta:::greta_col('main'))

  text_col <- switch (background,
                      white = greta:::greta_col('dark'),
                      light = 'white',
                      lighter = greta:::greta_col('dark'),
                      purple = 'white')

  # cache the old graphics options
  old_bg <- par('bg')
  old_mar <- par('mar')
  old_family <- par('family')

  # switch to a purple background, no margins and Muli typeface
  par(bg = ifelse(transparent_bg, NA, bg_col),
      mar = rep(0, 4),
      family = font)

  # set up the device, to have the correct width
  plot.new()
  plot.window(xlim = c(0, width),
              ylim = c(0, 1),
              asp = 1)

  # scale the font, so that 'greta' fills the area (excluding self-imposed
  # margins) either vertically or horizontally
  max_height <- (1 - 2 * margin) / strheight('greta')
  max_width <- (width - 2 * margin) / strwidth('greta')
  fontsize <- min(max_height, max_width)

  # find the final string dimensions
  string_height <- fontsize * strheight('greta')
  string_width <- fontsize * strwidth('greta')

  # how far to indent 'greta'
  xpos <- margin

  # 'g' should be aligned to the left of the box
  text(x = xpos,
       y = 0.5,
       label = 'greta',
       col = text_col,
       cex = fontsize,
       pos = 4,
       offset = 0)

  if (add_logo) {

    plot_logo(background = background,
              add = TRUE,
              x_start = string_width + xpos * 3,
              y_range = 0.55 + string_height * 0.5 * c(-1, 1),
              ...)

  }

  par(bg = old_bg,
      mar = old_mar,
      family = old_family)

  invisible(NULL)

}

# same dimensions as banner, but with no text
blank_banner <- function (width = 8, margin = 0.2) {

  # cache the old graphics options
  old_bg <- par('bg')
  old_mar <- par('mar')

  # switch to a purple background with no margins
  par(bg = greta:::greta_col(),
      mar = rep(0, 4))

  # set up the device, to have the correct width
  plot.new()
  plot.window(xlim = c(0, width),
              ylim = c(0, 1),
              asp = 1)

  par(bg = old_bg,
      mar = old_mar)

  invisible(NULL)

}

# make and save an image of a triangular tesselation GMRF pattern in greta purple
tesselation_image <- function (ncol = 10, nrow = 10,
                               max_edge = 0.08,
                               jitter = 0.1,
                               thickness = 1,
                               line_col = greta:::greta_col('light'),
                               ramp_cols = NULL) {

  if (is.null(ramp_cols)) {
    cols <- c(greta:::greta_col('lighter'),
              greta:::greta_col('light'))
    ramp_cols <- colorRampPalette(cols)(2000)[-(1:1000)]
  }

  require (INLA)
  require (raster)
  require (greta)
  require (fields)

  # grid sizes for sampling the GRF and for the final image
  ncol_sim <- round(ncol / 10)
  nrow_sim <- round(nrow / 10)
  ratio <- ncol / nrow
  grid <- list(x = seq(0, 1, length.out = ncol_sim),
               y = seq(0, 1, length.out = nrow_sim))

  obj <- Exp.image.cov(grid = grid, theta = 0.1, setup = TRUE)

  r <- raster(sim.rf(obj))

  image <- raster(nrow = nrow, ncol = ncol)
  extent(image) <- c(0, ratio, 0, 1)
  extent(r) <- extent(image)


  pts <- expand.grid(seq(0, ratio, length.out = 10),
                     seq(0, 1, length.out = 10))
  pts <- pts + cbind(rnorm(100, 0, jitter),
                     rnorm(100, 0, jitter))

  # make an inla mesh
  sp <- as(extent(image), 'SpatialPolygons')
  mesh <- inla.mesh.2d(loc = pts,
                       boundary = inla.sp2segment(sp),
                       max.edge = max_edge,
                       offset = 0)

  # sample GRF at nodes
  z <- extract(r, mesh$loc[, 1:2])

  # get projection to raster
  image_coords<- xyFromCell(image, 1:ncell(image))
  A <- inla.spde.make.A(mesh, loc = image_coords)

  # instead of linear interpolation, average the three node values
  A2 <- A
  A2@x[A2@x > 0] <- 1/3
  image[] <- (A2 %*% z)[, 1]

  pm <- par("mar")
  on.exit(par(mar = pm))

  par(mar = rep(0, 4))
  image(image,
        col = ramp_cols,
        asp = 1,
        axes = FALSE,
        xlab = '',
        ylab = '')
  plot(mesh,
       add = TRUE,
       edge.color = line_col,
       lwd = thickness,
       draw.segments = FALSE)
  points(mesh$loc,
         pch = 16,
         cex = 0.5 * sqrt(thickness),
         col = line_col)
}