Rotozoomer in base R using {nara}

rotozoomer.R

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Load packages
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
if (FALSE) {
  remotes::install_github('coolbutuseless/colorfast') # Need latest version
  remotes::install_github('coolbutuseless/nara')
  install.packages('governor')
  install.packages('fastpng')
}

library(png) # just for the logo image
library(colorfast)
library(nara)  
library(governor)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Open a fast graphics device
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
x11(type = 'dbcairo', antialias = 'none')
dev.control('inhibit')

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Load Image
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
nr <- nr_new(800, 800, fill = 'grey60')
src <- fastpng::read_png(system.file("img/Rlogo.png", package = "png"), type = 'nativeraster')

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Calculate some sizing information
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
dst_width  <- ncol(nr)
dst_height <- nrow(nr)
src_width  <- ncol(src)
src_height <- nrow(src)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Rotation angles and zoom factors
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
N <- 100; i <- 50
thetas <- c(seq(0, 4 * pi, length.out = N)) 
sfs <- c(displease::seq_ease(1, 4.75, N/2, direction = 'in'), displease::seq_ease(4.75, 1, N/2, direction = 'out'))

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Position of rotozoomed image on destination
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
xoff <- 400 
yoff <- 400

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Helper functions for calculating some rotations
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
rotx <- function(x, y, theta) { x * cos(theta) - y * sin(theta) }
roty <- function(x, y, theta) { x * sin(theta) + y * cos(theta) }

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Setup governor and ensure graphics device is flushed
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
skip <- FALSE
gov <- governor::gov_init(1/15) # 15 fps = 1/15s per frame
while (dev.flush()) {}

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Loop over all thetas/ + scale factors
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
for (i in seq(N)) {
  theta <- thetas[i]
  sf    <- sfs[i]
  
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Find minimal rectangle to interpolate within
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  xmax <- max(
    abs(rotx(src_width/2,  src_height/2, theta)),
    abs(rotx(src_width/2, -src_height/2, theta))
  ) * sf
  
  ymax <- max(
    abs(roty(src_width/2,  src_height/2, theta)),
    abs(roty(src_width/2, -src_height/2, theta))
  ) * sf
  
  xmax <- min(xmax, dst_width /2)
  ymax <- min(ymax, dst_height/2)
  
  df <- expand.grid(x = seq(-xmax, xmax), y = seq(-ymax, ymax))
  
  x <- df$x
  y <- df$y
  
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Blank the canvas
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  nr_fill(nr, 'white')
  
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Rotate each point in 'dst' to find where it is in 'src'
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  x0 <- (x) * cos(theta) - (y) * sin(theta);
  y0 <- (x) * sin(theta) + (y) * cos(theta);
  
  x0 <- (as.integer(x0 * 1/sf) + src_width  / 2)
  y0 <- (as.integer(y0 * 1/sf) + src_height / 2)
  
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Only lookup colours which are within the bounds of the source image
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  valid <- x0 > 0 & y0 > 0 & x0 <= ncol(src) & y0 <= nrow(src)
  x0 <- x0[valid]
  y0 <- y0[valid]
  
  val <- src[x0 + (y0 - 1) * ncol(src)]
  
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Plot the colour in the new
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  nr_point(nr, as.integer(x[valid] + xoff), as.integer(y[valid] + yoff), val)
  
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # control frame rate with governor
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  if (!skip) {
    dev.hold(); plot(nr, T); dev.flush()
  } else {
    cat("Skip", i, "\n");
  }
  skip <- governor::gov_wait(gov)
}